| blob | afe17289fe30709dbce6abba77a1d8d3dd9b2146 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
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.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% OPEN BUGS
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * success continuation optimization
64 %% * analyze history usage to determine whether/when
65 %% cheaper suspension is possible:
66 %% don't use history when all partners are passive and self never triggers
67 %% * store constraint unconditionally for unconditional propagation rule,
68 %% if first, i.e. without checking history and set trigger cont to next occ
69 %% * get rid of suspension passing for never triggered constraints,
70 %% up to allocation occurrence
71 %% * get rid of call indirection for never triggered constraints
72 %% up to first allocation occurrence.
73 %% * get rid of unnecessary indirection if last active occurrence
74 %% before unconditional removal is head2, e.g.
75 %% a \ b <=> true.
76 %% a <=> true.
77 %% * Eliminate last clause of never stored constraint, if its body
78 %% is fail, e.g.
79 %% a ...
80 %% a <=> fail.
81 %% * Specialize lookup operations and indexes for functional dependencies.
82 %%
83 %% MORE TODO
84 %%
85 %% * generate code to empty all constraint stores of a module (Bart Demoen)
86 %% * map A \ B <=> true | true rules
87 %% onto efficient code that empties the constraint stores of B
88 %% in O(1) time for ground constraints where A and B do not share
89 %% any variables
90 %% * ground matching seems to be not optimized for compound terms
91 %% in case of simpagation_head2 and propagation occurrences
92 %% * analysis for storage delaying (see primes for case)
93 %% * internal constraints declaration + analyses?
94 %% * Do not store in global variable store if not necessary
95 %% NOTE: affects show_store/1
96 %% * var_assoc multi-level store: variable - ground
97 %% * Do not maintain/check unnecessary propagation history
98 %% for reasons of anti-monotony
99 %% * Strengthen storage analysis for propagation rules
100 %% reason about bodies of rules only containing constraints
101 %% -> fixpoint with observation analysis
102 %% * instantiation declarations
103 %% COMPOUND (bound to nonvar)
104 %% avoid nonvar tests
105 %%
106 %% * make difference between cheap guards for reordering
107 %% and non-binding guards for lock removal
108 %% * fd -> once/[] transformation for propagation
109 %% * cheap guards interleaved with head retrieval + faster
110 %% via-retrieval + non-empty checking for propagation rules
111 %% redo for simpagation_head2 prelude
112 %% * intelligent backtracking for simplification/simpagation rule
113 %% generator_1(X),'_$savecp'(CP_1),
114 %% ...
115 %% if( (
116 %% generator_n(Y),
117 %% test(X,Y)
118 %% ),
119 %% true,
120 %% ('_$cutto'(CP_1), fail)
121 %% ),
122 %% ...
123 %%
124 %% or recently developped cascading-supported approach
125 %% * intelligent backtracking for propagation rule
126 %% use additional boolean argument for each possible smart backtracking
127 %% when boolean at end of list true -> no smart backtracking
128 %% false -> smart backtracking
129 %% only works for rules with at least 3 constraints in the head
130 %% * (set semantics + functional dependency) declaration + resolution
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %% merged
133 %%
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
137 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
138 ]).
139 %% SWI begin
140 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
141 :- use_module(library(ordsets)).
142 %% SWI end
144 :- use_module(hprolog).
145 :- use_module(pairlist).
146 :- use_module(a_star).
147 :- use_module(listmap).
148 :- use_module(clean_code).
149 :- use_module(builtins).
150 :- use_module(find).
151 :- use_module(binomialheap).
152 :- use_module(guard_entailment).
153 :- use_module(chr_compiler_options).
154 :- use_module(chr_compiler_utility).
155 :- use_module(chr_compiler_errors).
156 :- include(chr_op).
157 :- op(1150, fx, chr_type).
158 :- op(1130, xfx, --->).
159 :- op(980, fx, (+)).
160 :- op(980, fx, (-)).
161 :- op(980, fx, (?)).
162 :- op(1150, fx, constraints).
163 :- op(1150, fx, chr_constraint).
165 :- chr_option(debug,off).
166 :- chr_option(optimize,full).
167 :- chr_option(check_guard_bindings,off).
169 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
171 :- chr_type list(T) ---> [] ; [T|list(T)].
172 :- chr_type list == list(any).
174 :- chr_type maybe(T) ---> yes(T) ; no.
176 :- chr_type constraint ---> any / any.
178 :- chr_type module_name == any.
180 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
181 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
182 :- chr_type idspair ---> ids(list(id),list(id)).
184 :- chr_type pragma_type ---> passive(id)
185 ; mpassive(list(id))
186 ; already_in_heads
187 ; already_in_heads(id)
188 ; no_history
189 ; history(history_name,list(id)).
190 :- chr_type history_name== any.
192 :- chr_type rule_name == any.
193 :- chr_type rule_nb == natural.
194 :- chr_type id == natural.
196 :- chr_type goal == any.
198 :- chr_type store_type ---> default
199 ; multi_store(list(store_type))
200 ; multi_hash(list(list(int)))
201 ; multi_inthash(list(list(int)))
202 ; global_singleton
203 ; global_ground
204 % EXPERIMENTAL STORES
205 ; atomic_constants(list(int),list(any),atomic_coverage)
206 ; ground_constants(list(int),list(any))
207 ; var_assoc_store(int,list(int))
208 ; identifier_store(int)
209 ; type_indexed_identifier_store(int,any).
210 :- chr_type atomic_coverage ---> complete ; incomplete.
212 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
214 %------------------------------------------------------------------------------%
215 :- chr_constraint chr_source_file/1.
216 :- chr_option(mode,chr_source_file(+)).
217 :- chr_option(type_declaration,chr_source_file(module_name)).
218 %------------------------------------------------------------------------------%
219 chr_source_file(_) \ chr_source_file(_) <=> true.
221 %------------------------------------------------------------------------------%
222 :- chr_constraint get_chr_source_file/1.
223 :- chr_option(mode,get_chr_source_file(-)).
224 :- chr_option(type_declaration,get_chr_source_file(module_name)).
225 %------------------------------------------------------------------------------%
226 chr_source_file(Mod) \ get_chr_source_file(Query)
227 <=> Query = Mod .
228 get_chr_source_file(Query)
229 <=> Query = user.
232 %------------------------------------------------------------------------------%
233 :- chr_constraint target_module/1.
234 :- chr_option(mode,target_module(+)).
235 :- chr_option(type_declaration,target_module(module_name)).
236 %------------------------------------------------------------------------------%
237 target_module(_) \ target_module(_) <=> true.
239 %------------------------------------------------------------------------------%
240 :- chr_constraint get_target_module/1.
241 :- chr_option(mode,get_target_module(-)).
242 :- chr_option(type_declaration,get_target_module(module_name)).
243 %------------------------------------------------------------------------------%
244 target_module(Mod) \ get_target_module(Query)
245 <=> Query = Mod .
246 get_target_module(Query)
247 <=> Query = user.
249 %------------------------------------------------------------------------------%
250 :- chr_constraint line_number/2.
251 :- chr_option(mode,line_number(+,+)).
252 %------------------------------------------------------------------------------%
253 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
255 %------------------------------------------------------------------------------%
256 :- chr_constraint get_line_number/2.
257 :- chr_option(mode,get_line_number(+,-)).
258 %------------------------------------------------------------------------------%
259 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
260 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
262 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
263 :- chr_option(mode,indexed_argument(+,+)).
264 :- chr_option(type_declaration,indexed_argument(constraint,int)).
266 :- chr_constraint is_indexed_argument/2.
267 :- chr_option(mode,is_indexed_argument(+,+)).
268 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
270 :- chr_constraint constraint_mode/2.
271 :- chr_option(mode,constraint_mode(+,+)).
272 :- chr_option(type_declaration,constraint_mode(constraint,list)).
274 :- chr_constraint get_constraint_mode/2.
275 :- chr_option(mode,get_constraint_mode(+,-)).
276 :- chr_option(type_declaration,get_constraint_mode(constraint,list)).
278 :- chr_constraint may_trigger/1.
279 :- chr_option(mode,may_trigger(+)).
280 :- chr_option(type_declaration,may_trigger(constraint)).
282 :- chr_constraint only_ground_indexed_arguments/1.
283 :- chr_option(mode,only_ground_indexed_arguments(+)).
284 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
286 :- chr_constraint none_suspended_on_variables/0.
288 :- chr_constraint are_none_suspended_on_variables/0.
290 :- chr_constraint store_type/2.
291 :- chr_option(mode,store_type(+,+)).
292 :- chr_option(type_declaration,store_type(constraint,store_type)).
294 :- chr_constraint get_store_type/2.
295 :- chr_option(mode,get_store_type(+,?)).
296 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
298 :- chr_constraint update_store_type/2.
299 :- chr_option(mode,update_store_type(+,+)).
300 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
302 :- chr_constraint actual_store_types/2.
303 :- chr_option(mode,actual_store_types(+,+)).
304 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
306 :- chr_constraint assumed_store_type/2.
307 :- chr_option(mode,assumed_store_type(+,+)).
308 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
310 :- chr_constraint validate_store_type_assumption/1.
311 :- chr_option(mode,validate_store_type_assumption(+)).
312 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
314 :- chr_constraint rule_count/1.
315 :- chr_option(mode,rule_count(+)).
316 :- chr_option(type_declaration,rule_count(natural)).
318 :- chr_constraint inc_rule_count/1.
319 :- chr_option(mode,inc_rule_count(-)).
320 :- chr_option(type_declaration,inc_rule_count(natural)).
322 rule_count(_) \ rule_count(_)
323 <=> true.
324 rule_count(C), inc_rule_count(NC)
325 <=> NC is C + 1, rule_count(NC).
326 inc_rule_count(NC)
327 <=> NC = 1, rule_count(NC).
329 :- chr_constraint passive/2.
330 :- chr_option(mode,passive(+,+)).
332 :- chr_constraint is_passive/2.
333 :- chr_option(mode,is_passive(+,+)).
335 :- chr_constraint any_passive_head/1.
336 :- chr_option(mode,any_passive_head(+)).
338 :- chr_constraint new_occurrence/4.
339 :- chr_option(mode,new_occurrence(+,+,+,+)).
341 :- chr_constraint occurrence/5.
342 :- chr_option(mode,occurrence(+,+,+,+,+)).
343 :- chr_type occurrence_type ---> simplification ; propagation.
344 :- chr_option(type_declaration,occurrence(any,any,any,any,occurrence_type)).
346 :- chr_constraint get_occurrence/4.
347 :- chr_option(mode,get_occurrence(+,+,-,-)).
349 :- chr_constraint get_occurrence_from_id/4.
350 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
352 :- chr_constraint max_occurrence/2.
353 :- chr_option(mode,max_occurrence(+,+)).
355 :- chr_constraint get_max_occurrence/2.
356 :- chr_option(mode,get_max_occurrence(+,-)).
358 :- chr_constraint allocation_occurrence/2.
359 :- chr_option(mode,allocation_occurrence(+,+)).
361 :- chr_constraint get_allocation_occurrence/2.
362 :- chr_option(mode,get_allocation_occurrence(+,-)).
364 :- chr_constraint rule/2.
365 :- chr_option(mode,rule(+,+)).
366 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
368 :- chr_constraint get_rule/2.
369 :- chr_option(mode,get_rule(+,-)).
370 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
372 :- chr_constraint least_occurrence/2.
373 :- chr_option(mode,least_occurrence(+,+)).
374 :- chr_option(type_declaration,least_occurrence(any,list)).
376 :- chr_constraint is_least_occurrence/1.
377 :- chr_option(mode,is_least_occurrence(+)).
380 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
381 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
382 is_indexed_argument(_,_) <=> fail.
384 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
386 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
387 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
388 Q = Mode.
389 get_constraint_mode(FA,Q) <=>
390 FA = _ / N,
391 replicate(N,(?),Q).
393 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
395 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
396 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
397 nth1(I,Mode,M),
398 M \== (+) |
399 is_stored(FA).
400 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
402 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
403 <=>
404 nth1(I,Mode,M),
405 M \== (+)
406 |
407 fail.
408 only_ground_indexed_arguments(_) <=>
409 true.
411 none_suspended_on_variables \ none_suspended_on_variables <=> true.
412 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
413 are_none_suspended_on_variables <=> fail.
414 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
416 store_type(FA,StoreType)
417 ==> chr_pp_flag(verbose,on)
418 | chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
420 store_type(FA,Store) \ get_store_type(FA,Query)
421 <=> Query = Store.
423 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
424 <=> Query = Store.
425 get_store_type(_,Query)
426 <=> Query = default.
428 actual_store_types(C,STs) \ update_store_type(C,ST)
429 <=> member(ST,STs) | true.
430 update_store_type(C,ST), actual_store_types(C,STs)
431 <=>
432 actual_store_types(C,[ST|STs]).
433 update_store_type(C,ST)
434 <=>
435 actual_store_types(C,[ST]).
437 % refine store type assumption
438 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
439 <=>
440 delete(STs,multi_hash([Index]),STs0),
441 Index = [IndexPos],
442 ( get_constraint_type(C,Types),
443 nth1(IndexPos,Types,Type),
444 enumerated_atomic_type(Type,Atoms),
445 sort(Atoms,Keys) ->
446 Completeness = complete
447 ;
448 Completeness = incomplete
449 ),
450 actual_store_types(C,[atomic_constants(Index,Keys,Completeness)|STs0]).
451 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Keys)
452 <=>
453 delete(STs,multi_hash([Index]),STs0),
454 actual_store_types(C,[ground_constants(Index,Keys)|STs0]).
455 validate_store_type_assumption(C) \ actual_store_types(C,STs)
456 <=>
457 memberchk(multi_hash([[Index]]),STs),
458 get_constraint_type(C,Types),
459 nth1(Index,Types,Type),
460 enumerated_atomic_type(Type,Atoms)
461 |
462 delete(STs,multi_hash([[Index]]),STs0),
463 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
464 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
465 <=>
466 ( ( STs = [ground_constants(_,_)] ; STs = [atomic_constants(_,_,incomplete)]) ->
467 store_type(C,multi_store([global_ground|STs]))
468 ;
469 store_type(C,multi_store(STs))
470 ).
471 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
472 <=>
473 store_type(C,multi_store(STs)).
474 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
475 <=>
476 chr_pp_flag(debugable,on)
477 |
478 store_type(C,default).
479 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
480 <=> store_type(C,global_ground).
481 validate_store_type_assumption(C)
482 <=> true.
484 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
485 passive(R,ID) \ passive(R,ID) <=> true.
487 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
488 is_passive(_,_) <=> fail.
490 passive(RuleNb,_) \ any_passive_head(RuleNb)
491 <=> true.
492 any_passive_head(_)
493 <=> fail.
494 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
496 max_occurrence(C,N) \ max_occurrence(C,M)
497 <=> N >= M | true.
499 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
500 NO is MO + 1,
501 occurrence(C,NO,RuleNb,ID,Type),
502 max_occurrence(C,NO).
503 new_occurrence(C,RuleNb,ID,_) <=>
504 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
506 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
507 <=> Q = MON.
508 get_max_occurrence(C,Q)
509 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
511 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
512 <=> Rule = QRule, ID = QID.
513 get_occurrence(C,O,_,_)
514 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
516 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
517 <=> QC = C, QON = ON.
518 get_occurrence_from_id(C,O,_,_)
519 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
521 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
522 % Late allocation
524 late_allocation_analysis(Cs) :-
525 ( chr_pp_flag(late_allocation,on) ->
526 maplist(late_allocation, Cs)
527 ;
528 true
529 ).
531 late_allocation(C) :- late_allocation(C,0).
532 late_allocation(C,O) :- allocation_occurrence(C,O), !.
533 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
535 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
537 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
539 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
540 \+ is_passive(RuleNb,Id),
541 Type == propagation,
542 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
543 true
544 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
545 is_observed(C,O)
546 ; is_least_occurrence(RuleNb) -> % propagation rule
547 is_observed(C,O)
548 ;
549 true
550 ).
552 stored_in_guard_before_next_kept_occurrence(C,O) :-
553 chr_pp_flag(store_in_guards, on),
554 NO is O + 1,
555 stored_in_guard_lookahead(C,NO).
557 :- chr_constraint stored_in_guard_lookahead/2.
558 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
560 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
561 NO is O + 1, stored_in_guard_lookahead(C,NO).
562 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
563 Type == simplification,
564 ( is_stored_in_guard(C,RuleNb) ->
565 true
566 ;
567 NO is O + 1, stored_in_guard_lookahead(C,NO)
568 ).
569 stored_in_guard_lookahead(_,_) <=> fail.
572 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
573 \ least_occurrence(RuleNb,[ID|IDs])
574 <=> AO >= O, \+ may_trigger(C) |
575 least_occurrence(RuleNb,IDs).
576 rule(RuleNb,Rule), passive(RuleNb,ID)
577 \ least_occurrence(RuleNb,[ID|IDs])
578 <=> least_occurrence(RuleNb,IDs).
580 rule(RuleNb,Rule)
581 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
582 least_occurrence(RuleNb,IDs).
584 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
585 <=> true.
586 is_least_occurrence(_)
587 <=> fail.
589 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
590 <=> Q = O.
591 get_allocation_occurrence(_,Q)
592 <=> chr_pp_flag(late_allocation,off), Q=0.
593 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
595 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
596 <=> Q = Rule.
597 get_rule(_,_)
598 <=> fail.
600 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
602 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
603 %
604 % Default store constraint index assignment.
606 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
607 :- chr_option(mode,constraint_index(+,+)).
608 :- chr_option(type_declaration,constraint_index(constraint,int)).
610 :- chr_constraint get_constraint_index/2.
611 :- chr_option(mode,get_constraint_index(+,-)).
612 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
614 :- chr_constraint get_indexed_constraint/2.
615 :- chr_option(mode,get_indexed_constraint(+,-)).
616 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
618 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
619 :- chr_option(mode,max_constraint_index(+)).
620 :- chr_option(type_declaration,max_constraint_index(int)).
622 :- chr_constraint get_max_constraint_index/1.
623 :- chr_option(mode,get_max_constraint_index(-)).
624 :- chr_option(type_declaration,get_max_constraint_index(int)).
626 constraint_index(C,Index) \ get_constraint_index(C,Query)
627 <=> Query = Index.
628 get_constraint_index(C,Query)
629 <=> fail.
631 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
632 <=> Q = C.
633 get_indexed_constraint(Index,Q)
634 <=> fail.
636 max_constraint_index(Index) \ get_max_constraint_index(Query)
637 <=> Query = Index.
638 get_max_constraint_index(Query)
639 <=> Query = 0.
641 set_constraint_indices(Constraints) :-
642 set_constraint_indices(Constraints,1).
643 set_constraint_indices([],M) :-
644 N is M - 1,
645 max_constraint_index(N).
646 set_constraint_indices([C|Cs],N) :-
647 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
648 ; get_store_type(C,var_assoc_store(_,_))) ->
649 constraint_index(C,N),
650 M is N + 1,
651 set_constraint_indices(Cs,M)
652 ;
653 set_constraint_indices(Cs,N)
654 ).
656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
657 % Identifier Indexes
659 :- chr_constraint identifier_size/1.
660 :- chr_option(mode,identifier_size(+)).
661 :- chr_option(type_declaration,identifier_size(natural)).
663 identifier_size(_) \ identifier_size(_)
664 <=>
665 true.
667 :- chr_constraint get_identifier_size/1.
668 :- chr_option(mode,get_identifier_size(-)).
669 :- chr_option(type_declaration,get_identifier_size(natural)).
671 identifier_size(Size) \ get_identifier_size(Q)
672 <=>
673 Q = Size.
675 get_identifier_size(Q)
676 <=>
677 Q = 1.
679 :- chr_constraint identifier_index/3.
680 :- chr_option(mode,identifier_index(+,+,+)).
681 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
683 identifier_index(C,I,_) \ identifier_index(C,I,_)
684 <=>
685 true.
687 :- chr_constraint get_identifier_index/3.
688 :- chr_option(mode,get_identifier_index(+,+,-)).
689 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
691 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
692 <=>
693 Q = II.
694 identifier_size(Size), get_identifier_index(C,I,Q)
695 <=>
696 NSize is Size + 1,
697 identifier_index(C,I,NSize),
698 identifier_size(NSize),
699 Q = NSize.
700 get_identifier_index(C,I,Q)
701 <=>
702 identifier_index(C,I,2),
703 identifier_size(2),
704 Q = 2.
706 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
707 % Type Indexed Identifier Indexes
709 :- chr_constraint type_indexed_identifier_size/2.
710 :- chr_option(mode,type_indexed_identifier_size(+,+)).
711 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
713 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
714 <=>
715 true.
717 :- chr_constraint get_type_indexed_identifier_size/2.
718 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
719 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
721 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
722 <=>
723 Q = Size.
725 get_type_indexed_identifier_size(IndexType,Q)
726 <=>
727 Q = 1.
729 :- chr_constraint type_indexed_identifier_index/4.
730 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
731 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
733 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
734 <=>
735 true.
737 :- chr_constraint get_type_indexed_identifier_index/4.
738 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
739 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
741 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
742 <=>
743 Q = II.
744 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
745 <=>
746 NSize is Size + 1,
747 type_indexed_identifier_index(IndexType,C,I,NSize),
748 type_indexed_identifier_size(IndexType,NSize),
749 Q = NSize.
750 get_type_indexed_identifier_index(IndexType,C,I,Q)
751 <=>
752 type_indexed_identifier_index(IndexType,C,I,2),
753 type_indexed_identifier_size(IndexType,2),
754 Q = 2.
756 type_indexed_identifier_structure(IndexType,Structure) :-
757 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
758 get_type_indexed_identifier_size(IndexType,Arity),
759 functor(Structure,Functor,Arity).
760 type_indexed_identifier_name(IndexType,Prefix,Name) :-
761 ( atom(IndexType) ->
762 IndexTypeName = IndexType
763 ;
764 term_to_atom(IndexType,IndexTypeName)
765 ),
766 atom_concat_list([Prefix,'_',IndexTypeName],Name).
768 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
773 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
774 %%
775 %% Translation
777 chr_translate(Declarations,NewDeclarations) :-
778 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
780 chr_translate_line_info(Declarations,File,NewDeclarations) :-
781 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',[]),
782 init_chr_pp_flags,
783 chr_source_file(File),
784 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
785 chr_compiler_options:sanity_check,
786 check_declared_constraints(Constraints0),
787 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
788 add_constraints(Constraints),
789 add_rules(Rules1),
790 generate_never_stored_rules(Constraints,NewRules),
791 add_rules(NewRules),
792 append(Rules1,NewRules,Rules),
793 % start analysis
794 check_rules(Rules,Constraints),
795 time('type checking',chr_translate:static_type_check),
796 add_occurrences(Rules),
797 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
798 time('set semantics',chr_translate:set_semantics_rules(Rules)),
799 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
800 time('guard simplification',chr_translate:guard_simplification),
801 time('late storage',chr_translate:storage_analysis(Constraints)),
802 time('observation',chr_translate:observation_analysis(Constraints)),
803 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
804 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
805 partial_wake_analysis,
806 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
807 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
808 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
809 % end analysis
810 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
811 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
812 phase_end(validate_store_type_assumptions),
813 used_states_known,
814 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
815 insert_declarations(OtherClauses, Clauses0),
816 chr_module_declaration(CHRModuleDeclaration),
817 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
818 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
819 append([Clauses0,GeneratedClauses], NewDeclarations).
821 store_management_preds(Constraints,Clauses) :-
822 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
823 generate_attr_unify_hook(AttrUnifyHookClauses),
824 generate_attach_increment(AttachIncrementClauses),
825 generate_extra_clauses(Constraints,ExtraClauses),
826 generate_insert_delete_constraints(Constraints,DeleteClauses),
827 generate_attach_code(Constraints,StoreClauses),
828 generate_counter_code(CounterClauses),
829 generate_dynamic_type_check_clauses(TypeCheckClauses),
830 append([AttachAConstraintClauses
831 ,AttachIncrementClauses
832 ,AttrUnifyHookClauses
833 ,ExtraClauses
834 ,DeleteClauses
835 ,StoreClauses
836 ,CounterClauses
837 ,TypeCheckClauses
838 ]
839 ,Clauses).
842 insert_declarations(Clauses0, Clauses) :-
843 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
844 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
846 auxiliary_module(chr_hashtable_store).
847 auxiliary_module(chr_integertable_store).
848 auxiliary_module(chr_assoc_store).
850 generate_counter_code(Clauses) :-
851 ( chr_pp_flag(store_counter,on) ->
852 Clauses = [
853 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
854 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
855 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
856 (:- '$counter_init'('$insert_counter')),
857 (:- '$counter_init'('$delete_counter')),
858 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
859 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
860 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
861 ]
862 ;
863 Clauses = []
864 ).
866 % for systems with multifile declaration
867 chr_module_declaration(CHRModuleDeclaration) :-
868 get_target_module(Mod),
869 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
870 CHRModuleDeclaration = [
871 (:- multifile chr:'$chr_module'/1),
872 chr:'$chr_module'(Mod)
873 ]
874 ;
875 CHRModuleDeclaration = []
876 ).
879 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
880 %%
881 %% Partitioning of clauses into constraint declarations, chr rules and other
882 %% clauses
884 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
885 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
886 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
887 partition_clauses([],[],[],[]).
888 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
889 ( parse_rule(Clause,Rule) ->
890 ConstraintDeclarations = RestConstraintDeclarations,
891 Rules = [Rule|RestRules],
892 OtherClauses = RestOtherClauses
893 ; is_declaration(Clause,ConstraintDeclaration) ->
894 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
895 Rules = RestRules,
896 OtherClauses = RestOtherClauses
897 ; is_module_declaration(Clause,Mod) ->
898 target_module(Mod),
899 ConstraintDeclarations = RestConstraintDeclarations,
900 Rules = RestRules,
901 OtherClauses = [Clause|RestOtherClauses]
902 ; is_type_definition(Clause) ->
903 ConstraintDeclarations = RestConstraintDeclarations,
904 Rules = RestRules,
905 OtherClauses = RestOtherClauses
906 ; Clause = (handler _) ->
907 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
908 ConstraintDeclarations = RestConstraintDeclarations,
909 Rules = RestRules,
910 OtherClauses = RestOtherClauses
911 ; Clause = (rules _) ->
912 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
913 ConstraintDeclarations = RestConstraintDeclarations,
914 Rules = RestRules,
915 OtherClauses = RestOtherClauses
916 ; Clause = option(OptionName,OptionValue) ->
917 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
918 handle_option(OptionName,OptionValue),
919 ConstraintDeclarations = RestConstraintDeclarations,
920 Rules = RestRules,
921 OtherClauses = RestOtherClauses
922 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
923 handle_option(OptionName,OptionValue),
924 ConstraintDeclarations = RestConstraintDeclarations,
925 Rules = RestRules,
926 OtherClauses = RestOtherClauses
927 ; Clause = ('$chr_compiled_with_version'(_)) ->
928 ConstraintDeclarations = RestConstraintDeclarations,
929 Rules = RestRules,
930 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
931 ; ConstraintDeclarations = RestConstraintDeclarations,
932 Rules = RestRules,
933 OtherClauses = [Clause|RestOtherClauses]
934 ),
935 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
937 '$chr_compiled_with_version'(2).
939 is_declaration(D, Constraints) :- %% constraint declaration
940 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
941 conj2list(Cs,Constraints0)
942 ;
943 ( D = (:- Decl) ->
944 Decl =.. [constraints,Cs]
945 ;
946 D =.. [constraints,Cs]
947 ),
948 conj2list(Cs,Constraints0),
949 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
950 ),
951 extract_type_mode(Constraints0,Constraints).
953 extract_type_mode([],[]).
954 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
955 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
956 ( C0 = C # Annotation ->
957 functor(C,F,A),
958 extract_annotation(Annotation,F/A)
959 ;
960 C0 = C,
961 functor(C,F,A)
962 ),
963 ConstraintSymbol = F/A,
964 C =.. [_|Args],
965 extract_types_and_modes(Args,ArgTypes,ArgModes),
966 constraint_type(ConstraintSymbol,ArgTypes),
967 constraint_mode(ConstraintSymbol,ArgModes),
968 extract_type_mode(R,R2).
970 extract_annotation(stored,Symbol) :-
971 stored_assertion(Symbol).
972 extract_annotation(default(Goal),Symbol) :-
973 never_stored_default(Symbol,Goal).
975 extract_types_and_modes([],[],[]).
976 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
977 extract_type_and_mode(X,T,M),
978 extract_types_and_modes(R,R2,R3).
980 extract_type_and_mode(+(T),T,(+)) :- !.
981 extract_type_and_mode(?(T),T,(?)) :- !.
982 extract_type_and_mode(-(T),T,(-)) :- !.
983 extract_type_and_mode((+),any,(+)) :- !.
984 extract_type_and_mode((?),any,(?)) :- !.
985 extract_type_and_mode((-),any,(-)) :- !.
986 extract_type_and_mode(Illegal,_,_) :-
987 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
989 is_type_definition(Declaration) :-
990 ( Declaration = (:- TDef) ->
991 true
992 ;
993 Declaration = TDef
994 ),
995 TDef =.. [chr_type,TypeDef],
996 ( TypeDef = (Name ---> Def) ->
997 tdisj2list(Def,DefList),
998 type_definition(Name,DefList)
999 ; TypeDef = (Alias == Name) ->
1000 type_alias(Alias,Name)
1001 ;
1002 type_definition(TypeDef,[]),
1003 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1004 ).
1006 %% tdisj2list(+Goal,-ListOfGoals) is det.
1007 %
1008 % no removal of fails, e.g. :- type bool ---> true ; fail.
1009 tdisj2list(Conj,L) :-
1010 tdisj2list(Conj,L,[]).
1012 tdisj2list(Conj,L,T) :-
1013 Conj = (G1;G2), !,
1014 tdisj2list(G1,L,T1),
1015 tdisj2list(G2,T1,T).
1016 tdisj2list(G,[G | T],T).
1019 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1020 %% parse_rule(+term,-pragma_rule) is semidet.
1021 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1022 parse_rule(RI,R) :- %% name @ rule
1023 RI = (Name @ RI2), !,
1024 rule(RI2,yes(Name),R).
1025 parse_rule(RI,R) :-
1026 rule(RI,no,R).
1028 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1029 %% parse_rule(+term,-pragma_rule) is semidet.
1030 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1031 rule(RI,Name,R) :-
1032 RI = (RI2 pragma P), !, %% pragmas
1033 ( var(P) ->
1034 Ps = [_] % intercept variable
1035 ;
1036 conj2list(P,Ps)
1037 ),
1038 inc_rule_count(RuleCount),
1039 R = pragma(R1,IDs,Ps,Name,RuleCount),
1040 is_rule(RI2,R1,IDs,R).
1041 rule(RI,Name,R) :-
1042 inc_rule_count(RuleCount),
1043 R = pragma(R1,IDs,[],Name,RuleCount),
1044 is_rule(RI,R1,IDs,R).
1046 is_rule(RI,R,IDs,RC) :- %% propagation rule
1047 RI = (H ==> B), !,
1048 conj2list(H,Head2i),
1049 get_ids(Head2i,IDs2,Head2,RC),
1050 IDs = ids([],IDs2),
1051 ( B = (G | RB) ->
1052 R = rule([],Head2,G,RB)
1053 ;
1054 R = rule([],Head2,true,B)
1055 ).
1056 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1057 RI = (H <=> B), !,
1058 ( B = (G | RB) ->
1059 Guard = G,
1060 Body = RB
1061 ; Guard = true,
1062 Body = B
1063 ),
1064 ( H = (H1 \ H2) ->
1065 conj2list(H1,Head2i),
1066 conj2list(H2,Head1i),
1067 get_ids(Head2i,IDs2,Head2,0,N,RC),
1068 get_ids(Head1i,IDs1,Head1,N,_,RC),
1069 IDs = ids(IDs1,IDs2)
1070 ; conj2list(H,Head1i),
1071 Head2 = [],
1072 get_ids(Head1i,IDs1,Head1,RC),
1073 IDs = ids(IDs1,[])
1074 ),
1075 R = rule(Head1,Head2,Guard,Body).
1077 get_ids(Cs,IDs,NCs,RC) :-
1078 get_ids(Cs,IDs,NCs,0,_,RC).
1080 get_ids([],[],[],N,N,_).
1081 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1082 ( C = (NC # N1) ->
1083 ( var(N1) ->
1084 N1 = N
1085 ;
1086 check_direct_pragma(N1,N,RC)
1087 )
1088 ;
1089 NC = C
1090 ),
1091 M is N + 1,
1092 get_ids(Cs,IDs,NCs, M,NN,RC).
1094 check_direct_pragma(passive,Id,PragmaRule) :- !,
1095 PragmaRule = pragma(_,_,_,_,RuleNb),
1096 passive(RuleNb,Id).
1097 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1098 ( direct_pragma(FullPragma),
1099 atom_concat(Abbrev,Remainder,FullPragma) ->
1100 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1101 ;
1102 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1103 ).
1105 direct_pragma(passive).
1107 is_module_declaration((:- module(Mod)),Mod).
1108 is_module_declaration((:- module(Mod,_)),Mod).
1110 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1112 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1113 % Add constraints
1114 add_constraints([]).
1115 add_constraints([C|Cs]) :-
1116 max_occurrence(C,0),
1117 C = _/A,
1118 length(Mode,A),
1119 set_elems(Mode,?),
1120 constraint_mode(C,Mode),
1121 add_constraints(Cs).
1123 % Add rules
1124 add_rules([]).
1125 add_rules([Rule|Rules]) :-
1126 Rule = pragma(_,_,_,_,RuleNb),
1127 rule(RuleNb,Rule),
1128 add_rules(Rules).
1130 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1132 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1133 %% Some input verification:
1135 check_declared_constraints(Constraints) :-
1136 check_declared_constraints(Constraints,[]).
1138 check_declared_constraints([],_).
1139 check_declared_constraints([C|Cs],Acc) :-
1140 ( memberchk_eq(C,Acc) ->
1141 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1142 ;
1143 true
1144 ),
1145 check_declared_constraints(Cs,[C|Acc]).
1147 %% - all constraints in heads are declared constraints
1148 %% - all passive pragmas refer to actual head constraints
1150 check_rules([],_).
1151 check_rules([PragmaRule|Rest],Decls) :-
1152 check_rule(PragmaRule,Decls),
1153 check_rules(Rest,Decls).
1155 check_rule(PragmaRule,Decls) :-
1156 check_rule_indexing(PragmaRule),
1157 check_trivial_propagation_rule(PragmaRule),
1158 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1159 Rule = rule(H1,H2,_,_),
1160 append(H1,H2,HeadConstraints),
1161 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1162 check_pragmas(Pragmas,PragmaRule).
1164 % Make all heads passive in trivial propagation rule
1165 % ... ==> ... | true.
1166 check_trivial_propagation_rule(PragmaRule) :-
1167 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1168 ( Rule = rule([],_,_,true) ->
1169 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1170 set_all_passive(RuleNb)
1171 ;
1172 true
1173 ).
1175 check_head_constraints([],_,_).
1176 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1177 functor(Constr,F,A),
1178 ( member(F/A,Decls) ->
1179 check_head_constraints(Rest,Decls,PragmaRule)
1180 ;
1181 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1182 ).
1184 check_pragmas([],_).
1185 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1186 check_pragma(Pragma,PragmaRule),
1187 check_pragmas(Pragmas,PragmaRule).
1189 check_pragma(Pragma,PragmaRule) :-
1190 var(Pragma), !,
1191 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1192 check_pragma(passive(ID), PragmaRule) :-
1193 !,
1194 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1195 ( memberchk_eq(ID,IDs1) ->
1196 true
1197 ; memberchk_eq(ID,IDs2) ->
1198 true
1199 ;
1200 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1201 ),
1202 passive(RuleNb,ID).
1204 check_pragma(mpassive(IDs), PragmaRule) :-
1205 !,
1206 PragmaRule = pragma(_,_,_,_,RuleNb),
1207 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1208 maplist(passive(RuleNb),IDs).
1210 check_pragma(Pragma, PragmaRule) :-
1211 Pragma = already_in_heads,
1212 !,
1213 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1215 check_pragma(Pragma, PragmaRule) :-
1216 Pragma = already_in_head(_),
1217 !,
1218 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1220 check_pragma(Pragma, PragmaRule) :-
1221 Pragma = no_history,
1222 !,
1223 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1224 PragmaRule = pragma(_,_,_,_,N),
1225 no_history(N).
1227 check_pragma(Pragma, PragmaRule) :-
1228 Pragma = history(HistoryName,IDs),
1229 !,
1230 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1231 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1232 ( IDs1 \== [] ->
1233 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1234 ; \+ atom(HistoryName) ->
1235 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1236 ; \+ is_set(IDs) ->
1237 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1238 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1239 history(RuleNb,HistoryName,IDs)
1240 ;
1241 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1242 ).
1243 check_pragma(Pragma,PragmaRule) :-
1244 Pragma = line_number(LineNumber),
1245 !,
1246 PragmaRule = pragma(_,_,_,_,RuleNb),
1247 line_number(RuleNb,LineNumber).
1249 check_history_pragma_ids([], _, _).
1250 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1251 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1252 check_history_pragma_ids(IDs,IDs1,IDs2).
1254 check_pragma(Pragma,PragmaRule) :-
1255 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1257 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1258 %% no_history(+RuleNb) is det.
1259 :- chr_constraint no_history/1.
1260 :- chr_option(mode,no_history(+)).
1261 :- chr_option(type_declaration,no_history(int)).
1263 %% has_no_history(+RuleNb) is semidet.
1264 :- chr_constraint has_no_history/1.
1265 :- chr_option(mode,has_no_history(+)).
1266 :- chr_option(type_declaration,has_no_history(int)).
1268 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1269 has_no_history(_) <=> fail.
1271 :- chr_constraint history/3.
1272 :- chr_option(mode,history(+,+,+)).
1273 :- chr_option(type_declaration,history(any,any,list)).
1275 :- chr_constraint named_history/3.
1277 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1278 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1280 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1281 length(IDs1,L1), length(IDs2,L2),
1282 ( L1 \== L2 ->
1283 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1284 ;
1285 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1286 ).
1288 test_named_history_id_pairs(_, [], _, []).
1289 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1290 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1291 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1293 :- chr_constraint test_named_history_id_pair/4.
1294 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1296 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1297 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1298 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1299 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1301 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1302 named_history(_,_,_) <=> fail.
1304 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1307 format_rule(PragmaRule) :-
1308 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1309 ( MaybeName = yes(Name) ->
1310 write('rule '), write(Name)
1311 ;
1312 write('rule number '), write(RuleNumber)
1313 ),
1314 get_line_number(RuleNumber,LineNumber),
1315 write(' (line '),
1316 write(LineNumber),
1317 write(')').
1319 check_rule_indexing(PragmaRule) :-
1320 PragmaRule = pragma(Rule,_,_,_,_),
1321 Rule = rule(H1,H2,G,_),
1322 term_variables(H1-H2,HeadVars),
1323 remove_anti_monotonic_guards(G,HeadVars,NG),
1324 check_indexing(H1,NG-H2),
1325 check_indexing(H2,NG-H1),
1326 % EXPERIMENT
1327 ( chr_pp_flag(term_indexing,on) ->
1328 term_variables(NG,GuardVariables),
1329 append(H1,H2,Heads),
1330 check_specs_indexing(Heads,GuardVariables,Specs)
1331 ;
1332 true
1333 ).
1335 :- chr_constraint indexing_spec/2.
1336 :- chr_option(mode,indexing_spec(+,+)).
1338 :- chr_constraint get_indexing_spec/2.
1339 :- chr_option(mode,get_indexing_spec(+,-)).
1342 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1343 get_indexing_spec(_,Spec) <=> Spec = [].
1345 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1346 <=>
1347 append(Specs1,Specs2,Specs),
1348 indexing_spec(FA,Specs).
1350 remove_anti_monotonic_guards(G,Vars,NG) :-
1351 conj2list(G,GL),
1352 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1353 list2conj(NGL,NG).
1355 remove_anti_monotonic_guard_list([],_,[]).
1356 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1357 ( G = var(X), memberchk_eq(X,Vars) ->
1358 NGs = RGs
1359 % TODO: this is not correct
1360 % ; G = functor(Term,Functor,Arity), % isotonic
1361 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1362 % NGs = RGs
1363 ;
1364 NGs = [G|RGs]
1365 ),
1366 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1368 check_indexing([],_).
1369 check_indexing([Head|Heads],Other) :-
1370 functor(Head,F,A),
1371 Head =.. [_|Args],
1372 term_variables(Heads-Other,OtherVars),
1373 check_indexing(Args,1,F/A,OtherVars),
1374 check_indexing(Heads,[Head|Other]).
1376 check_indexing([],_,_,_).
1377 check_indexing([Arg|Args],I,FA,OtherVars) :-
1378 ( is_indexed_argument(FA,I) ->
1379 true
1380 ; nonvar(Arg) ->
1381 indexed_argument(FA,I)
1382 ; % var(Arg) ->
1383 term_variables(Args,ArgsVars),
1384 append(ArgsVars,OtherVars,RestVars),
1385 ( memberchk_eq(Arg,RestVars) ->
1386 indexed_argument(FA,I)
1387 ;
1388 true
1389 )
1390 ),
1391 J is I + 1,
1392 term_variables(Arg,NVars),
1393 append(NVars,OtherVars,NOtherVars),
1394 check_indexing(Args,J,FA,NOtherVars).
1396 check_specs_indexing([],_,[]).
1397 check_specs_indexing([Head|Heads],Variables,Specs) :-
1398 Specs = [Spec|RSpecs],
1399 term_variables(Heads,OtherVariables,Variables),
1400 check_spec_indexing(Head,OtherVariables,Spec),
1401 term_variables(Head,NVariables,Variables),
1402 check_specs_indexing(Heads,NVariables,RSpecs).
1404 check_spec_indexing(Head,OtherVariables,Spec) :-
1405 functor(Head,F,A),
1406 Spec = spec(F,A,ArgSpecs),
1407 Head =.. [_|Args],
1408 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1409 indexing_spec(F/A,[ArgSpecs]).
1411 check_args_spec_indexing([],_,_,[]).
1412 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1413 term_variables(Args,Variables,OtherVariables),
1414 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1415 ArgSpecs = [ArgSpec|RArgSpecs]
1416 ;
1417 ArgSpecs = RArgSpecs
1418 ),
1419 J is I + 1,
1420 term_variables(Arg,NOtherVariables,OtherVariables),
1421 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1423 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1424 ( var(Arg) ->
1425 memberchk_eq(Arg,Variables),
1426 ArgSpec = specinfo(I,any,[])
1427 ;
1428 functor(Arg,F,A),
1429 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1430 Arg =.. [_|Args],
1431 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1432 ).
1434 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1436 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1437 % Occurrences
1439 add_occurrences([]).
1440 add_occurrences([Rule|Rules]) :-
1441 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1442 add_occurrences(H1,IDs1,simplification,Nb),
1443 add_occurrences(H2,IDs2,propagation,Nb),
1444 add_occurrences(Rules).
1446 add_occurrences([],[],_,_).
1447 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1448 functor(H,F,A),
1449 FA = F/A,
1450 new_occurrence(FA,RuleNb,ID,Type),
1451 add_occurrences(Hs,IDs,Type,RuleNb).
1453 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1455 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1456 % Observation Analysis
1457 %
1458 % CLASSIFICATION
1459 %
1460 %
1461 %
1462 %
1463 %
1464 %
1466 :- chr_constraint observation_analysis/1.
1467 :- chr_option(mode, observation_analysis(+)).
1469 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1470 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1471 ( chr_pp_flag(store_in_guards, on) ->
1472 observation_analysis(RuleNb, Guard, guard, Cs)
1473 ;
1474 true
1475 ),
1476 observation_analysis(RuleNb, Body, body, Cs)
1478 pragma passive(Id).
1479 observation_analysis(_) <=> true.
1481 observation_analysis(RuleNb, Term, GB, Cs) :-
1482 ( all_spawned(RuleNb,GB) ->
1483 true
1484 ; var(Term) ->
1485 spawns_all(RuleNb,GB)
1486 ; Term = true ->
1487 true
1488 ; Term = fail ->
1489 true
1490 ; Term = '!' ->
1491 true
1492 ; Term = (T1,T2) ->
1493 observation_analysis(RuleNb,T1,GB,Cs),
1494 observation_analysis(RuleNb,T2,GB,Cs)
1495 ; Term = (T1;T2) ->
1496 observation_analysis(RuleNb,T1,GB,Cs),
1497 observation_analysis(RuleNb,T2,GB,Cs)
1498 ; Term = (T1->T2) ->
1499 observation_analysis(RuleNb,T1,GB,Cs),
1500 observation_analysis(RuleNb,T2,GB,Cs)
1501 ; Term = (\+ T) ->
1502 observation_analysis(RuleNb,T,GB,Cs)
1503 ; functor(Term,F,A), member(F/A,Cs) ->
1504 spawns(RuleNb,GB,F/A)
1505 ; Term = (_ = _) ->
1506 spawns_all_triggers(RuleNb,GB)
1507 ; Term = (_ is _) ->
1508 spawns_all_triggers(RuleNb,GB)
1509 ; builtin_binds_b(Term,Vars) ->
1510 ( Vars == [] ->
1511 true
1512 ;
1513 spawns_all_triggers(RuleNb,GB)
1514 )
1515 ;
1516 spawns_all(RuleNb,GB)
1517 ).
1519 :- chr_constraint spawns/3.
1520 :- chr_option(mode, spawns(+,+,+)).
1521 :- chr_type spawns_type ---> guard ; body.
1522 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1524 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1525 :- chr_option(mode, spawns_all(+,+)).
1526 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1527 :- chr_option(mode, spawns_all_triggers(+,+)).
1528 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1530 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1531 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1532 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1533 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1534 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1535 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1537 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1538 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1539 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1540 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1542 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1543 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1545 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1546 \
1547 spawns(RuleNb1,GB,C1)
1548 <=>
1549 \+ is_passive(RuleNb2,O)
1550 |
1551 spawns_all(RuleNb1,GB)
1552 pragma
1553 passive(Id).
1555 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1556 ==>
1557 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1558 \+ is_passive(RuleNb2,O), may_trigger(C1)
1559 |
1560 spawns_all_triggers_implies_spawns_all
1561 pragma
1562 passive(Id).
1564 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1565 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1566 spawns_all_triggers_implies_spawns_all \
1567 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1569 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1570 \
1571 spawns(RuleNb1,GB,C1)
1572 <=>
1573 may_trigger(C1),
1574 \+ is_passive(RuleNb2,O)
1575 |
1576 spawns_all_triggers(RuleNb1,GB)
1577 pragma
1578 passive(Id).
1580 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1581 spawns(RuleNb1,GB,C1)
1582 ==>
1583 \+ may_trigger(C1),
1584 \+ is_passive(RuleNb2,O)
1585 |
1586 spawns_all_triggers(RuleNb1,GB)
1587 pragma
1588 passive(Id).
1590 % a bit dangerous this rule: could start propagating too much too soon?
1591 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1592 spawns(RuleNb1,GB,C1)
1593 ==>
1594 RuleNb1 \== RuleNb2, C1 \== C2,
1595 \+ is_passive(RuleNb2,O)
1596 |
1597 spawns(RuleNb1,GB,C2)
1598 pragma
1599 passive(Id).
1601 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1602 spawns_all_triggers(RuleNb1,GB)
1603 ==>
1604 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1605 |
1606 spawns(RuleNb1,GB,C2)
1607 pragma
1608 passive(Id).
1611 :- chr_constraint all_spawned/2.
1612 :- chr_option(mode, all_spawned(+,+)).
1613 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1614 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1615 all_spawned(RuleNb,GB) <=> fail.
1618 % Overview of the supported queries:
1619 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1620 % only succeeds if the occurrence is observed by the
1621 % guard resp. body (depending on the last argument) of its rule
1622 % is_observed(+functor/artiy, +occurrence_number, -)
1623 % succeeds if the occurrence is observed by either the guard or
1624 % the body of its rule
1625 % NOTE: the last argument is NOT bound by this query
1626 %
1627 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1628 % succeeds if the given constraint is observed by the given
1629 % guard resp. body
1630 % do_is_observed(+functor/artiy,+rule_number)
1631 % succeeds if the given constraint is observed by the given
1632 % rule (either its guard or its body)
1635 is_observed(C,O) :-
1636 is_observed(C,O,_),
1637 ai_is_observed(C,O).
1639 is_stored_in_guard(C,RuleNb) :-
1640 chr_pp_flag(store_in_guards, on),
1641 do_is_observed(C,RuleNb,guard).
1643 :- chr_constraint is_observed/3.
1644 :- chr_option(mode, is_observed(+,+,+)).
1645 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1646 is_observed(_,_,_) <=> fail. % this will not happen in practice
1649 :- chr_constraint do_is_observed/3.
1650 :- chr_option(mode, do_is_observed(+,+,+)).
1651 :- chr_constraint do_is_observed/2.
1652 :- chr_option(mode, do_is_observed(+,+)).
1654 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1656 % (1) spawns_all
1657 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1658 % and some non-passive occurrence of some (possibly other) constraint
1659 % exists in a rule (could be same rule) with at least one occurrence of C
1661 spawns_all(RuleNb,GB),
1662 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1663 \
1664 do_is_observed(C,RuleNb,GB)
1665 <=>
1666 \+ is_passive(RuleNb2,O)
1667 |
1668 true.
1670 spawns_all(RuleNb,_),
1671 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1672 \
1673 do_is_observed(C,RuleNb)
1674 <=>
1675 \+ is_passive(RuleNb2,O)
1676 |
1677 true.
1679 % (2) spawns
1680 % a constraint C is observed if the GB of the rule it occurs in spawns a
1681 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1682 % as an occurrence of C
1684 spawns(RuleNb,GB,C2),
1685 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1686 \
1687 do_is_observed(C,RuleNb,GB)
1688 <=>
1689 \+ is_passive(RuleNb2,O)
1690 |
1691 true.
1693 spawns(RuleNb,_,C2),
1694 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1695 \
1696 do_is_observed(C,RuleNb)
1697 <=>
1698 \+ is_passive(RuleNb2,O)
1699 |
1700 true.
1702 % (3) spawns_all_triggers
1703 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1704 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1705 % exists in a rule (could be same rule) with at least one occurrence of C
1707 spawns_all_triggers(RuleNb,GB),
1708 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1709 \
1710 do_is_observed(C,RuleNb,GB)
1711 <=>
1712 \+ is_passive(RuleNb2,O), may_trigger(C2)
1713 |
1714 true.
1716 spawns_all_triggers(RuleNb,_),
1717 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1718 \
1719 do_is_observed(C,RuleNb)
1720 <=>
1721 \+ is_passive(RuleNb2,O), may_trigger(C2)
1722 |
1723 true.
1725 % (4) conservativeness
1726 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1727 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1730 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1732 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1734 %%
1735 %% Generated predicates
1736 %% attach_$CONSTRAINT
1737 %% attach_increment
1738 %% detach_$CONSTRAINT
1739 %% attr_unify_hook
1741 %% attach_$CONSTRAINT
1742 generate_attach_detach_a_constraint_all([],[]).
1743 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1744 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1745 generate_attach_a_constraint(Constraint,Clauses1),
1746 generate_detach_a_constraint(Constraint,Clauses2)
1747 ;
1748 Clauses1 = [],
1749 Clauses2 = []
1750 ),
1751 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1752 append([Clauses1,Clauses2,Clauses3],Clauses).
1754 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1755 generate_attach_a_constraint_nil(Constraint,Clause1),
1756 generate_attach_a_constraint_cons(Constraint,Clause2).
1758 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1759 make_name('attach_',FA,Name),
1760 Atom =.. [Name,Vars,Susp].
1762 generate_attach_a_constraint_nil(FA,Clause) :-
1763 Clause = (Head :- true),
1764 attach_constraint_atom(FA,[],_,Head).
1766 generate_attach_a_constraint_cons(FA,Clause) :-
1767 Clause = (Head :- Body),
1768 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1769 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1770 Body = ( AttachBody, Subscribe, RecursiveCall ),
1771 get_max_constraint_index(N),
1772 ( N == 1 ->
1773 generate_attach_body_1(FA,Var,Susp,AttachBody)
1774 ;
1775 generate_attach_body_n(FA,Var,Susp,AttachBody)
1776 ),
1777 % SWI-Prolog specific code
1778 chr_pp_flag(solver_events,NMod),
1779 ( NMod \== none ->
1780 Args = [[Var|_],Susp],
1781 get_target_module(Mod),
1782 use_auxiliary_predicate(run_suspensions),
1783 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1784 ;
1785 Subscribe = true
1786 ).
1788 generate_attach_body_1(FA,Var,Susp,Body) :-
1789 get_target_module(Mod),
1790 Body =
1791 ( get_attr(Var, Mod, Susps) ->
1792 put_attr(Var, Mod, [Susp|Susps])
1793 ;
1794 put_attr(Var, Mod, [Susp])
1795 ).
1797 generate_attach_body_n(F/A,Var,Susp,Body) :-
1798 get_constraint_index(F/A,Position),
1799 get_max_constraint_index(Total),
1800 get_target_module(Mod),
1801 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1802 singleton_attr(Total,Susp,Position,NewAttr3),
1803 Body =
1804 ( get_attr(Var,Mod,TAttr) ->
1805 AddGoal,
1806 put_attr(Var,Mod,NTAttr)
1807 ;
1808 put_attr(Var,Mod,NewAttr3)
1809 ), !.
1811 %% detach_$CONSTRAINT
1812 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1813 generate_detach_a_constraint_nil(Constraint,Clause1),
1814 generate_detach_a_constraint_cons(Constraint,Clause2).
1816 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1817 make_name('detach_',FA,Name),
1818 Atom =.. [Name,Vars,Susp].
1820 generate_detach_a_constraint_nil(FA,Clause) :-
1821 Clause = ( Head :- true),
1822 detach_constraint_atom(FA,[],_,Head).
1824 generate_detach_a_constraint_cons(FA,Clause) :-
1825 Clause = (Head :- Body),
1826 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1827 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1828 Body = ( DetachBody, RecursiveCall ),
1829 get_max_constraint_index(N),
1830 ( N == 1 ->
1831 generate_detach_body_1(FA,Var,Susp,DetachBody)
1832 ;
1833 generate_detach_body_n(FA,Var,Susp,DetachBody)
1834 ).
1836 generate_detach_body_1(FA,Var,Susp,Body) :-
1837 get_target_module(Mod),
1838 Body =
1839 ( get_attr(Var,Mod,Susps) ->
1840 'chr sbag_del_element'(Susps,Susp,NewSusps),
1841 ( NewSusps == [] ->
1842 del_attr(Var,Mod)
1843 ;
1844 put_attr(Var,Mod,NewSusps)
1845 )
1846 ;
1847 true
1848 ).
1850 generate_detach_body_n(F/A,Var,Susp,Body) :-
1851 get_constraint_index(F/A,Position),
1852 get_max_constraint_index(Total),
1853 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1854 get_target_module(Mod),
1855 Body =
1856 ( get_attr(Var,Mod,TAttr) ->
1857 RemGoal
1858 ;
1859 true
1860 ), !.
1862 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1863 %-------------------------------------------------------------------------------
1864 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1865 :- chr_constraint generate_indexed_variables_body/4.
1866 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1867 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1868 %-------------------------------------------------------------------------------
1869 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1870 get_indexing_spec(F/A,Specs),
1871 ( chr_pp_flag(term_indexing,on) ->
1872 spectermvars(Specs,Args,F,A,Body,Vars)
1873 ;
1874 get_constraint_type_det(F/A,ArgTypes),
1875 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1876 ( MaybeBody == empty ->
1877 Body = true,
1878 Vars = []
1879 ; N == 0 ->
1880 ( Args = [Term] ->
1881 true
1882 ;
1883 Term =.. [term|Args]
1884 ),
1885 Body = term_variables(Term,Vars)
1886 ;
1887 MaybeBody = Body
1888 )
1889 ).
1890 generate_indexed_variables_body(FA,_,_,_) <=>
1891 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1892 %===============================================================================
1894 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1895 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1896 J is I + 1,
1897 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1898 ( Mode == (?),
1899 is_indexed_argument(FA,I) ->
1900 ( atomic_type(Type) ->
1901 Body =
1902 (
1903 ( var(V) ->
1904 Vars = [V|Tail]
1905 ;
1906 Vars = Tail
1907 ),
1908 Continuation
1909 ),
1910 ( RBody == empty ->
1911 Continuation = true, Tail = []
1912 ;
1913 Continuation = RBody
1914 )
1915 ;
1916 ( RBody == empty ->
1917 Body = term_variables(V,Vars)
1918 ;
1919 Body = (term_variables(V,Vars,Tail),RBody)
1920 )
1921 ),
1922 N = M
1923 ; Mode == (-), is_indexed_argument(FA,I) ->
1924 ( RBody == empty ->
1925 Body = (Vars = [V])
1926 ;
1927 Body = (Vars = [V|Tail],RBody)
1928 ),
1929 N is M + 1
1930 ;
1931 Vars = Tail,
1932 Body = RBody,
1933 N is M + 1
1934 ).
1935 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1936 % EXPERIMENTAL
1937 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1938 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1940 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1941 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1942 Goal = (ArgGoal,RGoal),
1943 argspecs(Specs,I,TempArgSpecs,RSpecs),
1944 merge_argspecs(TempArgSpecs,ArgSpecs),
1945 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1946 J is I + 1,
1947 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1949 argspecs([],_,[],[]).
1950 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1951 argspecs(Rest,I,ArgSpecs,RestSpecs).
1952 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1953 ( I == J ->
1954 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1955 ( Specs = [] ->
1956 RRestSpecs = RestSpecs
1957 ;
1958 RestSpecs = [Specs|RRestSpecs]
1959 )
1960 ;
1961 ArgSpecs = RArgSpecs,
1962 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1963 ),
1964 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1966 merge_argspecs(In,Out) :-
1967 sort(In,Sorted),
1968 merge_argspecs_(Sorted,Out).
1970 merge_argspecs_([],[]).
1971 merge_argspecs_([X],R) :- !, R = [X].
1972 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1973 ( (F1 == any ; F2 == any) ->
1974 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1975 ; F1 == F2 ->
1976 append(A1,A2,A),
1977 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1978 ;
1979 R = [specinfo(I,F1,A1)|RR],
1980 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1981 ).
1983 arggoal(List,Arg,Goal,L,T) :-
1984 ( List == [] ->
1985 L = T,
1986 Goal = true
1987 ; List = [specinfo(_,any,_)] ->
1988 Goal = term_variables(Arg,L,T)
1989 ;
1990 Goal =
1991 ( var(Arg) ->
1992 L = [Arg|T]
1993 ;
1994 Cases
1995 ),
1996 arggoal_cases(List,Arg,L,T,Cases)
1997 ).
1999 arggoal_cases([],_,L,T,L=T).
2000 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2001 ( ArgSpecs == [] ->
2002 Cases = RCases
2003 ; ArgSpecs == [[]] ->
2004 Cases = RCases
2005 ; FA = F/A ->
2006 Cases = (Case ; RCases),
2007 functor(Term,F,A),
2008 Term =.. [_|Args],
2009 Case = (Arg = Term -> ArgsGoal),
2010 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2011 ),
2012 arggoal_cases(Rest,Arg,L,T,RCases).
2013 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2015 generate_extra_clauses(Constraints,List) :-
2016 generate_activate_clauses(Constraints,List,Tail0),
2017 generate_remove_clauses(Constraints,Tail0,Tail1),
2018 generate_allocate_clauses(Constraints,Tail1,Tail2),
2019 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2020 generate_novel_production(Tail3,Tail4),
2021 generate_extend_history(Tail4,Tail5),
2022 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2023 generate_empty_named_history_initialisations(Tail6,Tail7),
2024 Tail7 = [].
2026 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2027 % remove_constraint_internal/[1/3]
2029 generate_remove_clauses([],List,List).
2030 generate_remove_clauses([C|Cs],List,Tail) :-
2031 generate_remove_clause(C,List,List1),
2032 generate_remove_clauses(Cs,List1,Tail).
2034 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2035 uses_state(Constraint,removed),
2036 ( chr_pp_flag(inline_insertremove,off) ->
2037 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2038 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2039 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2040 ;
2041 delay_phase_end(validate_store_type_assumptions,
2042 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2043 )
2044 ).
2046 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2047 make_name('$remove_constraint_internal_',Constraint,Name),
2048 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2049 Goal =.. [Name, Susp,Delete]
2050 ;
2051 Goal =.. [Name,Susp,Agenda,Delete]
2052 ).
2054 generate_remove_clause(Constraint,List,Tail) :-
2055 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2056 List = [RemoveClause|Tail],
2057 RemoveClause = (Head :- RemoveBody),
2058 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2059 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2060 ;
2061 List = Tail
2062 ).
2064 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2065 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2066 ( Role == active ->
2067 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2068 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2069 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2070 ; Role == partner ->
2071 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2072 GetStateValue = true,
2073 MaybeDelete = DeleteYes
2074 ),
2075 RemoveBody =
2076 (
2077 GetState,
2078 GetStateValue,
2079 UpdateState,
2080 MaybeDelete
2081 )
2082 ;
2083 static_suspension_term(Constraint,Susp2),
2084 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2085 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2086 ( chr_pp_flag(debugable,on) ->
2087 Constraint = Functor / _,
2088 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2089 ;
2090 true
2091 ),
2092 ( Role == active ->
2093 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2094 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2095 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2096 ; Role == partner ->
2097 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2098 GetStateValue = true,
2099 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2100 ),
2101 RemoveBody =
2102 (
2103 Susp = Susp2,
2104 GetStateValue,
2105 UpdateState,
2106 MaybeDelete
2107 )
2108 ).
2110 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2111 % activate_constraint/4
2113 generate_activate_clauses([],List,List).
2114 generate_activate_clauses([C|Cs],List,Tail) :-
2115 generate_activate_clause(C,List,List1),
2116 generate_activate_clauses(Cs,List1,Tail).
2118 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2119 ( chr_pp_flag(inline_insertremove,off) ->
2120 use_auxiliary_predicate(activate_constraint,Constraint),
2121 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2122 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2123 ;
2124 delay_phase_end(validate_store_type_assumptions,
2125 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2126 )
2127 ).
2129 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2130 make_name('$activate_constraint_',Constraint,Name),
2131 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2132 Goal =.. [Name,Store, Susp]
2133 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2134 Goal =.. [Name,Store, Susp, Generation]
2135 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2136 Goal =.. [Name,Store, Vars, Susp, Generation]
2137 ;
2138 Goal =.. [Name,Store, Vars, Susp]
2139 ).
2141 generate_activate_clause(Constraint,List,Tail) :-
2142 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2143 List = [Clause|Tail],
2144 Clause = (Head :- Body),
2145 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2146 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2147 ;
2148 List = Tail
2149 ).
2151 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2152 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2153 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2154 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2155 ;
2156 GenerationHandling = true
2157 ),
2158 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2159 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2160 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2161 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2162 ;
2163 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2164 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2165 ( chr_pp_flag(guard_locks,off) ->
2166 NoneLocked = true
2167 ;
2168 NoneLocked = 'chr none_locked'( Vars)
2169 ),
2170 if_used_state(Constraint,not_stored_yet,
2171 ( State == not_stored_yet ->
2172 ArgumentsGoal,
2173 IndexedVariablesBody,
2174 NoneLocked,
2175 StoreYes
2176 ;
2177 % Vars = [],
2178 StoreNo
2179 ),
2180 % (Vars = [],StoreNo),StoreVarsGoal)
2181 StoreNo,StoreVarsGoal)
2182 ),
2183 Body =
2184 (
2185 GetState,
2186 GetStateValue,
2187 UpdateState,
2188 GenerationHandling,
2189 StoreVarsGoal
2190 ).
2191 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2192 % allocate_constraint/4
2194 generate_allocate_clauses([],List,List).
2195 generate_allocate_clauses([C|Cs],List,Tail) :-
2196 generate_allocate_clause(C,List,List1),
2197 generate_allocate_clauses(Cs,List1,Tail).
2199 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2200 uses_state(Constraint,not_stored_yet),
2201 ( chr_pp_flag(inline_insertremove,off) ->
2202 use_auxiliary_predicate(allocate_constraint,Constraint),
2203 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2204 ;
2205 Goal = (Susp = Suspension, Goal0),
2206 delay_phase_end(validate_store_type_assumptions,
2207 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2208 )
2209 ).
2211 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2212 make_name('$allocate_constraint_',Constraint,Name),
2213 Goal =.. [Name,Susp|Args].
2215 generate_allocate_clause(Constraint,List,Tail) :-
2216 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2217 List = [Clause|Tail],
2218 Clause = (Head :- Body),
2219 Constraint = _/A,
2220 length(Args,A),
2221 allocate_constraint_atom(Constraint,Susp,Args,Head),
2222 allocate_constraint_body(Constraint,Susp,Args,Body)
2223 ;
2224 List = Tail
2225 ).
2227 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2228 static_suspension_term(Constraint,Suspension),
2229 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2230 ( chr_pp_flag(debugable,on) ->
2231 Constraint = Functor / _,
2232 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2233 ;
2234 true
2235 ),
2236 ( chr_pp_flag(debugable,on) ->
2237 ( may_trigger(Constraint) ->
2238 append(Args,[Susp],VarsSusp),
2239 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2240 get_target_module(Mod),
2241 Continuation = Mod : ContinuationGoal
2242 ;
2243 Continuation = true
2244 ),
2245 Init = (Susp = Suspension),
2246 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2247 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2248 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2249 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2250 Susp = Suspension, Init = true, CreateContinuation = true
2251 ;
2252 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2253 ),
2254 ( uses_history(Constraint) ->
2255 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2256 ;
2257 CreateHistory = true
2258 ),
2259 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2260 ( has_suspension_field(Constraint,id) ->
2261 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2262 GenID = 'chr gen_id'(Id)
2263 ;
2264 GenID = true
2265 ),
2266 Body =
2267 (
2268 Init,
2269 CreateContinuation,
2270 CreateGeneration,
2271 CreateHistory,
2272 CreateState,
2273 GenID
2274 ).
2276 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2277 % insert_constraint_internal
2279 generate_insert_constraint_internal_clauses([],List,List).
2280 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2281 generate_insert_constraint_internal_clause(C,List,List1),
2282 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2284 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2285 ( chr_pp_flag(inline_insertremove,off) ->
2286 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2287 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2288 ;
2289 delay_phase_end(validate_store_type_assumptions,
2290 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2291 )
2292 ).
2295 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2296 insert_constraint_internal_constraint_name(Constraint,Name),
2297 ( chr_pp_flag(debugable,on) ->
2298 Goal =.. [Name, Vars, Self, Closure | Args]
2299 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2300 Goal =.. [Name,Self | Args]
2301 ;
2302 Goal =.. [Name,Vars, Self | Args]
2303 ).
2305 insert_constraint_internal_constraint_name(Constraint,Name) :-
2306 make_name('$insert_constraint_internal_',Constraint,Name).
2308 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2309 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2310 List = [Clause|Tail],
2311 Clause = (Head :- Body),
2312 Constraint = _/A,
2313 length(Args,A),
2314 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2315 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2316 ;
2317 List = Tail
2318 ).
2321 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2322 static_suspension_term(Constraint,Suspension),
2323 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2324 ( chr_pp_flag(debugable,on) ->
2325 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2326 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2327 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2328 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2329 ;
2330 CreateGeneration = true
2331 ),
2332 ( chr_pp_flag(debugable,on) ->
2333 Constraint = Functor / _,
2334 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2335 ;
2336 true
2337 ),
2338 ( uses_history(Constraint) ->
2339 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2340 ;
2341 CreateHistory = true
2342 ),
2343 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2344 List = [Clause|Tail],
2345 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2346 suspension_term_base_fields(Constraint,BaseFields),
2347 ( has_suspension_field(Constraint,id) ->
2348 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2349 GenID = 'chr gen_id'(Id)
2350 ;
2351 GenID = true
2352 ),
2353 Body =
2354 (
2355 Susp = Suspension,
2356 CreateState,
2357 CreateGeneration,
2358 CreateHistory,
2359 GenID
2360 )
2361 ;
2362 ( has_suspension_field(Constraint,id) ->
2363 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2364 GenID = 'chr gen_id'(Id)
2365 ;
2366 GenID = true
2367 ),
2368 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2369 ( chr_pp_flag(guard_locks,off) ->
2370 NoneLocked = true
2371 ;
2372 NoneLocked = 'chr none_locked'( Vars)
2373 ),
2374 Body =
2375 (
2376 Susp = Suspension,
2377 IndexedVariablesBody,
2378 NoneLocked,
2379 CreateState,
2380 CreateGeneration,
2381 CreateHistory,
2382 GenID
2383 )
2384 ).
2386 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2387 % novel_production/2
2389 generate_novel_production(List,Tail) :-
2390 ( is_used_auxiliary_predicate(novel_production) ->
2391 List = [Clause|Tail],
2392 Clause =
2393 (
2394 '$novel_production'( Self, Tuple) :-
2395 % arg( 3, Self, Ref), % ARGXXX
2396 % 'chr get_mutable'( History, Ref),
2397 arg( 3, Self, History), % ARGXXX
2398 ( hprolog:get_ds( Tuple, History, _) ->
2399 fail
2400 ;
2401 true
2402 )
2403 )
2404 ;
2405 List = Tail
2406 ).
2408 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2409 % extend_history/2
2411 generate_extend_history(List,Tail) :-
2412 ( is_used_auxiliary_predicate(extend_history) ->
2413 List = [Clause|Tail],
2414 Clause =
2415 (
2416 '$extend_history'( Self, Tuple) :-
2417 % arg( 3, Self, Ref), % ARGXXX
2418 % 'chr get_mutable'( History, Ref),
2419 arg( 3, Self, History), % ARGXXX
2420 hprolog:put_ds( Tuple, History, x, NewHistory),
2421 setarg( 3, Self, NewHistory) % ARGXXX
2422 )
2423 ;
2424 List = Tail
2425 ).
2427 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2428 %
2429 :- chr_constraint
2430 empty_named_history_initialisations/2,
2431 generate_empty_named_history_initialisation/1,
2432 find_empty_named_histories/0.
2434 generate_empty_named_history_initialisations(List, Tail) :-
2435 empty_named_history_initialisations(List, Tail),
2436 find_empty_named_histories.
2438 find_empty_named_histories, history(_, Name, []) ==>
2439 generate_empty_named_history_initialisation(Name).
2441 generate_empty_named_history_initialisation(Name) \
2442 generate_empty_named_history_initialisation(Name) <=> true.
2443 generate_empty_named_history_initialisation(Name) \
2444 empty_named_history_initialisations(List, Tail) # Passive
2445 <=>
2446 empty_named_history_global_variable(Name, GlobalVariable),
2447 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2448 empty_named_history_initialisations(Rest, Tail)
2449 pragma passive(Passive).
2451 find_empty_named_histories \
2452 generate_empty_named_history_initialisation(_) # Passive <=> true
2453 pragma passive(Passive).
2455 find_empty_named_histories,
2456 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2457 pragma passive(Passive).
2459 find_empty_named_histories <=>
2460 chr_error(internal, 'find_empty_named_histories was not removed', []).
2463 empty_named_history_global_variable(Name, GlobalVariable) :-
2464 atom_concat('chr empty named history ', Name, GlobalVariable).
2466 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2467 empty_named_history_global_variable(Name, GlobalVariable).
2469 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2470 empty_named_history_global_variable(Name, GlobalVariable).
2473 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2474 % run_suspensions/2
2476 generate_run_suspensions_clauses([],List,List).
2477 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2478 generate_run_suspensions_clause(C,List,List1),
2479 generate_run_suspensions_clauses(Cs,List1,Tail).
2481 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2482 make_name('$run_suspensions_',Constraint,Name),
2483 Goal =.. [Name,Suspensions].
2485 generate_run_suspensions_clause(Constraint,List,Tail) :-
2486 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2487 List = [Clause1,Clause2|Tail],
2488 run_suspensions_goal(Constraint,[],Clause1),
2489 ( chr_pp_flag(debugable,on) ->
2490 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2491 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2492 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2493 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2494 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2495 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2496 Clause2 =
2497 (
2498 Clause2Head :-
2499 GetState,
2500 GetStateValue,
2501 ( State==active ->
2502 UpdateState,
2503 GetGeneration,
2504 GetGenerationValue,
2505 Generation is Gen+1,
2506 UpdateGeneration,
2507 GetContinuation,
2508 (
2509 'chr debug_event'(wake(Suspension)),
2510 call(Continuation)
2511 ;
2512 'chr debug_event'(fail(Suspension)), !,
2513 fail
2514 ),
2515 (
2516 'chr debug_event'(exit(Suspension))
2517 ;
2518 'chr debug_event'(redo(Suspension)),
2519 fail
2520 ),
2521 GetPost,
2522 GetPostValue,
2523 ( Post==triggered ->
2524 UpdatePost % catching constraints that did not do anything
2525 ;
2526 true
2527 )
2528 ;
2529 true
2530 ),
2531 Clause2Recursion
2532 )
2533 ;
2534 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2535 static_suspension_term(Constraint,SuspensionTerm),
2536 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2537 append(Arguments,[Suspension],VarsSusp),
2538 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2539 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2540 ( uses_field(Constraint,generation) ->
2541 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2542 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2543 ;
2544 GenerationHandling = true
2545 ),
2546 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2547 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2548 if_used_state(Constraint,removed,
2549 ( GetState,
2550 ( State==active
2551 -> ReactivateConstraint
2552 ; true)
2553 ),ReactivateConstraint,CondReactivate),
2554 ReactivateConstraint =
2555 (
2556 UpdateState,
2557 GenerationHandling,
2558 Continuation,
2559 GetPostState,
2560 ( Post==triggered ->
2561 UpdatePostState % catching constraints that did not do anything
2562 ;
2563 true
2564 )
2565 ),
2566 Clause2 =
2567 (
2568 Clause2Head :-
2569 Suspension = SuspensionTerm,
2570 CondReactivate,
2571 Clause2Recursion
2572 )
2573 )
2574 ;
2575 List = Tail
2576 ).
2578 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2580 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2581 generate_attach_increment(Clauses) :-
2582 get_max_constraint_index(N),
2583 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2584 Clauses = [Clause1,Clause2],
2585 generate_attach_increment_empty(Clause1),
2586 ( N == 1 ->
2587 generate_attach_increment_one(Clause2)
2588 ;
2589 generate_attach_increment_many(N,Clause2)
2590 )
2591 ;
2592 Clauses = []
2593 ).
2595 generate_attach_increment_empty((attach_increment([],_) :- true)).
2597 generate_attach_increment_one(Clause) :-
2598 Head = attach_increment([Var|Vars],Susps),
2599 get_target_module(Mod),
2600 ( chr_pp_flag(guard_locks,off) ->
2601 NotLocked = true
2602 ;
2603 NotLocked = 'chr not_locked'( Var)
2604 ),
2605 Body =
2606 (
2607 NotLocked,
2608 ( get_attr(Var,Mod,VarSusps) ->
2609 sort(VarSusps,SortedVarSusps),
2610 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2611 put_attr(Var,Mod,MergedSusps)
2612 ;
2613 put_attr(Var,Mod,Susps)
2614 ),
2615 attach_increment(Vars,Susps)
2616 ),
2617 Clause = (Head :- Body).
2619 generate_attach_increment_many(N,Clause) :-
2620 Head = attach_increment([Var|Vars],TAttr1),
2621 % writeln(merge_attributes_1_before),
2622 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2623 % writeln(merge_attributes_1_after),
2624 get_target_module(Mod),
2625 ( chr_pp_flag(guard_locks,off) ->
2626 NotLocked = true
2627 ;
2628 NotLocked = 'chr not_locked'( Var)
2629 ),
2630 Body =
2631 (
2632 NotLocked,
2633 ( get_attr(Var,Mod,TAttr2) ->
2634 MergeGoal,
2635 put_attr(Var,Mod,Attr)
2636 ;
2637 put_attr(Var,Mod,TAttr1)
2638 ),
2639 attach_increment(Vars,TAttr1)
2640 ),
2641 Clause = (Head :- Body).
2643 %% attr_unify_hook
2644 generate_attr_unify_hook(Clauses) :-
2645 get_max_constraint_index(N),
2646 ( N == 0 ->
2647 Clauses = []
2648 ;
2649 ( N == 1 ->
2650 generate_attr_unify_hook_one(Clauses)
2651 ;
2652 generate_attr_unify_hook_many(N,Clauses)
2653 )
2654 ).
2656 generate_attr_unify_hook_one([Clause]) :-
2657 Head = attr_unify_hook(Susps,Other),
2658 get_target_module(Mod),
2659 get_indexed_constraint(1,C),
2660 ( get_store_type(C,ST),
2661 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2662 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2663 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2664 ( atomic_types_suspended_constraint(C) ->
2665 SortGoal1 = true,
2666 SortedSusps = Susps,
2667 SortGoal2 = true,
2668 SortedOtherSusps = OtherSusps,
2669 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2670 NonvarBody = true
2671 ;
2672 SortGoal1 = sort(Susps, SortedSusps),
2673 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2674 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2675 use_auxiliary_predicate(attach_increment),
2676 NonvarBody =
2677 ( compound(Other) ->
2678 term_variables(Other,OtherVars),
2679 attach_increment(OtherVars, SortedSusps)
2680 ;
2681 true
2682 )
2683 ),
2684 Body =
2685 (
2686 SortGoal1,
2687 ( var(Other) ->
2688 ( get_attr(Other,Mod,OtherSusps) ->
2689 SortGoal2,
2690 MergeGoal,
2691 put_attr(Other,Mod,NewSusps),
2692 WakeNewSusps
2693 ;
2694 put_attr(Other,Mod,SortedSusps),
2695 WakeSusps
2696 )
2697 ;
2698 NonvarBody,
2699 WakeSusps
2700 )
2701 ),
2702 Clause = (Head :- Body)
2703 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2704 make_run_suspensions(List,List,WakeNewSusps),
2705 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2706 Body =
2707 ( get_attr(Other,Mod,OtherSusps) ->
2708 MergeGoal,
2709 WakeNewSusps
2710 ;
2711 put_attr(Other,Mod,Susps)
2712 ),
2713 Clause = (Head :- Body)
2714 ).
2717 generate_attr_unify_hook_many(N,[Clause]) :-
2718 chr_pp_flag(dynattr,off), !,
2719 Head = attr_unify_hook(Attr,Other),
2720 get_target_module(Mod),
2721 make_attr(N,Mask,SuspsList,Attr),
2722 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2723 list2conj(SortGoalList,SortGoals),
2724 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2725 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2726 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2727 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2728 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2729 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2730 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2731 NonvarBody = true
2732 ;
2733 use_auxiliary_predicate(attach_increment),
2734 NonvarBody =
2735 ( compound(Other) ->
2736 term_variables(Other,OtherVars),
2737 attach_increment(OtherVars,SortedAttr)
2738 ;
2739 true
2740 )
2741 ),
2742 Body =
2743 (
2744 SortGoals,
2745 ( var(Other) ->
2746 ( get_attr(Other,Mod,TOtherAttr) ->
2747 MergeGoal,
2748 put_attr(Other,Mod,MergedAttr),
2749 WakeMergedSusps
2750 ;
2751 put_attr(Other,Mod,SortedAttr),
2752 WakeSortedSusps
2753 )
2754 ;
2755 NonvarBody,
2756 WakeSortedSusps
2757 )
2758 ),
2759 Clause = (Head :- Body).
2761 % NEW
2762 generate_attr_unify_hook_many(N,Clauses) :-
2763 Head = attr_unify_hook(Attr,Other),
2764 get_target_module(Mod),
2765 normalize_attr(Attr,NormalGoal,NormalAttr),
2766 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2767 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2768 make_run_suspensions(N),
2769 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2770 NonvarBody = true
2771 ;
2772 use_auxiliary_predicate(attach_increment),
2773 NonvarBody =
2774 ( compound(Other) ->
2775 term_variables(Other,OtherVars),
2776 attach_increment(OtherVars,NormalAttr)
2777 ;
2778 true
2779 )
2780 ),
2781 Body =
2782 (
2783 NormalGoal,
2784 ( var(Other) ->
2785 ( get_attr(Other,Mod,OtherAttr) ->
2786 NormalOtherGoal,
2787 MergeGoal,
2788 put_attr(Other,Mod,MergedAttr),
2789 '$dispatch_run_suspensions'(MergedAttr)
2790 ;
2791 put_attr(Other,Mod,NormalAttr),
2792 '$dispatch_run_suspensions'(NormalAttr)
2793 )
2794 ;
2795 NonvarBody,
2796 '$dispatch_run_suspensions'(NormalAttr)
2797 )
2798 ),
2799 Clause = (Head :- Body),
2800 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2801 DispatchList1 = ('$dispatch_run_suspensions'([])),
2802 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2803 run_suspensions_dispatchers(N,[],Dispatchers).
2805 % NEW
2806 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2807 ( N > 0 ->
2808 get_indexed_constraint(N,C),
2809 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2810 ( may_trigger(C) ->
2811 run_suspensions_goal(C,List,Body)
2812 ;
2813 Body = true
2814 ),
2815 M is N - 1,
2816 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2817 ;
2818 Dispatchers = Acc
2819 ).
2821 % NEW
2822 make_run_suspensions(N) :-
2823 ( N > 0 ->
2824 ( get_indexed_constraint(N,C),
2825 may_trigger(C) ->
2826 use_auxiliary_predicate(run_suspensions,C)
2827 ;
2828 true
2829 ),
2830 M is N - 1,
2831 make_run_suspensions(M)
2832 ;
2833 true
2834 ).
2836 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2837 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2839 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2840 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2841 use_auxiliary_predicate(run_suspensions,C),
2842 ( wakes_partially(C) ->
2843 run_suspensions_goal(C,OneSusps,Goal)
2844 ;
2845 run_suspensions_goal(C,AllSusps,Goal)
2846 )
2847 ;
2848 Goal = true
2849 ).
2851 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2852 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2854 make_run_suspensions_loop([],[],_,true).
2855 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2856 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2857 J is I + 1,
2858 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2860 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2861 % $insert_in_store_F/A
2862 % $delete_from_store_F/A
2864 generate_insert_delete_constraints([],[]).
2865 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2866 ( is_stored(FA) ->
2867 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2868 ;
2869 Clauses = RestClauses
2870 ),
2871 generate_insert_delete_constraints(Rest,RestClauses).
2873 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2874 insert_constraint_clause(FA,Clauses,RestClauses1),
2875 delete_constraint_clause(FA,RestClauses1,RestClauses).
2877 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2878 % insert_in_store
2880 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2881 ( chr_pp_flag(inline_insertremove,off) ->
2882 use_auxiliary_predicate(insert_in_store,FA),
2883 insert_constraint_atom(FA,Susp,Goal)
2884 ;
2885 delay_phase_end(validate_store_type_assumptions,
2886 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2887 insert_constraint_direct_used_vars(UsedVars,Vars)
2888 )
2889 )
2890 ).
2892 insert_constraint_direct_used_vars([],_).
2893 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2894 nth1(Index,Vars,Var),
2895 insert_constraint_direct_used_vars(Rest,Vars).
2897 insert_constraint_atom(FA,Susp,Call) :-
2898 make_name('$insert_in_store_',FA,Functor),
2899 Call =.. [Functor,Susp].
2901 insert_constraint_clause(C,Clauses,RestClauses) :-
2902 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2903 Clauses = [Clause|RestClauses],
2904 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2905 insert_constraint_atom(C,Susp,Head),
2906 insert_constraint_body(C,Susp,UsedVars,Body),
2907 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2908 ( chr_pp_flag(store_counter,on) ->
2909 InsertCounterInc = '$insert_counter_inc'
2910 ;
2911 InsertCounterInc = true
2912 )
2913 ;
2914 Clauses = RestClauses
2915 ).
2917 insert_constraint_used_vars([],_,_,true).
2918 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2919 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2920 insert_constraint_used_vars(Rest,C,Susp,Goals).
2922 insert_constraint_body(C,Susp,UsedVars,Body) :-
2923 get_store_type(C,StoreType),
2924 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2926 insert_constraint_body(default,C,Susp,[],Body) :-
2927 global_list_store_name(C,StoreName),
2928 make_get_store_goal(StoreName,Store,GetStoreGoal),
2929 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2930 ( chr_pp_flag(debugable,on) ->
2931 Cell = [Susp|Store],
2932 Body =
2933 (
2934 GetStoreGoal,
2935 UpdateStoreGoal
2936 )
2937 ;
2938 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2939 Body =
2940 (
2941 GetStoreGoal,
2942 Cell = [Susp|Store],
2943 UpdateStoreGoal,
2944 ( Store = [NextSusp|_] ->
2945 SetGoal
2946 ;
2947 true
2948 )
2949 )
2950 ).
2951 % get_target_module(Mod),
2952 % get_max_constraint_index(Total),
2953 % ( Total == 1 ->
2954 % generate_attach_body_1(C,Store,Susp,AttachBody)
2955 % ;
2956 % generate_attach_body_n(C,Store,Susp,AttachBody)
2957 % ),
2958 % Body =
2959 % (
2960 % 'chr default_store'(Store),
2961 % AttachBody
2962 % ).
2963 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2964 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2965 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2966 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2967 sort_out_used_vars(MixedUsedVars,UsedVars).
2968 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
2969 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
2970 constants_store_index_name(C,Index,IndexName),
2971 IndexLookup =.. [IndexName,Key,StoreName],
2972 Body =
2973 ( IndexLookup ->
2974 nb_getval(StoreName,Store),
2975 b_setval(StoreName,[Susp|Store])
2976 ;
2977 true
2978 ).
2979 insert_constraint_body(ground_constants(Index,_),C,Susp,UsedVars,Body) :-
2980 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
2981 constants_store_index_name(C,Index,IndexName),
2982 IndexLookup =.. [IndexName,Key,StoreName],
2983 Body =
2984 ( IndexLookup ->
2985 nb_getval(StoreName,Store),
2986 b_setval(StoreName,[Susp|Store])
2987 ;
2988 true
2989 ).
2990 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2991 global_ground_store_name(C,StoreName),
2992 make_get_store_goal(StoreName,Store,GetStoreGoal),
2993 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2994 ( chr_pp_flag(debugable,on) ->
2995 Cell = [Susp|Store],
2996 Body =
2997 (
2998 GetStoreGoal,
2999 UpdateStoreGoal
3000 )
3001 ;
3002 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3003 Body =
3004 (
3005 GetStoreGoal,
3006 Cell = [Susp|Store],
3007 UpdateStoreGoal,
3008 ( Store = [NextSusp|_] ->
3009 SetGoal
3010 ;
3011 true
3012 )
3013 )
3014 ).
3015 % global_ground_store_name(C,StoreName),
3016 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3017 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3018 % Body =
3019 % (
3020 % GetStoreGoal, % nb_getval(StoreName,Store),
3021 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3022 % ).
3023 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3024 % TODO: generalize to more than one !!!
3025 get_target_module(Module),
3026 Body = ( get_attr(Variable,Module,AssocStore) ->
3027 insert_assoc_store(AssocStore,Key,Susp)
3028 ;
3029 new_assoc_store(AssocStore),
3030 put_attr(Variable,Module,AssocStore),
3031 insert_assoc_store(AssocStore,Key,Susp)
3032 ).
3034 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3035 global_singleton_store_name(C,StoreName),
3036 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3037 Body =
3038 (
3039 UpdateStoreGoal
3040 ).
3041 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3042 find_with_var_identity(
3043 B-UV,
3044 [Susp],
3045 (
3046 member(ST,StoreTypes),
3047 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
3048 ),
3049 BodiesUsedVars
3050 ),
3051 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
3052 list2conj(Bodies,Body),
3053 sort_out_used_vars(NestedUsedVars,UsedVars).
3054 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3055 UsedVars = [Index-Var],
3056 get_identifier_size(ISize),
3057 functor(Struct,struct,ISize),
3058 get_identifier_index(C,Index,IIndex),
3059 arg(IIndex,Struct,Susps),
3060 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3061 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3062 UsedVars = [Index-Var],
3063 type_indexed_identifier_structure(IndexType,Struct),
3064 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3065 arg(IIndex,Struct,Susps),
3066 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3068 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3069 flatten(NestedUsedVars,FlatUsedVars),
3070 sort(FlatUsedVars,SortedFlatUsedVars),
3071 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3073 sort_out_used_vars1([],[]).
3074 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3075 sort_out_used_vars1([I-X,J-Y|R],L) :-
3076 ( I == J ->
3077 X = Y,
3078 sort_out_used_vars1([I-X|R],L)
3079 ;
3080 L = [I-X|T],
3081 sort_out_used_vars1([J-Y|R],T)
3082 ).
3084 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3085 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3086 multi_hash_store_name(FA,Index,StoreName),
3087 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3088 Body =
3089 (
3090 KeyBody,
3091 nb_getval(StoreName,Store),
3092 insert_iht(Store,Key,Susp)
3093 ),
3094 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3096 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3097 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3098 multi_hash_store_name(FA,Index,StoreName),
3099 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3100 make_get_store_goal(StoreName,Store,GetStoreGoal),
3101 ( chr_pp_flag(ht_removal,on)
3102 -> ht_prev_field(Index,PrevField),
3103 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3104 SetGoal),
3105 Body =
3106 (
3107 GetStoreGoal,
3108 insert_ht(Store,Key,Susp,Result),
3109 ( Result = [_,NextSusp|_]
3110 -> SetGoal
3111 ; true
3112 )
3113 )
3114 ; Body =
3115 (
3116 GetStoreGoal,
3117 insert_ht(Store,Key,Susp)
3118 )
3119 ),
3120 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3123 % Delete
3125 delete_constraint_clause(C,Clauses,RestClauses) :-
3126 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3127 Clauses = [Clause|RestClauses],
3128 Clause = (Head :- Body),
3129 delete_constraint_atom(C,Susp,Head),
3130 C = F/A,
3131 functor(Head,F,A),
3132 delete_constraint_body(C,Head,Susp,[],Body)
3133 ;
3134 Clauses = RestClauses
3135 ).
3137 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3138 functor(Head,F,A),
3139 C = F/A,
3140 ( chr_pp_flag(inline_insertremove,off) ->
3141 use_auxiliary_predicate(delete_from_store,C),
3142 delete_constraint_atom(C,Susp,Goal)
3143 ;
3144 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3145 ).
3147 delete_constraint_atom(C,Susp,Atom) :-
3148 make_name('$delete_from_store_',C,Functor),
3149 Atom =.. [Functor,Susp].
3152 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3153 Body = (CounterBody,DeleteBody),
3154 ( chr_pp_flag(store_counter,on) ->
3155 CounterBody = '$delete_counter_inc'
3156 ;
3157 CounterBody = true
3158 ),
3159 get_store_type(C,StoreType),
3160 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3162 delete_constraint_body(default,C,_,Susp,_,Body) :-
3163 ( chr_pp_flag(debugable,on) ->
3164 global_list_store_name(C,StoreName),
3165 make_get_store_goal(StoreName,Store,GetStoreGoal),
3166 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3167 Body =
3168 (
3169 GetStoreGoal, % nb_getval(StoreName,Store),
3170 'chr sbag_del_element'(Store,Susp,NStore),
3171 UpdateStoreGoal % b_setval(StoreName,NStore)
3172 )
3173 ;
3174 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3175 global_list_store_name(C,StoreName),
3176 make_get_store_goal(StoreName,Store,GetStoreGoal),
3177 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3178 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3179 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3180 Body =
3181 (
3182 GetGoal,
3183 ( var(PredCell) ->
3184 GetStoreGoal, % nb_getval(StoreName,Store),
3185 Store = [_|Tail],
3186 UpdateStoreGoal,
3187 ( Tail = [NextSusp|_] ->
3188 SetGoal1
3189 ;
3190 true
3191 )
3192 ;
3193 PredCell = [_,_|Tail],
3194 setarg(2,PredCell,Tail),
3195 ( Tail = [NextSusp|_] ->
3196 SetGoal2
3197 ;
3198 true
3199 )
3200 )
3201 )
3202 ).
3203 % get_target_module(Mod),
3204 % get_max_constraint_index(Total),
3205 % ( Total == 1 ->
3206 % generate_detach_body_1(C,Store,Susp,DetachBody),
3207 % Body =
3208 % (
3209 % 'chr default_store'(Store),
3210 % DetachBody
3211 % )
3212 % ;
3213 % generate_detach_body_n(C,Store,Susp,DetachBody),
3214 % Body =
3215 % (
3216 % 'chr default_store'(Store),
3217 % DetachBody
3218 % )
3219 % ).
3220 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3221 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3222 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3223 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3224 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3225 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3226 constants_store_index_name(C,Index,IndexName),
3227 IndexLookup =.. [IndexName,Key,StoreName],
3228 Body =
3229 ( KeyBody,
3230 ( IndexLookup ->
3231 nb_getval(StoreName,Store),
3232 'chr sbag_del_element'(Store,Susp,NStore),
3233 b_setval(StoreName,NStore)
3234 ;
3235 true
3236 )).
3237 delete_constraint_body(ground_constants(Index,_),C,Head,Susp,VarDict,Body) :-
3238 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3239 constants_store_index_name(C,Index,IndexName),
3240 IndexLookup =.. [IndexName,Key,StoreName],
3241 Body =
3242 ( KeyBody,
3243 ( IndexLookup ->
3244 nb_getval(StoreName,Store),
3245 'chr sbag_del_element'(Store,Susp,NStore),
3246 b_setval(StoreName,NStore)
3247 ;
3248 true
3249 )).
3250 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3251 ( chr_pp_flag(debugable,on) ->
3252 global_ground_store_name(C,StoreName),
3253 make_get_store_goal(StoreName,Store,GetStoreGoal),
3254 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3255 Body =
3256 (
3257 GetStoreGoal, % nb_getval(StoreName,Store),
3258 'chr sbag_del_element'(Store,Susp,NStore),
3259 UpdateStoreGoal % b_setval(StoreName,NStore)
3260 )
3261 ;
3262 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3263 global_ground_store_name(C,StoreName),
3264 make_get_store_goal(StoreName,Store,GetStoreGoal),
3265 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3266 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3267 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3268 Body =
3269 (
3270 GetGoal,
3271 ( var(PredCell) ->
3272 GetStoreGoal, % nb_getval(StoreName,Store),
3273 Store = [_|Tail],
3274 UpdateStoreGoal,
3275 ( Tail = [NextSusp|_] ->
3276 SetGoal1
3277 ;
3278 true
3279 )
3280 ;
3281 PredCell = [_,_|Tail],
3282 setarg(2,PredCell,Tail),
3283 ( Tail = [NextSusp|_] ->
3284 SetGoal2
3285 ;
3286 true
3287 )
3288 )
3289 )
3290 ).
3291 % global_ground_store_name(C,StoreName),
3292 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3293 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3294 % Body =
3295 % (
3296 % GetStoreGoal, % nb_getval(StoreName,Store),
3297 % 'chr sbag_del_element'(Store,Susp,NStore),
3298 % UpdateStoreGoal % b_setval(StoreName,NStore)
3299 % ).
3300 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3301 get_target_module(Module),
3302 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3303 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3304 Body = (
3305 VariableGoal,
3306 get_attr(Variable,Module,AssocStore),
3307 KeyGoal,
3308 delete_assoc_store(AssocStore,Key,Susp)
3309 ).
3310 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3311 global_singleton_store_name(C,StoreName),
3312 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3313 Body =
3314 (
3315 UpdateStoreGoal % b_setval(StoreName,[])
3316 ).
3317 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3318 find_with_var_identity(
3319 B,
3320 [Susp/VarDict/Head],
3321 (
3322 member(ST,StoreTypes),
3323 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3324 ),
3325 Bodies
3326 ),
3327 list2conj(Bodies,Body).
3328 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3329 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3330 get_identifier_size(ISize),
3331 functor(Struct,struct,ISize),
3332 get_identifier_index(C,Index,IIndex),
3333 arg(IIndex,Struct,Susps),
3334 Body = (
3335 VariableGoal,
3336 Variable = Struct,
3337 'chr sbag_del_element'(Susps,Susp,NSusps),
3338 setarg(IIndex,Variable,NSusps)
3339 ).
3340 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3341 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3342 type_indexed_identifier_structure(IndexType,Struct),
3343 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3344 arg(IIndex,Struct,Susps),
3345 Body = (
3346 VariableGoal,
3347 Variable = Struct,
3348 'chr sbag_del_element'(Susps,Susp,NSusps),
3349 setarg(IIndex,Variable,NSusps)
3350 ).
3352 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3353 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3354 multi_hash_store_name(FA,Index,StoreName),
3355 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3356 Body =
3357 (
3358 KeyBody,
3359 nb_getval(StoreName,Store),
3360 delete_iht(Store,Key,Susp)
3361 ),
3362 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3363 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3364 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3365 multi_hash_store_name(C,Index,StoreName),
3366 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3367 make_get_store_goal(StoreName,Store,GetStoreGoal),
3368 ( chr_pp_flag(ht_removal,on)
3369 -> ht_prev_field(Index,PrevField),
3370 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3371 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3372 SetGoal1),
3373 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3374 SetGoal2),
3375 Body =
3376 (
3377 GetGoal,
3378 ( var(Prev)
3379 -> GetStoreGoal,
3380 KeyBody,
3381 delete_first_ht(Store,Key,Values),
3382 ( Values = [NextSusp|_]
3383 -> SetGoal1
3384 ; true
3385 )
3386 ; Prev = [_,_|Values],
3387 setarg(2,Prev,Values),
3388 ( Values = [NextSusp|_]
3389 -> SetGoal2
3390 ; true
3391 )
3392 )
3393 )
3394 ; Body =
3395 (
3396 KeyBody,
3397 GetStoreGoal, % nb_getval(StoreName,Store),
3398 delete_ht(Store,Key,Susp)
3399 )
3400 ),
3401 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3403 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3405 :- chr_constraint
3406 module_initializer/1,
3407 module_initializers/1.
3409 module_initializers(G), module_initializer(Initializer) <=>
3410 G = (Initializer,Initializers),
3411 module_initializers(Initializers).
3413 module_initializers(G) <=>
3414 G = true.
3416 generate_attach_code(Constraints,[Enumerate|L]) :-
3417 enumerate_stores_code(Constraints,Enumerate),
3418 generate_attach_code(Constraints,L,T),
3419 module_initializers(Initializers),
3420 prolog_global_variables_code(PrologGlobalVariables),
3421 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3423 generate_attach_code([],L,L).
3424 generate_attach_code([C|Cs],L,T) :-
3425 get_store_type(C,StoreType),
3426 generate_attach_code(StoreType,C,L,L1),
3427 generate_attach_code(Cs,L1,T).
3429 generate_attach_code(default,C,L,T) :-
3430 global_list_store_initialisation(C,L,T).
3431 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3432 multi_inthash_store_initialisations(Indexes,C,L,L1),
3433 multi_inthash_via_lookups(Indexes,C,L1,T).
3434 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3435 multi_hash_store_initialisations(Indexes,C,L,L1),
3436 multi_hash_lookups(Indexes,C,L1,T).
3437 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3438 constants_initializers(C,Index,Constants),
3439 atomic_constants_code(C,Index,Constants,L,T).
3440 generate_attach_code(ground_constants(Index,Constants),C,L,T) :-
3441 constants_initializers(C,Index,Constants),
3442 ground_constants_code(C,Index,Constants,L,T).
3443 generate_attach_code(global_ground,C,L,T) :-
3444 global_ground_store_initialisation(C,L,T).
3445 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3446 use_auxiliary_module(chr_assoc_store).
3447 generate_attach_code(global_singleton,C,L,T) :-
3448 global_singleton_store_initialisation(C,L,T).
3449 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3450 multi_store_generate_attach_code(StoreTypes,C,L,T).
3451 generate_attach_code(identifier_store(Index),C,L,T) :-
3452 get_identifier_index(C,Index,IIndex),
3453 ( IIndex == 2 ->
3454 get_identifier_size(ISize),
3455 functor(Struct,struct,ISize),
3456 Struct =.. [_,Label|Stores],
3457 set_elems(Stores,[]),
3458 Clause1 = new_identifier(Label,Struct),
3459 functor(Struct2,struct,ISize),
3460 arg(1,Struct2,Label2),
3461 Clause2 =
3462 ( user:portray(Struct2) :-
3463 write('<id:'),
3464 print(Label2),
3465 write('>')
3466 ),
3467 functor(Struct3,struct,ISize),
3468 arg(1,Struct3,Label3),
3469 Clause3 = identifier_label(Struct3,Label3),
3470 L = [Clause1,Clause2,Clause3|T]
3471 ;
3472 L = T
3473 ).
3474 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3475 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3476 ( IIndex == 2 ->
3477 identifier_store_initialization(IndexType,L,L1),
3478 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3479 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3480 get_type_indexed_identifier_size(IndexType,ISize),
3481 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3482 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3483 type_indexed_identifier_structure(IndexType,Struct),
3484 Struct =.. [_,Label|Stores],
3485 set_elems(Stores,[]),
3486 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3487 Clause1 =.. [Name1,Label,Struct],
3488 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3489 Goal1 =.. [Name1,Label1b,S1b],
3490 type_indexed_identifier_structure(IndexType,Struct1b),
3491 Struct1b =.. [_,Label1b|Stores1b],
3492 set_elems(Stores1b,[]),
3493 Expansion1 = (S1b = Struct1b),
3494 Clause1b = user:goal_expansion(Goal1,Expansion1),
3495 % writeln(Clause1-Clause1b),
3496 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3497 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3498 type_indexed_identifier_structure(IndexType,Struct2),
3499 arg(1,Struct2,Label2),
3500 Clause2 =
3501 ( user:portray(Struct2) :-
3502 write('<id:'),
3503 print(Label2),
3504 write('>')
3505 ),
3506 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3507 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3508 type_indexed_identifier_structure(IndexType,Struct3),
3509 arg(1,Struct3,Label3),
3510 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3511 Clause3 =.. [Name3,Struct3,Label3],
3512 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3513 Goal3b =.. [Name3,S3b,L3b],
3514 type_indexed_identifier_structure(IndexType,Struct3b),
3515 arg(1,Struct3b,L3b),
3516 Expansion3b = (S3 = Struct3b),
3517 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3518 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3519 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3520 identifier_store_name(IndexType,GlobalVariable),
3521 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3522 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3523 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3524 Clause4 =
3525 ( LookupAtom :-
3526 nb_getval(GlobalVariable,HT),
3527 ( lookup_ht(HT,X,[IX]) ->
3528 true
3529 ;
3530 NewIdentifierGoal,
3531 insert_ht(HT,X,IX)
3532 )
3533 ),
3534 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3535 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3536 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3537 ;
3538 L = T
3539 ).
3541 constants_initializers(C,Index,Constants) :-
3542 maplist(constants_store_name(C,Index),Constants,StoreNames),
3543 findall(Initializer,
3544 ( member(StoreName,StoreNames),
3545 Initializer = nb_setval(StoreName,[])
3546 ),
3547 Initializers),
3548 maplist(module_initializer,Initializers).
3550 lookup_identifier_atom(Key,X,IX,Atom) :-
3551 atom_concat('lookup_identifier_',Key,LookupFunctor),
3552 Atom =.. [LookupFunctor,X,IX].
3554 identifier_label_atom(IndexType,IX,X,Atom) :-
3555 type_indexed_identifier_name(IndexType,identifier_label,Name),
3556 Atom =.. [Name,IX,X].
3558 multi_store_generate_attach_code([],_,L,L).
3559 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3560 generate_attach_code(ST,C,L,L1),
3561 multi_store_generate_attach_code(STs,C,L1,T).
3563 multi_inthash_store_initialisations([],_,L,L).
3564 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3565 use_auxiliary_module(chr_integertable_store),
3566 multi_hash_store_name(FA,Index,StoreName),
3567 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3568 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3569 L1 = L,
3570 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3571 multi_hash_store_initialisations([],_,L,L).
3572 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3573 use_auxiliary_module(chr_hashtable_store),
3574 multi_hash_store_name(FA,Index,StoreName),
3575 prolog_global_variable(StoreName),
3576 make_init_store_goal(StoreName,HT,InitStoreGoal),
3577 module_initializer((new_ht(HT),InitStoreGoal)),
3578 L1 = L,
3579 multi_hash_store_initialisations(Indexes,FA,L1,T).
3581 global_list_store_initialisation(C,L,T) :-
3582 ( is_stored(C) ->
3583 global_list_store_name(C,StoreName),
3584 prolog_global_variable(StoreName),
3585 make_init_store_goal(StoreName,[],InitStoreGoal),
3586 module_initializer(InitStoreGoal)
3587 ;
3588 true
3589 ),
3590 L = T.
3591 global_ground_store_initialisation(C,L,T) :-
3592 global_ground_store_name(C,StoreName),
3593 prolog_global_variable(StoreName),
3594 make_init_store_goal(StoreName,[],InitStoreGoal),
3595 module_initializer(InitStoreGoal),
3596 L = T.
3597 global_singleton_store_initialisation(C,L,T) :-
3598 global_singleton_store_name(C,StoreName),
3599 prolog_global_variable(StoreName),
3600 make_init_store_goal(StoreName,[],InitStoreGoal),
3601 module_initializer(InitStoreGoal),
3602 L = T.
3603 identifier_store_initialization(IndexType,L,T) :-
3604 use_auxiliary_module(chr_hashtable_store),
3605 identifier_store_name(IndexType,StoreName),
3606 prolog_global_variable(StoreName),
3607 make_init_store_goal(StoreName,HT,InitStoreGoal),
3608 module_initializer((new_ht(HT),InitStoreGoal)),
3609 L = T.
3612 multi_inthash_via_lookups([],_,L,L).
3613 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3614 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3615 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3616 L = [(Head :- Body)|L1],
3617 multi_inthash_via_lookups(Indexes,C,L1,T).
3618 multi_hash_lookups([],_,L,L).
3619 multi_hash_lookups([Index|Indexes],C,L,T) :-
3620 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3621 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3622 L = [(Head :- Body)|L1],
3623 multi_hash_lookups(Indexes,C,L1,T).
3625 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3626 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3627 Head =.. [Name,Key,SuspsList].
3629 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3630 %
3631 % Returns goal that performs hash table lookup.
3632 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3633 % INLINED:
3634 ( get_store_type(ConstraintSymbol,multi_store(Stores)),
3635 memberchk(atomic_constants(Index,Constants,_),Stores) ->
3636 ( ground(Key) ->
3637 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3638 Goal = nb_getval(StoreName,SuspsList)
3639 ;
3640 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3641 Lookup =.. [IndexName,Key,StoreName],
3642 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3643 )
3644 ; get_store_type(ConstraintSymbol,multi_store(Stores)),
3645 memberchk(ground_constants(Index,Constants),Stores) ->
3646 ( ground(Key) ->
3647 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3648 Goal = nb_getval(StoreName,SuspsList)
3649 ;
3650 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3651 Lookup =.. [IndexName,Key,StoreName],
3652 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3653 )
3654 ;
3655 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3656 make_get_store_goal(StoreName,HT,GetStoreGoal),
3657 ( HashType == hash, specialized_hash_term_call(Key,Hash,HashCall) ->
3658 Goal =
3659 (
3660 GetStoreGoal, % nb_getval(StoreName,HT),
3661 HashCall, % hash_term(Key,Hash),
3662 lookup_ht1(HT,Hash,Key,SuspsList)
3663 )
3664 ;
3665 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3666 Goal =
3667 (
3668 GetStoreGoal, % nb_getval(StoreName,HT),
3669 hash_term(Key,Hash),
3670 Lookup
3671 )
3672 )
3673 ).
3676 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3677 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3679 specialized_hash_term_call(Key,Hash,Call) :-
3680 ( ground(Key) ->
3681 % This is based on a property of SWI-Prolog's
3682 % hash_term/2 predicate:
3683 % the hash value is stable over repeated invocations
3684 % of SWI-Prolog
3685 hash_term(Key,Hash),
3686 Call = true
3687 ;
3688 nonvar(Key),
3689 specialize_hash_term(Key,NewKey),
3690 NewKey \== Key,
3691 Call = hash_term(NewKey,Hash)
3692 ).
3694 specialize_hash_term(Term,NewTerm) :-
3695 ( ground(Term) ->
3696 hash_term(Term,NewTerm)
3697 ; var(Term) ->
3698 NewTerm = Term
3699 ;
3700 Term =.. [F|Args],
3701 maplist(specialize_hash_term,Args,NewArgs),
3702 NewTerm =.. [F|NewArgs]
3703 ).
3705 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3706 ( /* chr_pp_flag(experiment,off) ->
3707 true
3708 ; */ atomic(Key) ->
3709 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3710 ; ground(Key) ->
3711 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3712 ;
3713 actual_non_atomic_multi_hash_key(ConstraintSymbol,Index)
3714 ),
3715 delay_phase_end(validate_store_type_assumptions,
3716 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3718 :- chr_constraint actual_atomic_multi_hash_keys/3.
3719 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3721 :- chr_constraint actual_ground_multi_hash_keys/3.
3722 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3724 :- chr_constraint actual_non_atomic_multi_hash_key/2.
3725 :- chr_option(mode,actual_non_atomic_multi_hash_key(+,+)).
3727 /*
3728 actual_atomic_multi_hash_keys(C,Index,Keys)
3729 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3731 actual_ground_multi_hash_keys(C,Index,Keys)
3732 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3734 actual_non_atomic_multi_hash_key(C,Index)
3735 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3736 */
3737 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3738 <=> append(Keys1,Keys2,Keys0),
3739 sort(Keys0,Keys),
3740 actual_atomic_multi_hash_keys(C,Index,Keys).
3742 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3743 <=> append(Keys1,Keys2,Keys0),
3744 sort(Keys0,Keys),
3745 actual_ground_multi_hash_keys(C,Index,Keys).
3747 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3748 <=> append(Keys1,Keys2,Keys0),
3749 sort(Keys0,Keys),
3750 actual_ground_multi_hash_keys(C,Index,Keys).
3752 actual_non_atomic_multi_hash_key(C,Index) \ actual_non_atomic_multi_hash_key(C,Index)
3753 <=> true.
3755 actual_non_atomic_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3756 <=> true.
3758 actual_non_atomic_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3759 <=> true.
3761 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3762 %
3763 % Returns predicate name of hash table lookup predicate.
3764 multi_hash_lookup_name(F/A,Index,Name) :-
3765 ( integer(Index) ->
3766 IndexName = Index
3767 ; is_list(Index) ->
3768 atom_concat_list(Index,IndexName)
3769 ),
3770 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3772 multi_hash_store_name(F/A,Index,Name) :-
3773 get_target_module(Mod),
3774 ( integer(Index) ->
3775 IndexName = Index
3776 ; is_list(Index) ->
3777 atom_concat_list(Index,IndexName)
3778 ),
3779 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3781 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3782 ( ( integer(Index) ->
3783 I = Index
3784 ;
3785 Index = [I]
3786 ) ->
3787 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3788 ; is_list(Index) ->
3789 sort(Index,Indexes),
3790 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3791 once(pairup(Bodies,Keys,ArgKeyPairs)),
3792 Key =.. [k|Keys],
3793 list2conj(Bodies,KeyBody)
3794 ).
3796 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3797 ( ( integer(Index) ->
3798 I = Index
3799 ;
3800 Index = [I]
3801 ) ->
3802 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3803 ; is_list(Index) ->
3804 sort(Index,Indexes),
3805 find_with_var_identity(
3806 Goal-KeyI,
3807 [Susp/Head/VarDict],
3808 (
3809 member(I,Indexes),
3810 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3811 ),
3812 ArgKeyPairs
3813 ),
3814 once(pairup(Bodies,Keys,ArgKeyPairs)),
3815 Key =.. [k|Keys],
3816 list2conj(Bodies,KeyBody)
3817 ).
3819 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3820 arg(Index,Head,OriginalArg),
3821 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3822 Goal = true
3823 ;
3824 functor(Head,F,A),
3825 C = F/A,
3826 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3827 ).
3829 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3830 ( ( integer(Index) ->
3831 I = Index
3832 ;
3833 Index = [I]
3834 ) ->
3835 UsedVars = [I-Key]
3836 ; is_list(Index) ->
3837 sort(Index,Indexes),
3838 pairup(Indexes,Keys,UsedVars),
3839 Key =.. [k|Keys]
3840 ).
3842 multi_hash_key_args(Index,Head,KeyArgs) :-
3843 ( integer(Index) ->
3844 arg(Index,Head,Arg),
3845 KeyArgs = [Arg]
3846 ; is_list(Index) ->
3847 sort(Index,Indexes),
3848 term_variables(Head,Vars),
3849 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3850 ).
3853 %-------------------------------------------------------------------------------
3854 atomic_constants_code(C,Index,Constants,L,T) :-
3855 constants_store_index_name(C,Index,IndexName),
3856 findall(Clause,
3857 ( member(Constant,Constants),
3858 constants_store_name(C,Index,Constant,StoreName),
3859 Clause =.. [IndexName,Constant,StoreName]
3860 ),
3861 Clauses),
3862 append(Clauses,T,L).
3864 %-------------------------------------------------------------------------------
3865 ground_constants_code(C,Index,Terms,L,T) :-
3866 constants_store_index_name(C,Index,IndexName),
3867 findall(StoreName,
3868 ( member(Constant,Terms),
3869 constants_store_name(C,Index,Constant,StoreName)
3870 ),
3871 StoreNames),
3872 length(Terms,N),
3873 replicate(N,[],More),
3874 trie_index([Terms|More],StoreNames,IndexName,L,T).
3876 constants_store_name(F/A,Index,Term,Name) :-
3877 get_target_module(Mod),
3878 term_to_atom(Term,Constant),
3879 term_to_atom(Index,IndexAtom),
3880 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3882 constants_store_index_name(F/A,Index,Name) :-
3883 get_target_module(Mod),
3884 term_to_atom(Index,IndexAtom),
3885 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3887 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3888 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3890 trie_step([],_,_,[],[],L,L) :- !.
3891 % length MorePatterns == length Patterns == length Results
3892 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3893 MorePatterns = [List|_],
3894 length(List,N),
3895 findall(F/A,
3896 ( member(Pattern,Patterns),
3897 functor(Pattern,F,A)
3898 ),
3899 FAs0),
3900 sort(FAs0,FAs),
3901 N1 is N + 1,
3902 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3904 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3905 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3906 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3907 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3909 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3910 Clause = (Head :- Body),
3911 N1 is N + 1,
3912 functor(Head,Symbol,N1),
3913 arg(N1,Head,Result),
3914 functor(IndexPattern,F,A),
3915 arg(1,Head,IndexPattern),
3916 Head =.. [_,_|RestArgs],
3917 IndexPattern =.. [_|Args],
3918 append(Args,RestArgs,RecArgs),
3919 ( RecArgs == [Result] ->
3920 List = Tail,
3921 Body = true,
3922 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
3923 MoreResults = [Result]
3924 ;
3925 gensym(Prefix,RSymbol),
3926 Body =.. [RSymbol|RecArgs],
3927 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
3928 trie_step(Cases,RSymbol,Prefix,MoreCases,MoreResults,List,Tail)
3929 ).
3931 rec_cases([],[],[],_,[],[],[]).
3932 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
3933 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
3934 Cases = [Case|NCases],
3935 MoreCases = [MoreCase|NMoreCases],
3936 MoreResults = [Result|NMoreResults],
3937 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
3938 ;
3939 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
3940 ).
3942 %-------------------------------------------------------------------------------
3943 global_list_store_name(F/A,Name) :-
3944 get_target_module(Mod),
3945 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
3946 global_ground_store_name(F/A,Name) :-
3947 get_target_module(Mod),
3948 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
3949 global_singleton_store_name(F/A,Name) :-
3950 get_target_module(Mod),
3951 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
3953 identifier_store_name(TypeName,Name) :-
3954 get_target_module(Mod),
3955 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
3957 :- chr_constraint prolog_global_variable/1.
3958 :- chr_option(mode,prolog_global_variable(+)).
3960 :- chr_constraint prolog_global_variables/1.
3961 :- chr_option(mode,prolog_global_variables(-)).
3963 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
3965 prolog_global_variables(List), prolog_global_variable(Name) <=>
3966 List = [Name|Tail],
3967 prolog_global_variables(Tail).
3968 prolog_global_variables(List) <=> List = [].
3970 %% SWI begin
3971 prolog_global_variables_code(Code) :-
3972 prolog_global_variables(Names),
3973 ( Names == [] ->
3974 Code = []
3975 ;
3976 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
3977 Code = [(:- dynamic user:exception/3),
3978 (:- multifile user:exception/3),
3979 (user:exception(undefined_global_variable,Name,retry) :-
3980 (
3981 '$chr_prolog_global_variable'(Name),
3982 '$chr_initialization'
3983 )
3984 )
3985 |
3986 NameDeclarations
3987 ]
3988 ).
3989 %% SWI end
3990 %% SICStus begin
3991 % prolog_global_variables_code([]).
3992 %% SICStus end
3993 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3994 %sbag_member_call(S,L,sysh:mem(S,L)).
3995 sbag_member_call(S,L,'chr sbag_member'(S,L)).
3996 %sbag_member_call(S,L,member(S,L)).
3997 update_mutable_call(A,B,'chr update_mutable'( A, B)).
3998 %update_mutable_call(A,B,setarg(1, B, A)).
3999 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4000 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4002 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4003 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4004 % create_get_mutable(Value,Field,Get1).
4005 %
4006 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4007 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4008 % update_mutable_call(NewValue,Field,Set).
4009 %
4010 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4011 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4012 % create_get_mutable_ref(Value,Field,Get1),
4013 % update_mutable_call(NewValue,Field,Set).
4014 %
4015 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4016 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4017 % create_mutable_call(Value,Field,Create).
4018 %
4019 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4020 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4021 % create_get_mutable(Value,Field,Get).
4022 %
4023 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4024 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4025 % create_get_mutable_ref(Value,Field,Get),
4026 % update_mutable_call(NewValue,Field,Set).
4028 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4029 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4031 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4032 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4034 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4035 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4036 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4038 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4039 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4041 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4042 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4044 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4045 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4046 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4048 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4050 enumerate_stores_code(Constraints,Clause) :-
4051 Head = '$enumerate_constraints'(Constraint),
4052 enumerate_store_bodies(Constraints,Constraint,Bodies),
4053 list2disj(Bodies,Body),
4054 Clause = (Head :- Body).
4056 enumerate_store_bodies([],_,[]).
4057 enumerate_store_bodies([C|Cs],Constraint,L) :-
4058 ( is_stored(C) ->
4059 get_store_type(C,StoreType),
4060 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
4061 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4062 C = F/_,
4063 Constraint0 =.. [F|Arguments],
4064 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4065 L = [Body|T]
4066 ;
4067 L = T
4068 ),
4069 enumerate_store_bodies(Cs,Constraint,T).
4071 enumerate_store_body(default,C,Susp,Body) :-
4072 global_list_store_name(C,StoreName),
4073 sbag_member_call(Susp,List,Sbag),
4074 make_get_store_goal(StoreName,List,GetStoreGoal),
4075 Body =
4076 (
4077 GetStoreGoal, % nb_getval(StoreName,List),
4078 Sbag
4079 ).
4080 % get_constraint_index(C,Index),
4081 % get_target_module(Mod),
4082 % get_max_constraint_index(MaxIndex),
4083 % Body1 =
4084 % (
4085 % 'chr default_store'(GlobalStore),
4086 % get_attr(GlobalStore,Mod,Attr)
4087 % ),
4088 % ( MaxIndex > 1 ->
4089 % NIndex is Index + 1,
4090 % sbag_member_call(Susp,List,Sbag),
4091 % Body2 =
4092 % (
4093 % arg(NIndex,Attr,List),
4094 % Sbag
4095 % )
4096 % ;
4097 % sbag_member_call(Susp,Attr,Sbag),
4098 % Body2 = Sbag
4099 % ),
4100 % Body = (Body1,Body2).
4101 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4102 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4103 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4104 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4105 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4106 Completeness == complete, % fail if incomplete
4107 find_with_var_identity(nb_getval(StoreName,Susps),[Susps],
4108 ( member(Constant,Constants),
4109 constants_store_name(C,Index,Constant,StoreName) )
4110 , Disjuncts),
4111 list2disj(Disjuncts, Disjunction),
4112 Body = ( Disjunction, member(Susp,Susps) ).
4113 enumerate_store_body(ground_constants(_,_),_,_,_) :- fail.
4114 enumerate_store_body(global_ground,C,Susp,Body) :-
4115 global_ground_store_name(C,StoreName),
4116 sbag_member_call(Susp,List,Sbag),
4117 make_get_store_goal(StoreName,List,GetStoreGoal),
4118 Body =
4119 (
4120 GetStoreGoal, % nb_getval(StoreName,List),
4121 Sbag
4122 ).
4123 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4124 Body = fail.
4125 enumerate_store_body(global_singleton,C,Susp,Body) :-
4126 global_singleton_store_name(C,StoreName),
4127 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4128 Body =
4129 (
4130 GetStoreGoal, % nb_getval(StoreName,Susp),
4131 Susp \== []
4132 ).
4133 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4134 once((
4135 member(ST,STs),
4136 enumerate_store_body(ST,C,Susp,Body)
4137 )).
4138 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4139 Body = fail.
4140 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4141 Body = fail.
4143 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4144 multi_hash_store_name(C,I,StoreName),
4145 B =
4146 (
4147 nb_getval(StoreName,HT),
4148 value_iht(HT,Susp)
4149 ).
4150 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4151 multi_hash_store_name(C,I,StoreName),
4152 make_get_store_goal(StoreName,HT,GetStoreGoal),
4153 B =
4154 (
4155 GetStoreGoal, % nb_getval(StoreName,HT),
4156 value_ht(HT,Susp)
4157 ).
4159 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4162 :- chr_constraint
4163 prev_guard_list/8,
4164 prev_guard_list/6,
4165 simplify_guards/1,
4166 set_all_passive/1.
4168 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4169 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4170 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4171 :- chr_option(mode,simplify_guards(+)).
4172 :- chr_option(mode,set_all_passive(+)).
4174 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4175 % GUARD SIMPLIFICATION
4176 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4177 % If the negation of the guards of earlier rules entails (part of)
4178 % the current guard, the current guard can be simplified. We can only
4179 % use earlier rules with a head that matches if the head of the current
4180 % rule does, and which make it impossible for the current rule to match
4181 % if they fire (i.e. they shouldn't be propagation rules and their
4182 % head constraints must be subsets of those of the current rule).
4183 % At this point, we know for sure that the negation of the guard
4184 % of such a rule has to be true (otherwise the earlier rule would have
4185 % fired, because of the refined operational semantics), so we can use
4186 % that information to simplify the guard by replacing all entailed
4187 % conditions by true/0. As a consequence, the never-stored analysis
4188 % (in a further phase) will detect more cases of never-stored constraints.
4189 %
4190 % e.g. c(X),d(Y) <=> X > 0 | ...
4191 % e(X) <=> X < 0 | ...
4192 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4193 % \____________/
4194 % true
4196 guard_simplification :-
4197 ( chr_pp_flag(guard_simplification,on) ->
4198 precompute_head_matchings,
4199 simplify_guards(1)
4200 ;
4201 true
4202 ).
4204 % for every rule, we create a prev_guard_list where the last argument
4205 % eventually is a list of the negations of earlier guards
4206 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4207 <=>
4208 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4209 append(Head1,Head2,Heads),
4210 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4211 multiple_occ_constraints_checked([]),
4212 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4214 append(IDs1,IDs2,IDs),
4215 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4216 empty_q(EmptyHeap),
4217 insert_list_q(HeapData,EmptyHeap,Heap),
4218 next_prev_rule(Heap,_,Heap1),
4219 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4220 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4221 NextRule is RuleNb+1,
4222 simplify_guards(NextRule).
4224 next_prev_rule(Heap,RuleNb,NHeap) :-
4225 ( find_min_q(Heap,_-Priority) ->
4226 Priority = (-RuleNb),
4227 normalize_heap(Heap,Priority,NHeap)
4228 ;
4229 RuleNb = 0,
4230 NHeap = Heap
4231 ).
4233 normalize_heap(Heap,Priority,NHeap) :-
4234 ( find_min_q(Heap,_-Priority) ->
4235 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4236 ( O > 1 ->
4237 NO is O -1,
4238 get_occurrence(C,NO,RuleNb,_),
4239 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4240 ;
4241 Heap2 = Heap1
4242 ),
4243 normalize_heap(Heap2,Priority,NHeap)
4244 ;
4245 NHeap = Heap
4246 ).
4248 % no more rule
4249 simplify_guards(_)
4250 <=>
4251 true.
4253 % The negation of the guard of a non-propagation rule is added
4254 % if its kept head constraints are a subset of the kept constraints of
4255 % the rule we're working on, and its removed head constraints (at least one)
4256 % are a subset of the removed constraints.
4258 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4259 <=>
4260 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4261 H1 \== [],
4262 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4263 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4264 |
4265 append(H1,H2,Heads),
4266 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4267 append(GuardList,DerivedInfo,GL1),
4268 normalize_conj_list(GL1,GL),
4269 append(GH_New1,GH,GH1),
4270 normalize_conj_list(GH1,GH_New),
4271 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4272 % PrevPrevRuleNb is PrevRuleNb-1,
4273 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4275 % if this isn't the case, we skip this one and try the next rule
4276 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4277 <=>
4278 ( N > 0 ->
4279 next_prev_rule(Heap,N1,NHeap),
4280 % N1 is N-1,
4281 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4282 ;
4283 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4284 ).
4286 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4287 <=>
4288 GH \== []
4289 |
4290 head_types_modes_condition(GH,H,TypeInfo),
4291 conj2list(TypeInfo,TI),
4292 term_variables(H,HeadVars),
4293 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4294 normalize_conj_list(Info,InfoL),
4295 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4297 head_types_modes_condition([],H,true).
4298 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4299 types_modes_condition(H,GH,TI1),
4300 head_types_modes_condition(GHs,H,TI2).
4302 %%
4303 %
4304 % when all earlier guards are added or skipped, we simplify the guard.
4305 % if it's different from the original one, we change the rule
4307 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4308 <=>
4309 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4310 G \== true, % let's not try to simplify this ;)
4311 append(M,GuardList,Info),
4312 simplify_guard(G,B,Info,SimpleGuard,NB),
4313 G \== SimpleGuard
4314 |
4315 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4316 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4318 %% normalize_conj_list(+List,-NormalList) is det.
4319 %
4320 % Removes =true= elements and flattens out conjunctions.
4322 normalize_conj_list(List,NormalList) :-
4323 list2conj(List,Conj),
4324 conj2list(Conj,NormalList).
4326 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4327 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4328 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4330 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4331 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4332 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4333 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4334 append(Renaming1,ExtraRenaming,Renaming2),
4335 list2conj(PrevMatchings,Match),
4336 negate_b(Match,HeadsDontMatch),
4337 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4338 list2conj(HeadsMatch,HeadsMatchBut),
4339 term_variables(Renaming2,RenVars),
4340 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4341 new_vars(MGVars,RenVars,ExtraRenaming2),
4342 append(Renaming2,ExtraRenaming2,Renaming),
4343 ( PrevGuard == true -> % true can't fail
4344 Info_ = HeadsDontMatch
4345 ;
4346 negate_b(PrevGuard,TheGuardFailed),
4347 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4348 ),
4349 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4350 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4351 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4352 list2conj(RenamedMatchings_,RenamedMatchings),
4353 apply_guard_wrt_term(H,RenamedG2,GH2),
4354 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4355 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4357 simplify_guard(G,B,Info,SG,NB) :-
4358 conj2list(G,LG),
4359 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4360 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4361 list2conj(SGL,SG).
4364 new_vars([],_,[]).
4365 new_vars([A|As],RV,ER) :-
4366 ( memberchk_eq(A,RV) ->
4367 new_vars(As,RV,ER)
4368 ;
4369 ER = [A-NewA,NewA-A|ER2],
4370 new_vars(As,RV,ER2)
4371 ).
4373 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4374 %
4375 % check if a list of constraints is a subset of another list of constraints
4376 % (multiset-subset), meanwhile computing a variable renaming to convert
4377 % one into the other.
4378 head_subset(H,Head,Renaming) :-
4379 head_subset(H,Head,Renaming,[],_).
4381 head_subset([],Remainder,Renaming,Renaming,Remainder).
4382 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4383 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4384 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4386 % check if A is in the list, remove it from Headleft
4387 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4388 ( variable_replacement(A,X,Acc,Renaming),
4389 Remainder = Xs
4390 ;
4391 Remainder = [X|RRemainder],
4392 head_member(Xs,A,Renaming,Acc,RRemainder)
4393 ).
4394 %-------------------------------------------------------------------------------%
4395 % memoing code to speed up repeated computation
4397 :- chr_constraint precompute_head_matchings/0.
4399 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4400 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4401 append(H1,H2,Heads),
4402 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4403 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4404 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4406 precompute_head_matchings <=> true.
4408 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4409 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4411 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4412 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4414 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4415 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4416 <=>
4417 Q1 = NHeads,
4418 Q2 = Matchings.
4419 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4421 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4422 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4423 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4424 %-------------------------------------------------------------------------------%
4426 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4427 extract_arguments(Heads,Arguments),
4428 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4429 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4431 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4432 extract_arguments(Heads,Arguments),
4433 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4434 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4436 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4437 extract_arguments(Heads,Arguments1),
4438 extract_arguments(MatchingFreeHeads,Arguments2),
4439 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4441 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4442 %
4443 % Returns list of arguments of given list of constraints.
4444 extract_arguments([],[]).
4445 extract_arguments([Constraint|Constraints],AllArguments) :-
4446 Constraint =.. [_|Arguments],
4447 append(Arguments,RestArguments,AllArguments),
4448 extract_arguments(Constraints,RestArguments).
4450 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4451 %
4452 % Substitutes arguments of constraints with those in the given list.
4454 substitute_arguments([],[],[]).
4455 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4456 functor(Constraint,F,N),
4457 split_at(N,Variables,Arguments,RestVariables),
4458 NConstraint =.. [F|Arguments],
4459 substitute_arguments(Constraints,RestVariables,NConstraints).
4461 make_matchings_explicit([],[],_,MC,MC,[]).
4462 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4463 ( var(Arg) ->
4464 ( memberchk_eq(Arg,VarAcc) ->
4465 list2disj(MatchingCondition,MatchingCondition_disj),
4466 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4467 NVarAcc = VarAcc
4468 ;
4469 Matchings = RestMatchings,
4470 NewVar = Arg,
4471 NVarAcc = [Arg|VarAcc]
4472 ),
4473 MatchingCondition2 = MatchingCondition
4474 ;
4475 functor(Arg,F,A),
4476 Arg =.. [F|RecArgs],
4477 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4478 FlatArg =.. [F|RecVars],
4479 ( RecMatchings == [] ->
4480 Matchings = [functor(NewVar,F,A)|RestMatchings]
4481 ;
4482 list2conj(RecMatchings,ArgM_conj),
4483 list2disj(MatchingCondition,MatchingCondition_disj),
4484 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4485 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4486 ),
4487 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4488 term_variables(Args,ArgVars),
4489 append(ArgVars,VarAcc,NVarAcc)
4490 ),
4491 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4494 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4495 %
4496 % Returns list of new variables and list of pairwise unifications between given list and variables.
4498 make_matchings_explicit_not_negated([],[],[]).
4499 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4500 Matchings = [Var = X|RMatchings],
4501 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4503 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4504 %
4505 % (Partially) applies substitutions of =Goal= to given list.
4507 apply_guard_wrt_term([],_Guard,[]).
4508 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4509 ( var(Term) ->
4510 apply_guard_wrt_variable(Guard,Term,NTerm)
4511 ;
4512 Term =.. [F|HArgs],
4513 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4514 NTerm =.. [F|NewHArgs]
4515 ),
4516 apply_guard_wrt_term(RH,Guard,RGH).
4518 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4519 %
4520 % (Partially) applies goal =Guard= wrt variable.
4522 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4523 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4524 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4525 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4526 ( Guard = (X = Y), Variable == X ->
4527 NVariable = Y
4528 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4529 functor(NVariable,Functor,Arity)
4530 ;
4531 NVariable = Variable
4532 ).
4534 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4535 % ALWAYS FAILING HEADS
4536 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4538 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4539 <=>
4540 chr_pp_flag(check_impossible_rules,on),
4541 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4542 append(M,GuardList,Info),
4543 guard_entailment:entails_guard(Info,fail)
4544 |
4545 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4546 set_all_passive(RuleNb).
4548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4549 % HEAD SIMPLIFICATION
4550 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4552 % now we check the head matchings (guard may have been simplified meanwhile)
4553 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4554 <=>
4555 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4556 simplify_heads(M,GuardList,G,B,NewM,NewB),
4557 NewM \== [],
4558 extract_arguments(Head1,VH1),
4559 extract_arguments(Head2,VH2),
4560 extract_arguments(H,VH),
4561 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4562 substitute_arguments(Head1,H1,NewH1),
4563 substitute_arguments(Head2,H2,NewH2),
4564 append(NewB,NewB_,NewBody),
4565 list2conj(NewBody,BodyMatchings),
4566 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4567 (Head1 \== NewH1 ; Head2 \== NewH2 )
4568 |
4569 rule(RuleNb,NewRule).
4571 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4572 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4575 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4576 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4577 ( NH == M ->
4578 H2_ = M,
4579 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4580 ;
4581 (M = functor(X,F,A), NH == X ->
4582 length(A_args,A),
4583 (var(H2) ->
4584 NewB1 = [],
4585 H2_ =.. [F|A_args]
4586 ;
4587 H2 =.. [F|OrigArgs],
4588 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4589 H2_ =.. [F|A_args_]
4590 ),
4591 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4592 append(NewB1,NewB2,NewB)
4593 ;
4594 H2_ = H2,
4595 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4596 )
4597 ).
4599 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4600 ( NH == M ->
4601 H1_ = M,
4602 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4603 ;
4604 (M = functor(X,F,A), NH == X ->
4605 length(A_args,A),
4606 (var(H1) ->
4607 NewB1 = [],
4608 H1_ =.. [F|A_args]
4609 ;
4610 H1 =.. [F|OrigArgs],
4611 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4612 H1_ =.. [F|A_args_]
4613 ),
4614 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4615 append(NewB1,NewB2,NewB)
4616 ;
4617 H1_ = H1,
4618 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4619 )
4620 ).
4622 use_same_args([],[],[],_,_,[]).
4623 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4624 var(OA),!,
4625 Out = OA,
4626 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4627 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4628 nonvar(OA),!,
4629 ( common_variables(OA,Body) ->
4630 NewB = [NA = OA|NextB]
4631 ;
4632 NewB = NextB
4633 ),
4634 Out = NA,
4635 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4638 simplify_heads([],_GuardList,_G,_Body,[],[]).
4639 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4640 M = (A = B),
4641 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4642 guard_entailment:entails_guard(GuardList,(A=B)) ->
4643 ( common_variables(B,G-RM-GuardList) ->
4644 NewB = NextB,
4645 NewM = NextM
4646 ;
4647 ( common_variables(B,Body) ->
4648 NewB = [A = B|NextB]
4649 ;
4650 NewB = NextB
4651 ),
4652 NewM = [A|NextM]
4653 )
4654 ;
4655 ( nonvar(B), functor(B,BFu,BAr),
4656 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4657 NewB = NextB,
4658 ( common_variables(B,G-RM-GuardList) ->
4659 NewM = NextM
4660 ;
4661 NewM = [functor(A,BFu,BAr)|NextM]
4662 )
4663 ;
4664 NewM = NextM,
4665 NewB = NextB
4666 )
4667 ),
4668 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4670 common_variables(B,G) :-
4671 term_variables(B,BVars),
4672 term_variables(G,GVars),
4673 intersect_eq(BVars,GVars,L),
4674 L \== [].
4677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4678 % ALWAYS FAILING GUARDS
4679 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4681 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4682 set_all_passive(_) <=> true.
4684 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4685 ==>
4686 chr_pp_flag(check_impossible_rules,on),
4687 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4688 conj2list(G,GL),
4689 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4690 guard_entailment:entails_guard(GL,fail)
4691 |
4692 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4693 set_all_passive(RuleNb).
4697 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4698 % OCCURRENCE SUBSUMPTION
4699 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4701 :- chr_constraint
4702 first_occ_in_rule/4,
4703 next_occ_in_rule/6.
4705 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4706 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4708 :- chr_constraint multiple_occ_constraints_checked/1.
4709 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4711 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4712 occurrence(C,O,RuleNb,ID,_),
4713 occurrence(C,O2,RuleNb,ID2,_),
4714 rule(RuleNb,Rule)
4715 \
4716 multiple_occ_constraints_checked(Done)
4717 <=>
4718 O < O2,
4719 chr_pp_flag(occurrence_subsumption,on),
4720 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4721 H1 \== [],
4722 \+ memberchk_eq(C,Done)
4723 |
4724 first_occ_in_rule(RuleNb,C,O,ID),
4725 multiple_occ_constraints_checked([C|Done]).
4727 % Find first occurrence of constraint =C= in rule =RuleNb=
4728 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4729 <=>
4730 O < O2
4731 |
4732 first_occ_in_rule(RuleNb,C,O,ID).
4734 first_occ_in_rule(RuleNb,C,O,ID_o1)
4735 <=>
4736 C = F/A,
4737 functor(FreshHead,F,A),
4738 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4740 % Skip passive occurrences.
4741 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4742 <=>
4743 O2 is O+1
4744 |
4745 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4747 prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4748 <=>
4749 O2 is O+1,
4750 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4751 |
4752 append(H1,H2,Heads),
4753 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4754 ( ExtraCond == [chr_pp_void_info] ->
4755 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4756 ;
4757 append(ExtraCond,Cond,NewCond),
4758 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4759 copy_term(GuardList,FGuardList),
4760 variable_replacement(GuardList,FGuardList,GLRepl),
4761 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4762 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4763 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4764 append(NewCond,GuardList2,BigCond),
4765 append(BigCond,GuardList3,BigCond2),
4766 copy_with_variable_replacement(M,M2,Repl),
4767 copy_with_variable_replacement(M,M3,Repl2),
4768 append(M3,BigCond2,BigCond3),
4769 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4770 list2conj(CheckCond,OccSubsum),
4771 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4772 ( OccSubsum \= chr_pp_void_info ->
4773 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4774 passive(RuleNb,ID_o2)
4775 ;
4776 true
4777 )
4778 ;
4779 true
4780 ),!,
4781 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4782 ).
4785 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4786 <=>
4787 true.
4789 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4790 <=>
4791 true.
4793 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4794 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4795 append(ID2,ID1,IDs),
4796 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4797 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4798 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4799 copy_with_variable_replacement(G,FG,Repl),
4800 extract_explicit_matchings(FG,FG2),
4801 negate_b(FG2,NotFG),
4802 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4803 ( safely_unifiable(FH,FH2), FH=FH2 ->
4804 FailCond = [(NotFG;FMPCond)]
4805 ;
4806 % in this case, not much can be done
4807 % e.g. c(f(...)), c(g(...)) <=> ...
4808 FailCond = [chr_pp_void_info]
4809 ).
4811 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4812 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4813 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4814 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4815 Cond = (chr_pp_not_in_store(H);Cond1),
4816 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4818 extract_explicit_matchings((A,B),D) :- !,
4819 ( extract_explicit_matchings(A) ->
4820 extract_explicit_matchings(B,D)
4821 ;
4822 D = (A,E),
4823 extract_explicit_matchings(B,E)
4824 ).
4825 extract_explicit_matchings(A,D) :- !,
4826 ( extract_explicit_matchings(A) ->
4827 D = true
4828 ;
4829 D = A
4830 ).
4832 extract_explicit_matchings(A=B) :-
4833 var(A), var(B), !, A=B.
4834 extract_explicit_matchings(A==B) :-
4835 var(A), var(B), !, A=B.
4837 safely_unifiable(H,I) :- var(H), !.
4838 safely_unifiable([],[]) :- !.
4839 safely_unifiable([H|Hs],[I|Is]) :- !,
4840 safely_unifiable(H,I),
4841 safely_unifiable(Hs,Is).
4842 safely_unifiable(H,I) :-
4843 nonvar(H),
4844 nonvar(I),
4845 H =.. [F|HA],
4846 I =.. [F|IA],
4847 safely_unifiable(HA,IA).
4851 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4852 % TYPE INFORMATION
4853 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4855 :- chr_constraint
4856 type_definition/2,
4857 type_alias/2,
4858 constraint_type/2,
4859 get_type_definition/2,
4860 get_constraint_type/2.
4863 :- chr_option(mode,type_definition(?,?)).
4864 :- chr_option(mode,get_type_definition(?,?)).
4865 :- chr_option(mode,type_alias(?,?)).
4866 :- chr_option(mode,constraint_type(+,+)).
4867 :- chr_option(mode,get_constraint_type(+,-)).
4869 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4870 % Consistency checks of type aliases
4872 type_alias(T,T2) <=>
4873 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4874 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4875 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4877 type_alias(T1,A1), type_alias(T2,A2) <=>
4878 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4879 \+ (T1\=T2) |
4880 copy_term_nat(T1,T1_),
4881 copy_term_nat(T2,T2_),
4882 T1_ = T2_,
4883 chr_error(type_error,
4884 '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_]).
4886 type_alias(T,B) \ type_alias(X,T2) <=>
4887 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4888 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4889 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4890 type_alias(X2,D1).
4892 oneway_unification(X,Y) :-
4893 term_variables(X,XVars),
4894 chr_runtime:lockv(XVars),
4895 X=Y,
4896 chr_runtime:unlockv(XVars).
4898 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4899 % Consistency checks of type definitions
4901 type_definition(T1,_), type_definition(T2,_)
4902 <=>
4903 functor(T1,F,A), functor(T2,F,A)
4904 |
4905 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
4907 type_definition(T1,_), type_alias(T2,_)
4908 <=>
4909 functor(T1,F,A), functor(T2,F,A)
4910 |
4911 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
4913 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4914 %% get_type_definition(+Type,-Definition) is semidet.
4915 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4917 get_type_definition(T,Def)
4918 <=>
4919 \+ ground(T)
4920 |
4921 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
4923 type_alias(T,D) \ get_type_definition(T2,Def)
4924 <=>
4925 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4926 copy_term_nat((T,D),(T1,D1)),T1=T2
4927 |
4928 ( get_type_definition(D1,Def) ->
4929 true
4930 ;
4931 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
4932 ).
4934 type_definition(T,D) \ get_type_definition(T2,Def)
4935 <=>
4936 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4937 copy_term_nat((T,D),(T1,D1)),T1=T2
4938 |
4939 Def = D1.
4941 get_type_definition(Type,Def)
4942 <=>
4943 atomic_builtin_type(Type,_,_)
4944 |
4945 Def = [Type].
4947 get_type_definition(Type,Def)
4948 <=>
4949 compound_builtin_type(Type,_,_)
4950 |
4951 Def = [Type].
4953 get_type_definition(X,Y) <=> fail.
4955 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4956 %% get_type_definition_det(+Type,-Definition) is det.
4957 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4958 get_type_definition_det(Type,Definition) :-
4959 ( get_type_definition(Type,Definition) ->
4960 true
4961 ;
4962 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
4963 ).
4965 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4966 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
4967 %
4968 % Return argument types of =ConstraintSymbol=, but fails if none where
4969 % declared.
4970 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4971 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
4972 get_constraint_type(_,_) <=> fail.
4974 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4975 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
4976 %
4977 % Like =get_constraint_type/2=, but returns list of =any= types when
4978 % no types are declared.
4979 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4980 get_constraint_type_det(ConstraintSymbol,Types) :-
4981 ( get_constraint_type(ConstraintSymbol,Types) ->
4982 true
4983 ;
4984 ConstraintSymbol = _ / N,
4985 replicate(N,any,Types)
4986 ).
4987 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4988 %% unalias_type(+Alias,-Type) is det.
4989 %
4990 % Follows alias chain until base type is reached.
4991 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4992 :- chr_constraint unalias_type/2.
4994 unalias_var @
4995 unalias_type(Alias,BaseType)
4996 <=>
4997 var(Alias)
4998 |
4999 BaseType = Alias.
5001 unalias_alias @
5002 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5003 <=>
5004 nonvar(AliasProtoType),
5005 nonvar(Alias),
5006 functor(AliasProtoType,F,A),
5007 functor(Alias,F,A),
5008 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5009 Alias = AliasInstance
5010 |
5011 unalias_type(Type,BaseType).
5013 unalias_type_definition @
5014 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5015 <=>
5016 nonvar(ProtoType),
5017 nonvar(Alias),
5018 functor(ProtoType,F,A),
5019 functor(Alias,F,A)
5020 |
5021 BaseType = Alias.
5023 unalias_atomic_builtin @
5024 unalias_type(Alias,BaseType)
5025 <=>
5026 atomic_builtin_type(Alias,_,_)
5027 |
5028 BaseType = Alias.
5030 unalias_compound_builtin @
5031 unalias_type(Alias,BaseType)
5032 <=>
5033 compound_builtin_type(Alias,_,_)
5034 |
5035 BaseType = Alias.
5037 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5038 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5039 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5040 :- chr_constraint types_modes_condition/3.
5041 :- chr_option(mode,types_modes_condition(+,+,?)).
5042 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5044 types_modes_condition([],[],T) <=> T=true.
5046 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5047 <=>
5048 functor(Head,F,A)
5049 |
5050 Head =.. [_|Args],
5051 Condition = (ModesCondition, TypesCondition, RestCondition),
5052 modes_condition(Modes,Args,ModesCondition),
5053 get_constraint_type_det(F/A,Types),
5054 UnrollHead =.. [_|RealArgs],
5055 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5056 types_modes_condition(Heads,UnrollHeads,RestCondition).
5058 types_modes_condition([Head|_],_,_)
5059 <=>
5060 functor(Head,F,A),
5061 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5064 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5065 %% modes_condition(+Modes,+Args,-Condition) is det.
5066 %
5067 % Return =Condition= on =Args= that checks =Modes=.
5068 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5069 modes_condition([],[],true).
5070 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5071 ( Mode == (+) ->
5072 Condition = ( ground(Arg) , RCondition )
5073 ; Mode == (-) ->
5074 Condition = ( var(Arg) , RCondition )
5075 ;
5076 Condition = RCondition
5077 ),
5078 modes_condition(Modes,Args,RCondition).
5080 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5081 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5082 %
5083 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5084 % =UnrollArgs= controls the depth of type definition unrolling.
5085 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5086 types_condition([],[],[],[],true).
5087 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5088 ( Mode == (-) ->
5089 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5090 ;
5091 get_type_definition_det(Type,Def),
5092 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5093 ( Mode == (+) ->
5094 TypeConditionList = TypeConditionList1
5095 ;
5096 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5097 )
5098 ),
5099 list2disj(TypeConditionList,DisjTypeConditionList),
5100 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5102 type_condition([],_,_,_,[]).
5103 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5104 ( var(DefCase) ->
5105 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5106 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5107 true
5108 ; compound_builtin_type(DefCase,Arg,Condition) ->
5109 true
5110 ;
5111 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5112 ),
5113 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5115 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5116 :- chr_type atomic_builtin_type ---> any
5117 ; number
5118 ; float
5119 ; int
5120 ; natural
5121 ; dense_int
5122 ; chr_identifier
5123 ; chr_identifier(any).
5124 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5126 atomic_builtin_type(any,_Arg,true).
5127 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5128 atomic_builtin_type(int,Arg,integer(Arg)).
5129 atomic_builtin_type(number,Arg,number(Arg)).
5130 atomic_builtin_type(float,Arg,float(Arg)).
5131 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5132 atomic_builtin_type(chr_identifier,_Arg,true).
5134 compound_builtin_type(chr_identifier(_),_Arg,true).
5136 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5137 ( nonvar(DefCase) ->
5138 functor(DefCase,F,A),
5139 ( A == 0 ->
5140 Condition = (Arg = DefCase)
5141 ; var(UnrollArg) ->
5142 Condition = functor(Arg,F,A)
5143 ; functor(UnrollArg,F,A) ->
5144 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5145 DefCase =.. [_|ArgTypes],
5146 UnrollArg =.. [_|UnrollArgs],
5147 functor(Template,F,A),
5148 Template =.. [_|TemplateArgs],
5149 replicate(A,Mode,ArgModes),
5150 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5151 ;
5152 Condition = functor(Arg,F,A)
5153 )
5154 ;
5155 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5156 ).
5159 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5160 % Static type checking
5161 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5162 % Checks head constraints and CHR constraint calls in bodies.
5163 %
5164 % TODO:
5165 % - type clashes involving built-in types
5166 % - Prolog built-ins in guard and body
5167 % - indicate position in terms in error messages
5168 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5169 :- chr_constraint
5170 static_type_check/0.
5172 :- chr_type type_error_src ---> head(any) ; body(any).
5174 rule(_,Rule), static_type_check
5175 ==>
5176 copy_term_nat(Rule,RuleCopy),
5177 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5178 (
5179 catch(
5180 ( static_type_check_heads(Head1),
5181 static_type_check_heads(Head2),
5182 conj2list(Body,GoalList),
5183 static_type_check_body(GoalList)
5184 ),
5185 type_error(Error),
5186 ( Error = invalid_functor(Src,Term,Type) ->
5187 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5188 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5189 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5190 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5191 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5192 )
5193 ),
5194 fail % cleanup constraints
5195 ;
5196 true
5197 ).
5200 static_type_check <=> true.
5202 static_type_check_heads([]).
5203 static_type_check_heads([Head|Heads]) :-
5204 static_type_check_head(Head),
5205 static_type_check_heads(Heads).
5207 static_type_check_head(Head) :-
5208 functor(Head,F,A),
5209 get_constraint_type_det(F/A,Types),
5210 Head =..[_|Args],
5211 maplist(static_type_check_term(head(Head)),Args,Types).
5213 static_type_check_body([]).
5214 static_type_check_body([Goal|Goals]) :-
5215 functor(Goal,F,A),
5216 get_constraint_type_det(F/A,Types),
5217 Goal =..[_|Args],
5218 maplist(static_type_check_term(body(Goal)),Args,Types),
5219 static_type_check_body(Goals).
5221 :- chr_constraint static_type_check_term/3.
5222 :- chr_option(mode,static_type_check_term(?,?,?)).
5223 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5225 static_type_check_term(Src,Term,Type)
5226 <=>
5227 var(Term)
5228 |
5229 static_type_check_var(Src,Term,Type).
5230 static_type_check_term(Src,Term,Type)
5231 <=>
5232 atomic_builtin_type(Type,Term,Goal)
5233 |
5234 ( call(Goal) ->
5235 true
5236 ;
5237 throw(type_error(invalid_functor(Src,Term,Type)))
5238 ).
5239 static_type_check_term(Src,Term,Type)
5240 <=>
5241 compound_builtin_type(Type,Term,Goal)
5242 |
5243 ( call(Goal) ->
5244 true
5245 ;
5246 throw(type_error(invalid_functor(Src,Term,Type)))
5247 ).
5248 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5249 <=>
5250 functor(Type,F,A),
5251 functor(AType,F,A)
5252 |
5253 copy_term_nat(AType-ADef,Type-Def),
5254 static_type_check_term(Src,Term,Def).
5256 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5257 <=>
5258 functor(Type,F,A),
5259 functor(AType,F,A)
5260 |
5261 copy_term_nat(AType-ADef,Type-Variants),
5262 functor(Term,TF,TA),
5263 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5264 Term =.. [_|Args],
5265 Variant =.. [_|Types],
5266 maplist(static_type_check_term(Src),Args,Types)
5267 ;
5268 throw(type_error(invalid_functor(Src,Term,Type)))
5269 ).
5271 static_type_check_term(Src,Term,Type)
5272 <=>
5273 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5275 :- chr_constraint static_type_check_var/3.
5276 :- chr_option(mode,static_type_check_var(?,-,?)).
5277 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5279 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5280 <=>
5281 functor(AType,F,A),
5282 functor(Type,F,A)
5283 |
5284 copy_term_nat(AType-ADef,Type-Def),
5285 static_type_check_var(Src,Var,Def).
5287 static_type_check_var(Src,Var,Type)
5288 <=>
5289 atomic_builtin_type(Type,_,_)
5290 |
5291 static_atomic_builtin_type_check_var(Src,Var,Type).
5293 static_type_check_var(Src,Var,Type)
5294 <=>
5295 compound_builtin_type(Type,_,_)
5296 |
5297 true.
5300 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5301 <=>
5302 Type1 \== Type2
5303 |
5304 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5306 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5307 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5308 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5309 :- chr_constraint static_atomic_builtin_type_check_var/3.
5310 :- chr_option(mode,static_type_check_var(?,-,+)).
5311 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5313 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5314 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5315 <=>
5316 true.
5317 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5318 <=>
5319 true.
5320 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5321 <=>
5322 true.
5323 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5324 <=>
5325 true.
5326 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5327 <=>
5328 true.
5329 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5330 <=>
5331 true.
5332 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5333 <=>
5334 true.
5335 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5336 <=>
5337 true.
5338 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5339 <=>
5340 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5342 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5343 %% format_src(+type_error_src) is det.
5344 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5345 format_src(head(Head)) :- format('head ~w',[Head]).
5346 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5348 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5349 % Dynamic type checking
5350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5352 :- chr_constraint
5353 dynamic_type_check/0,
5354 dynamic_type_check_clauses/1,
5355 get_dynamic_type_check_clauses/1.
5357 generate_dynamic_type_check_clauses(Clauses) :-
5358 ( chr_pp_flag(debugable,on) ->
5359 dynamic_type_check,
5360 get_dynamic_type_check_clauses(Clauses0),
5361 append(Clauses0,
5362 [('$dynamic_type_check'(Type,Term) :-
5363 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5364 )],
5365 Clauses)
5366 ;
5367 Clauses = []
5368 ).
5370 type_definition(T,D), dynamic_type_check
5371 ==>
5372 copy_term_nat(T-D,Type-Definition),
5373 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5374 dynamic_type_check_clauses(DynamicChecks).
5375 type_alias(A,B), dynamic_type_check
5376 ==>
5377 copy_term_nat(A-B,Alias-Body),
5378 dynamic_type_check_alias_clause(Alias,Body,Clause),
5379 dynamic_type_check_clauses([Clause]).
5381 dynamic_type_check <=>
5382 findall(
5383 ('$dynamic_type_check'(Type,Term) :- Goal),
5384 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
5385 BuiltinChecks
5386 ),
5387 dynamic_type_check_clauses(BuiltinChecks).
5389 dynamic_type_check_clause(T,DC,Clause) :-
5390 copy_term(T-DC,Type-DefinitionClause),
5391 functor(DefinitionClause,F,A),
5392 functor(Term,F,A),
5393 DefinitionClause =.. [_|DCArgs],
5394 Term =.. [_|TermArgs],
5395 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5396 list2conj(RecursiveCallList,RecursiveCalls),
5397 Clause = (
5398 '$dynamic_type_check'(Type,Term) :-
5399 RecursiveCalls
5400 ).
5402 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5403 Clause = (
5404 '$dynamic_type_check'(Alias,Term) :-
5405 '$dynamic_type_check'(Body,Term)
5406 ).
5408 dynamic_type_check_call(Type,Term,Call) :-
5409 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5410 % Call = when(nonvar(Term),Goal)
5411 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5412 % Call = when(nonvar(Term),Goal)
5413 % ;
5414 ( Type == any ->
5415 Call = true
5416 ;
5417 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5418 )
5419 % )
5420 .
5422 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5423 <=>
5424 append(C1,C2,C),
5425 dynamic_type_check_clauses(C).
5427 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5428 <=>
5429 Q = C.
5430 get_dynamic_type_check_clauses(Q)
5431 <=>
5432 Q = [].
5434 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5435 % Atomic Types
5436 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5437 % Some optimizations can be applied for atomic types...
5438 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5440 atomic_types_suspended_constraint(C) :-
5441 C = _/N,
5442 get_constraint_type(C,ArgTypes),
5443 get_constraint_mode(C,ArgModes),
5444 findall(I,between(1,N,I),Indexes),
5445 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5447 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5448 ( is_indexed_argument(C,Index) ->
5449 ( Mode == (?) ->
5450 atomic_type(Type)
5451 ;
5452 true
5453 )
5454 ;
5455 true
5456 ).
5458 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5459 %% atomic_type(+Type) is semidet.
5460 %
5461 % Succeeds when all values of =Type= are atomic.
5462 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5463 :- chr_constraint atomic_type/1.
5465 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5467 type_definition(TypePat,Def) \ atomic_type(Type)
5468 <=>
5469 functor(Type,F,A), functor(TypePat,F,A)
5470 |
5471 forall(member(Term,Def),atomic(Term)).
5473 type_alias(TypePat,Alias) \ atomic_type(Type)
5474 <=>
5475 functor(Type,F,A), functor(TypePat,F,A)
5476 |
5477 atomic(Alias),
5478 copy_term_nat(TypePat-Alias,Type-NType),
5479 atomic_type(NType).
5481 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5482 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5483 %
5484 % Succeeds when all values of =Type= are atomic
5485 % and the atom values are finitely enumerable.
5486 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5487 :- chr_constraint enumerated_atomic_type/2.
5489 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5491 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5492 <=>
5493 functor(Type,F,A), functor(TypePat,F,A)
5494 |
5495 forall(member(Term,Def),atomic(Term)),
5496 Atoms = Def.
5498 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5499 <=>
5500 functor(Type,F,A), functor(TypePat,F,A)
5501 |
5502 atomic(Alias),
5503 copy_term_nat(TypePat-Alias,Type-NType),
5504 enumerated_atomic_type(NType,Atoms).
5505 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5507 :- chr_constraint
5508 stored/3, % constraint,occurrence,(yes/no/maybe)
5509 stored_completing/3,
5510 stored_complete/3,
5511 is_stored/1,
5512 is_finally_stored/1,
5513 check_all_passive/2.
5515 :- chr_option(mode,stored(+,+,+)).
5516 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5517 :- chr_type storedinfo ---> yes ; no ; maybe.
5518 :- chr_option(mode,stored_complete(+,+,+)).
5519 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5520 :- chr_option(mode,guard_list(+,+,+,+)).
5521 :- chr_option(mode,check_all_passive(+,+)).
5522 :- chr_option(type_declaration,check_all_passive(any,list)).
5524 % change yes in maybe when yes becomes passive
5525 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5526 stored(C,O,yes), stored_complete(C,RO,Yesses)
5527 <=> O < RO | NYesses is Yesses - 1,
5528 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5529 % change yes in maybe when not observed
5530 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5531 <=> O < RO |
5532 NYesses is Yesses - 1,
5533 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5535 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5536 ==> RO =< MO2 | % C2 is never stored
5537 passive(RuleNb,ID).
5542 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5544 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5545 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5546 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5548 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5549 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5550 check_all_passive(RuleNb,IDs2).
5552 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5553 check_all_passive(RuleNb,IDs).
5555 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5556 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5558 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5560 % collect the storage information
5561 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5562 <=> NO is O + 1, NYesses is Yesses + 1,
5563 stored_completing(C,NO,NYesses).
5564 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5565 <=> NO is O + 1,
5566 stored_completing(C,NO,Yesses).
5568 stored(C,O,no) \ stored_completing(C,O,Yesses)
5569 <=> stored_complete(C,O,Yesses).
5570 stored_completing(C,O,Yesses)
5571 <=> stored_complete(C,O,Yesses).
5573 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5574 O2 > O | passive(RuleNb,Id).
5576 % decide whether a constraint is stored
5577 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5578 <=> RO =< MO | fail.
5579 is_stored(C) <=> true.
5581 % decide whether a constraint is suspends after occurrences
5582 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5583 <=> RO =< MO | fail.
5584 is_finally_stored(C) <=> true.
5586 storage_analysis(Constraints) :-
5587 ( chr_pp_flag(storage_analysis,on) ->
5588 check_constraint_storages(Constraints)
5589 ;
5590 true
5591 ).
5593 check_constraint_storages([]).
5594 check_constraint_storages([C|Cs]) :-
5595 check_constraint_storage(C),
5596 check_constraint_storages(Cs).
5598 check_constraint_storage(C) :-
5599 get_max_occurrence(C,MO),
5600 check_occurrences_storage(C,1,MO).
5602 check_occurrences_storage(C,O,MO) :-
5603 ( O > MO ->
5604 stored_completing(C,1,0)
5605 ;
5606 check_occurrence_storage(C,O),
5607 NO is O + 1,
5608 check_occurrences_storage(C,NO,MO)
5609 ).
5611 check_occurrence_storage(C,O) :-
5612 get_occurrence(C,O,RuleNb,ID),
5613 ( is_passive(RuleNb,ID) ->
5614 stored(C,O,maybe)
5615 ;
5616 get_rule(RuleNb,PragmaRule),
5617 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5618 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5619 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5620 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5621 check_storage_head2(Head2,O,Heads1,Body)
5622 )
5623 ).
5625 check_storage_head1(Head,O,H1,H2,G) :-
5626 functor(Head,F,A),
5627 C = F/A,
5628 ( H1 == [Head],
5629 H2 == [],
5630 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5631 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5632 Head =.. [_|L],
5633 no_matching(L,[]) ->
5634 stored(C,O,no)
5635 ;
5636 stored(C,O,maybe)
5637 ).
5639 no_matching([],_).
5640 no_matching([X|Xs],Prev) :-
5641 var(X),
5642 \+ memberchk_eq(X,Prev),
5643 no_matching(Xs,[X|Prev]).
5645 check_storage_head2(Head,O,H1,B) :-
5646 functor(Head,F,A),
5647 C = F/A,
5648 ( %(
5649 ( H1 \== [], B == true )
5650 %;
5651 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5652 %)
5653 ->
5654 stored(C,O,maybe)
5655 ;
5656 stored(C,O,yes)
5657 ).
5659 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5661 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5662 %% ____ _ ____ _ _ _ _
5663 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5664 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5665 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5666 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5667 %% |_|
5669 constraints_code(Constraints,Clauses) :-
5670 (chr_pp_flag(reduced_indexing,on),
5671 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5672 none_suspended_on_variables
5673 ;
5674 true
5675 ),
5676 constraints_code1(Constraints,Clauses,[]).
5678 %===============================================================================
5679 :- chr_constraint constraints_code1/3.
5680 :- chr_option(mode,constraints_code1(+,+,+)).
5681 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5682 %-------------------------------------------------------------------------------
5683 constraints_code1([],L,T) <=> L = T.
5684 constraints_code1([C|RCs],L,T)
5685 <=>
5686 constraint_code(C,L,T1),
5687 constraints_code1(RCs,T1,T).
5688 %===============================================================================
5689 :- chr_constraint constraint_code/3.
5690 :- chr_option(mode,constraint_code(+,+,+)).
5691 %-------------------------------------------------------------------------------
5692 %% Generate code for a single CHR constraint
5693 constraint_code(Constraint, L, T)
5694 <=> true
5695 | ( (chr_pp_flag(debugable,on) ;
5696 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5697 ( may_trigger(Constraint) ;
5698 get_allocation_occurrence(Constraint,AO),
5699 get_max_occurrence(Constraint,MO), MO >= AO ) )
5700 ->
5701 constraint_prelude(Constraint,Clause),
5702 add_dummy_location(Clause,LocatedClause),
5703 L = [LocatedClause | L1]
5704 ;
5705 L = L1
5706 ),
5707 Id = [0],
5708 occurrences_code(Constraint,1,Id,NId,L1,L2),
5709 gen_cond_attach_clause(Constraint,NId,L2,T).
5711 %===============================================================================
5712 %% Generate prelude predicate for a constraint.
5713 %% f(...) :- f/a_0(...,Susp).
5714 constraint_prelude(F/A, Clause) :-
5715 vars_susp(A,Vars,Susp,VarsSusp),
5716 Head =.. [ F | Vars],
5717 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5718 build_head(F,A,[0],VarsSusp,Delegate),
5719 ( chr_pp_flag(debugable,on) ->
5720 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5721 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5722 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5723 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5725 ( get_constraint_type(F/A,ArgTypeList) ->
5726 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5727 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5728 ;
5729 DynamicTypeChecks = true
5730 ),
5732 Clause =
5733 ( Head :-
5734 DynamicTypeChecks,
5735 InsertGoal,
5736 InsertCall,
5737 AttachCall,
5738 Inactive,
5739 'chr debug_event'(insert(Head#Susp)),
5740 (
5741 'chr debug_event'(call(Susp)),
5742 Delegate
5743 ;
5744 'chr debug_event'(fail(Susp)), !,
5745 fail
5746 ),
5747 (
5748 'chr debug_event'(exit(Susp))
5749 ;
5750 'chr debug_event'(redo(Susp)),
5751 fail
5752 )
5753 )
5754 ; get_allocation_occurrence(F/A,0) ->
5755 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5756 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5757 Clause = ( Head :- Goal, Inactive, Delegate )
5758 ;
5759 Clause = ( Head :- Delegate )
5760 ).
5762 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5763 ( may_trigger(F/A) ->
5764 build_head(F,A,[0],VarsSusp,Delegate),
5765 ( chr_pp_flag(debugable,off) ->
5766 Goal = Delegate
5767 ;
5768 get_target_module(Mod),
5769 Goal = Mod:Delegate
5770 )
5771 ;
5772 Goal = true
5773 ).
5775 %===============================================================================
5776 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5777 :- chr_option(mode,has_active_occurrence(+)).
5778 :- chr_option(mode,has_active_occurrence(+,+)).
5779 %-------------------------------------------------------------------------------
5780 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5782 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5783 O > MO | fail.
5784 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5785 has_active_occurrence(C,O) <=>
5786 NO is O + 1,
5787 has_active_occurrence(C,NO).
5788 has_active_occurrence(C,O) <=> true.
5789 %===============================================================================
5791 gen_cond_attach_clause(F/A,Id,L,T) :-
5792 ( is_finally_stored(F/A) ->
5793 get_allocation_occurrence(F/A,AllocationOccurrence),
5794 get_max_occurrence(F/A,MaxOccurrence),
5795 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5796 ( only_ground_indexed_arguments(F/A) ->
5797 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5798 ;
5799 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5800 )
5801 ; vars_susp(A,Args,Susp,AllArgs),
5802 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5803 ),
5804 build_head(F,A,Id,AllArgs,Head),
5805 Clause = ( Head :- Body ),
5806 add_dummy_location(Clause,LocatedClause),
5807 L = [LocatedClause | T]
5808 ;
5809 L = T
5810 ).
5812 :- chr_constraint use_auxiliary_predicate/1.
5813 :- chr_option(mode,use_auxiliary_predicate(+)).
5815 :- chr_constraint use_auxiliary_predicate/2.
5816 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5818 :- chr_constraint is_used_auxiliary_predicate/1.
5819 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5821 :- chr_constraint is_used_auxiliary_predicate/2.
5822 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5825 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5827 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5829 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5831 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5833 is_used_auxiliary_predicate(P) <=> fail.
5835 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5836 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5838 is_used_auxiliary_predicate(P,C) <=> fail.
5840 %------------------------------------------------------------------------------%
5841 % Only generate import statements for actually used modules.
5842 %------------------------------------------------------------------------------%
5844 :- chr_constraint use_auxiliary_module/1.
5845 :- chr_option(mode,use_auxiliary_module(+)).
5847 :- chr_constraint is_used_auxiliary_module/1.
5848 :- chr_option(mode,is_used_auxiliary_module(+)).
5851 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5853 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5855 is_used_auxiliary_module(P) <=> fail.
5857 % only called for constraints with
5858 % at least one
5859 % non-ground indexed argument
5860 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5861 vars_susp(A,Args,Susp,AllArgs),
5862 make_suspension_continuation_goal(F/A,AllArgs,Closure),
5863 ( get_store_type(F/A,var_assoc_store(_,_)) ->
5864 Attach = true
5865 ;
5866 attach_constraint_atom(F/A,Vars,Susp,Attach)
5867 ),
5868 FTerm =.. [F|Args],
5869 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5870 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5871 ( may_trigger(F/A) ->
5872 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
5873 Goal =
5874 (
5875 ( var(Susp) ->
5876 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
5877 InsertCall,
5878 Attach
5879 ;
5880 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
5881 )
5882 )
5883 ;
5884 Goal =
5885 (
5886 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
5887 InsertCall,
5888 Attach
5889 )
5890 ).
5892 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
5893 vars_susp(A,Args,Susp,AllArgs),
5894 make_suspension_continuation_goal(F/A,AllArgs,Cont),
5895 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
5896 attach_constraint_atom(F/A,Vars,Susp,Attach)
5897 ;
5898 Attach = true
5899 ),
5900 FTerm =.. [F|Args],
5901 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5902 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
5903 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
5904 Goal =
5905 (
5906 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
5907 InsertCall
5908 )
5909 ;
5910 Goal =
5911 (
5912 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
5913 InsertCall,
5914 Attach
5915 )
5916 ).
5918 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
5919 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5920 attach_constraint_atom(FA,Vars,Susp,Attach)
5921 ;
5922 Attach = true
5923 ),
5924 insert_constraint_goal(FA,Susp,Args,InsertCall),
5925 ( chr_pp_flag(late_allocation,on) ->
5926 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
5927 ;
5928 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
5929 ).
5931 %-------------------------------------------------------------------------------
5932 :- chr_constraint occurrences_code/6.
5933 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
5934 %-------------------------------------------------------------------------------
5935 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
5936 <=> O > MO
5937 | NId = Id, L = T.
5938 occurrences_code(C,O,Id,NId,L,T)
5939 <=>
5940 occurrence_code(C,O,Id,Id1,L,L1),
5941 NO is O + 1,
5942 occurrences_code(C,NO,Id1,NId,L1,T).
5943 %-------------------------------------------------------------------------------
5944 :- chr_constraint occurrence_code/6.
5945 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
5946 %-------------------------------------------------------------------------------
5947 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
5948 <=>
5949 ( named_history(RuleNb,_,_) ->
5950 does_use_history(C,O)
5951 ;
5952 true
5953 ),
5954 NId = Id,
5955 L = T.
5956 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
5957 <=> true |
5958 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
5959 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5960 NId = Id,
5961 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
5962 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5963 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
5964 inc_id(Id,NId),
5965 ( unconditional_occurrence(C,O) ->
5966 L1 = T
5967 ;
5968 gen_alloc_inc_clause(C,O,Id,L1,T)
5969 )
5970 ).
5972 occurrence_code(C,O,_,_,_,_)
5973 <=>
5974 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
5975 %-------------------------------------------------------------------------------
5977 %% Generate code based on one removed head of a CHR rule
5978 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5979 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5980 Rule = rule(_,Head2,_,_),
5981 ( Head2 == [] ->
5982 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5983 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
5984 ;
5985 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5986 ).
5988 %% Generate code based on one persistent head of a CHR rule
5989 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5990 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5991 Rule = rule(Head1,_,_,_),
5992 ( Head1 == [] ->
5993 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5994 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
5995 ;
5996 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5997 ).
5999 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6000 vars_susp(A,Vars,Susp,VarsSusp),
6001 build_head(F,A,Id,VarsSusp,Head),
6002 inc_id(Id,IncId),
6003 build_head(F,A,IncId,VarsSusp,CallHead),
6004 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6005 Clause =
6006 (
6007 Head :-
6008 ConditionalAlloc,
6009 CallHead
6010 ),
6011 add_dummy_location(Clause,LocatedClause),
6012 L = [LocatedClause|T].
6014 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6015 get_allocation_occurrence(FA,AO),
6016 ( chr_pp_flag(debugable,off), O == AO ->
6017 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6018 ( may_trigger(FA) ->
6019 Goal = (var(Susp) -> Goal0 ; true)
6020 ;
6021 Goal = Goal0
6022 )
6023 ;
6024 Goal = true
6025 ).
6027 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6028 get_allocation_occurrence(FA,AO),
6029 ( chr_pp_flag(debugable,off), O < AO ->
6030 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6031 ( may_trigger(FA) ->
6032 Goal = (var(Susp) -> Goal0 ; true)
6033 ;
6034 Goal = Goal0
6035 )
6036 ;
6037 Goal = true
6038 ).
6040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6042 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6043 %
6044 % Reorders guard goals with respect to partner constraint retrieval goals and
6045 % active constraint. Returns combined partner retrieval + guard goal.
6047 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6048 ( chr_pp_flag(guard_via_reschedule,on) ->
6049 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6050 list2conj(ScheduleSkeleton,GoalSkeleton)
6051 ;
6052 length(Retrievals,RL), length(LookupSkeleton,RL),
6053 length(GuardList,GL), length(GuardListSkeleton,GL),
6054 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6055 list2conj(GoalListSkeleton,GoalSkeleton)
6056 ).
6057 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6058 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6059 initialize_unit_dictionary(ActiveHead,Dict),
6060 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6061 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6062 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6063 dependency_reorder(Units,NUnits),
6064 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6065 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6066 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6068 wrap_in_functor(Functor,X,Term) :-
6069 Term =.. [Functor,X].
6071 wrappedunits2lists([],[],[],[]).
6072 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6073 Ss = [GoalCopy|TSs],
6074 ( WrappedGoal = lookup(Goal) ->
6075 Ls = [GoalCopy|TLs],
6076 Gs = TGs
6077 ; WrappedGoal = guard(Goal) ->
6078 Gs = [N-GoalCopy|TGs],
6079 Ls = TLs
6080 ),
6081 wrappedunits2lists(Units,TGs,TLs,TSs).
6083 guard_splitting(Rule,SplitGuardList) :-
6084 Rule = rule(H1,H2,Guard,_),
6085 append(H1,H2,Heads),
6086 conj2list(Guard,GuardList),
6087 term_variables(Heads,HeadVars),
6088 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6089 append(GuardPrefix,[RestGuard],SplitGuardList),
6090 term_variables(RestGuardList,GuardVars1),
6091 % variables that are declared to be ground don't need to be locked
6092 ground_vars(Heads,GroundVars),
6093 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6094 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6095 ( chr_pp_flag(guard_locks,on),
6096 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6097 once(pairup(Locks,Unlocks,LocksUnlocks))
6098 ;
6099 Locks = [],
6100 Unlocks = []
6101 ),
6102 list2conj(Locks,LockPhase),
6103 list2conj(Unlocks,UnlockPhase),
6104 list2conj(RestGuardList,RestGuard1),
6105 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6107 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6108 Rule = rule(_,_,_,Body),
6109 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6110 my_term_copy(Body,VarDict2,BodyCopy).
6113 split_off_simple_guard_new([],_,[],[]).
6114 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6115 ( simple_guard_new(G,VarDict) ->
6116 S = [G|Ss],
6117 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6118 ;
6119 S = [],
6120 C = [G|Gs]
6121 ).
6123 % simple guard: cheap and benign (does not bind variables)
6124 simple_guard_new(G,Vars) :-
6125 builtin_binds_b(G,BoundVars),
6126 \+ (( member(V,BoundVars),
6127 memberchk_eq(V,Vars)
6128 )).
6130 dependency_reorder(Units,NUnits) :-
6131 dependency_reorder(Units,[],NUnits).
6133 dependency_reorder([],Acc,Result) :-
6134 reverse(Acc,Result).
6136 dependency_reorder([Unit|Units],Acc,Result) :-
6137 Unit = unit(_GID,_Goal,Type,GIDs),
6138 ( Type == fixed ->
6139 NAcc = [Unit|Acc]
6140 ;
6141 dependency_insert(Acc,Unit,GIDs,NAcc)
6142 ),
6143 dependency_reorder(Units,NAcc,Result).
6145 dependency_insert([],Unit,_,[Unit]).
6146 dependency_insert([X|Xs],Unit,GIDs,L) :-
6147 X = unit(GID,_,_,_),
6148 ( memberchk(GID,GIDs) ->
6149 L = [Unit,X|Xs]
6150 ;
6151 L = [X | T],
6152 dependency_insert(Xs,Unit,GIDs,T)
6153 ).
6155 build_units(Retrievals,Guard,InitialDict,Units) :-
6156 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6157 build_guard_units(Guard,N,Dict,Tail).
6159 build_retrieval_units([],N,N,Dict,Dict,L,L).
6160 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6161 term_variables(U,Vs),
6162 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6163 L = [unit(N,U,fixed,GIDs)|L1],
6164 N1 is N + 1,
6165 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6167 initialize_unit_dictionary(Term,Dict) :-
6168 term_variables(Term,Vars),
6169 pair_all_with(Vars,0,Dict).
6171 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6172 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6173 ( lookup_eq(Dict,V,GID) ->
6174 ( (GID == This ; memberchk(GID,GIDs) ) ->
6175 GIDs1 = GIDs
6176 ;
6177 GIDs1 = [GID|GIDs]
6178 ),
6179 Dict1 = Dict
6180 ;
6181 Dict1 = [V - This|Dict],
6182 GIDs1 = GIDs
6183 ),
6184 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6186 build_guard_units(Guard,N,Dict,Units) :-
6187 ( Guard = [Goal] ->
6188 Units = [unit(N,Goal,fixed,[])]
6189 ; Guard = [Goal|Goals] ->
6190 term_variables(Goal,Vs),
6191 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6192 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6193 N1 is N + 1,
6194 build_guard_units(Goals,N1,NDict,RUnits)
6195 ).
6197 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6198 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6199 ( lookup_eq(Dict,V,GID) ->
6200 ( (GID == This ; memberchk(GID,GIDs) ) ->
6201 GIDs1 = GIDs
6202 ;
6203 GIDs1 = [GID|GIDs]
6204 ),
6205 Dict1 = [V - This|Dict]
6206 ;
6207 Dict1 = [V - This|Dict],
6208 GIDs1 = GIDs
6209 ),
6210 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6212 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6214 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6215 %% ____ _ ____ _ _
6216 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6217 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6218 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6219 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6220 %%
6221 %% _ _ _ ___ __
6222 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6223 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6224 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6225 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6226 %% |_|
6227 :- chr_constraint
6228 functional_dependency/4,
6229 get_functional_dependency/4.
6231 :- chr_option(mode,functional_dependency(+,+,?,?)).
6232 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6234 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6235 <=>
6236 RuleNb > 1, AO > O
6237 |
6238 functional_dependency(C,1,Pattern,Key).
6240 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6241 <=>
6242 RuleNb2 >= RuleNb1
6243 |
6244 QPattern = Pattern, QKey = Key.
6245 get_functional_dependency(_,_,_,_)
6246 <=>
6247 fail.
6249 functional_dependency_analysis(Rules) :-
6250 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6251 functional_dependency_analysis_main(Rules)
6252 ;
6253 true
6254 ).
6256 functional_dependency_analysis_main([]).
6257 functional_dependency_analysis_main([PRule|PRules]) :-
6258 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6259 functional_dependency(C,RuleNb,Pattern,Key)
6260 ;
6261 true
6262 ),
6263 functional_dependency_analysis_main(PRules).
6265 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6266 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6267 Rule = rule(H1,H2,Guard,_),
6268 ( H1 = [C1],
6269 H2 = [C2] ->
6270 true
6271 ; H1 = [C1,C2],
6272 H2 == [] ->
6273 true
6274 ),
6275 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6276 term_variables(C1,Vs),
6277 \+ (
6278 member(V1,Vs),
6279 lookup_eq(List,V1,V2),
6280 memberchk_eq(V2,Vs)
6281 ),
6282 select_pragma_unique_variables(Vs,List,Key1),
6283 copy_term_nat(C1-Key1,Pattern-Key),
6284 functor(C1,F,A).
6286 select_pragma_unique_variables([],_,[]).
6287 select_pragma_unique_variables([V|Vs],List,L) :-
6288 ( lookup_eq(List,V,_) ->
6289 L = T
6290 ;
6291 L = [V|T]
6292 ),
6293 select_pragma_unique_variables(Vs,List,T).
6295 % depends on functional dependency analysis
6296 % and shape of rule: C1 \ C2 <=> true.
6297 set_semantics_rules(Rules) :-
6298 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6299 set_semantics_rules_main(Rules)
6300 ;
6301 true
6302 ).
6304 set_semantics_rules_main([]).
6305 set_semantics_rules_main([R|Rs]) :-
6306 set_semantics_rule_main(R),
6307 set_semantics_rules_main(Rs).
6309 set_semantics_rule_main(PragmaRule) :-
6310 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6311 ( Rule = rule([C1],[C2],true,_),
6312 IDs = ids([ID1],[ID2]),
6313 \+ is_passive(RuleNb,ID1),
6314 functor(C1,F,A),
6315 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6316 copy_term_nat(Pattern-Key,C1-Key1),
6317 copy_term_nat(Pattern-Key,C2-Key2),
6318 Key1 == Key2 ->
6319 passive(RuleNb,ID2)
6320 ;
6321 true
6322 ).
6324 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6325 \+ any_passive_head(RuleNb),
6326 variable_replacement(C1-C2,C2-C1,List),
6327 copy_with_variable_replacement(G,OtherG,List),
6328 negate_b(G,NotG),
6329 once(entails_b(NotG,OtherG)).
6331 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6332 % where C1 and C2 are symmteric constraints
6333 symmetry_analysis(Rules) :-
6334 ( chr_pp_flag(check_unnecessary_active,off) ->
6335 true
6336 ;
6337 symmetry_analysis_main(Rules)
6338 ).
6340 symmetry_analysis_main([]).
6341 symmetry_analysis_main([R|Rs]) :-
6342 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6343 Rule = rule(H1,H2,_,_),
6344 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6345 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6346 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6347 ;
6348 true
6349 ),
6350 symmetry_analysis_main(Rs).
6352 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6353 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6354 ( \+ is_passive(RuleNb,ID),
6355 member2(PreHs,PreIDs,PreH-PreID),
6356 \+ is_passive(RuleNb,PreID),
6357 variable_replacement(PreH,H,List),
6358 copy_with_variable_replacement(Rule,Rule2,List),
6359 identical_guarded_rules(Rule,Rule2) ->
6360 passive(RuleNb,ID)
6361 ;
6362 true
6363 ),
6364 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6366 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6367 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6368 ( \+ is_passive(RuleNb,ID),
6369 member2(PreHs,PreIDs,PreH-PreID),
6370 \+ is_passive(RuleNb,PreID),
6371 variable_replacement(PreH,H,List),
6372 copy_with_variable_replacement(Rule,Rule2,List),
6373 identical_rules(Rule,Rule2) ->
6374 passive(RuleNb,ID)
6375 ;
6376 true
6377 ),
6378 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6380 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6383 %% ____ _ _ _ __ _ _ _
6384 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6385 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6386 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6387 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6388 %% |_|
6390 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6391 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6392 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6393 build_head(F,A,Id,HeadVars,ClauseHead),
6394 get_constraint_mode(F/A,Mode),
6395 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6398 guard_splitting(Rule,GuardList0),
6399 ( is_stored_in_guard(F/A, RuleNb) ->
6400 GuardList = [Hole1|GuardList0]
6401 ;
6402 GuardList = GuardList0
6403 ),
6404 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6406 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6408 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6410 ( is_stored_in_guard(F/A, RuleNb) ->
6411 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6412 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6413 GuardCopyList = [Hole1Copy|_],
6414 Hole1Copy = (Allocation, Attachment)
6415 ;
6416 true
6417 ),
6420 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6421 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6423 ( chr_pp_flag(debugable,on) ->
6424 Rule = rule(_,_,Guard,Body),
6425 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6426 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6427 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6428 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6429 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6430 ;
6431 Cut = ActualCut
6432 ),
6433 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6434 Clause = ( ClauseHead :-
6435 FirstMatching,
6436 RescheduledTest,
6437 Cut,
6438 SuspsDetachments,
6439 SuspDetachment,
6440 BodyCopy
6441 ),
6442 add_location(Clause,RuleNb,LocatedClause),
6443 L = [LocatedClause | T].
6445 add_location(Clause,RuleNb,NClause) :-
6446 ( chr_pp_flag(line_numbers,on) ->
6447 get_chr_source_file(File),
6448 get_line_number(RuleNb,LineNb),
6449 NClause = '$source_location'(File,LineNb):Clause
6450 ;
6451 NClause = Clause
6452 ).
6454 add_dummy_location(Clause,NClause) :-
6455 ( chr_pp_flag(line_numbers,on) ->
6456 get_chr_source_file(File),
6457 NClause = '$source_location'(File,1):Clause
6458 ;
6459 NClause = Clause
6460 ).
6461 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6462 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6463 %
6464 % Return goal matching newly introduced variables with variables in
6465 % previously looked-up heads.
6466 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6467 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6468 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6470 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6471 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6472 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6473 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6474 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6475 list2conj(GoalList,Goal).
6477 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6478 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6479 ( var(Arg) ->
6480 ( lookup_eq(VarDict,Arg,OtherVar) ->
6481 ( Mode = (+) ->
6482 ( memberchk_eq(Arg,GroundVars) ->
6483 GoalList = [Var = OtherVar | RestGoalList],
6484 GroundVars1 = GroundVars
6485 ;
6486 GoalList = [Var == OtherVar | RestGoalList],
6487 GroundVars1 = [Arg|GroundVars]
6488 )
6489 ;
6490 GoalList = [Var == OtherVar | RestGoalList],
6491 GroundVars1 = GroundVars
6492 ),
6493 VarDict1 = VarDict
6494 ;
6495 VarDict1 = [Arg-Var | VarDict],
6496 GoalList = RestGoalList,
6497 ( Mode = (+) ->
6498 GroundVars1 = [Arg|GroundVars]
6499 ;
6500 GroundVars1 = GroundVars
6501 )
6502 ),
6503 Pairs = Rest,
6504 RestModes = Modes
6505 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6506 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6507 GoalList = [Goal|RestGoalList],
6508 VarDict = VarDict1,
6509 GroundVars1 = GroundVars,
6510 Pairs = Rest,
6511 RestModes = Modes
6512 ; atomic(Arg) ->
6513 ( Mode = (+) ->
6514 GoalList = [ Var = Arg | RestGoalList]
6515 ;
6516 GoalList = [ Var == Arg | RestGoalList]
6517 ),
6518 VarDict = VarDict1,
6519 GroundVars1 = GroundVars,
6520 Pairs = Rest,
6521 RestModes = Modes
6522 ; Mode == (+), is_ground(GroundVars,Arg) ->
6523 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6524 GoalList = [ Var = ArgCopy | RestGoalList],
6525 VarDict = VarDict1,
6526 GroundVars1 = GroundVars,
6527 Pairs = Rest,
6528 RestModes = Modes
6529 ; Arg =.. [_|Args],
6530 functor(Arg,Fct,N),
6531 functor(Term,Fct,N),
6532 Term =.. [_|Vars],
6533 ( Mode = (+) ->
6534 GoalList = [ Var = Term | RestGoalList ]
6535 ;
6536 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6537 ),
6538 pairup(Args,Vars,NewPairs),
6539 append(NewPairs,Rest,Pairs),
6540 replicate(N,Mode,NewModes),
6541 append(NewModes,Modes,RestModes),
6542 VarDict1 = VarDict,
6543 GroundVars1 = GroundVars
6544 ),
6545 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6547 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6548 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6549 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6550 add_heads_types([],VarTypes,VarTypes).
6551 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6552 add_head_types(Head,VarTypes,VarTypes1),
6553 add_heads_types(Heads,VarTypes1,NVarTypes).
6555 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6556 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6557 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6558 add_head_types(Head,VarTypes,NVarTypes) :-
6559 functor(Head,F,A),
6560 get_constraint_type_det(F/A,ArgTypes),
6561 Head =.. [_|Args],
6562 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6564 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6565 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6566 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6567 add_args_types([],[],VarTypes,VarTypes).
6568 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6569 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6570 add_args_types(Args,Types,VarTypes1,NVarTypes).
6572 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6573 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6574 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6575 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6576 ( var(Term) ->
6577 ( lookup_eq(VarTypes,Term,_) ->
6578 NVarTypes = VarTypes
6579 ;
6580 NVarTypes = [Term-Type|VarTypes]
6581 )
6582 ; ground(Term) ->
6583 NVarTypes = VarTypes
6584 ; % TODO improve approximation!
6585 term_variables(Term,Vars),
6586 length(Vars,VarNb),
6587 replicate(VarNb,any,Types),
6588 add_args_types(Vars,Types,VarTypes,NVarTypes)
6589 ).
6593 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6594 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6595 %
6596 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6597 add_heads_ground_variables([],GroundVars,GroundVars).
6598 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6599 add_head_ground_variables(Head,GroundVars,GroundVars1),
6600 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6602 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6603 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6604 %
6605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6606 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6607 functor(Head,F,A),
6608 get_constraint_mode(F/A,ArgModes),
6609 Head =.. [_|Args],
6610 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6613 add_arg_ground_variables([],[],GroundVars,GroundVars).
6614 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6615 ( Mode == (+) ->
6616 term_variables(Arg,Vars),
6617 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6618 ;
6619 GroundVars = GroundVars1
6620 ),
6621 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6623 add_var_ground_variables([],GroundVars,GroundVars).
6624 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6625 ( memberchk_eq(Var,GroundVars) ->
6626 GroundVars1 = GroundVars
6627 ;
6628 GroundVars1 = [Var|GroundVars]
6629 ),
6630 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6631 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6632 %% is_ground(+GroundVars,+Term) is semidet.
6633 %
6634 % Determine whether =Term= is always ground.
6635 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6636 is_ground(GroundVars,Term) :-
6637 ( ground(Term) ->
6638 true
6639 ; compound(Term) ->
6640 Term =.. [_|Args],
6641 maplist(is_ground(GroundVars),Args)
6642 ;
6643 memberchk_eq(Term,GroundVars)
6644 ).
6646 %% check_ground(+GroundVars,+Term,-Goal) is det.
6647 %
6648 % Return runtime check to see whether =Term= is ground.
6649 check_ground(GroundVars,Term,Goal) :-
6650 term_variables(Term,Variables),
6651 check_ground_variables(Variables,GroundVars,Goal).
6653 check_ground_variables([],_,true).
6654 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6655 ( memberchk_eq(Var,GroundVars) ->
6656 check_ground_variables(Vars,GroundVars,Goal)
6657 ;
6658 Goal = (ground(Var), RGoal),
6659 check_ground_variables(Vars,GroundVars,RGoal)
6660 ).
6662 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6663 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6665 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6666 ( Heads = [_|_] ->
6667 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6668 ;
6669 GoalList = [],
6670 Susps = [],
6671 VarDict = NVarDict,
6672 GroundVars = NGroundVars
6673 ).
6675 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6676 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6677 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6678 functor(H,F,A),
6679 head_info(H,A,Vars,_,_,Pairs),
6680 get_store_type(F/A,StoreType),
6681 ( StoreType == default ->
6682 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6683 delay_phase_end(validate_store_type_assumptions,
6684 ( static_suspension_term(F/A,Suspension),
6685 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6686 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6687 )
6688 ),
6689 % create_get_mutable_ref(active,State,GetMutable),
6690 get_constraint_mode(F/A,Mode),
6691 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6692 NPairs = Pairs,
6693 sbag_member_call(Susp,VarSusps,Sbag),
6694 ExistentialLookup = (
6695 ViaGoal,
6696 Sbag,
6697 Susp = Suspension, % not inlined
6698 GetState
6699 )
6700 ;
6701 delay_phase_end(validate_store_type_assumptions,
6702 ( static_suspension_term(F/A,Suspension),
6703 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6704 )
6705 ),
6706 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6707 get_constraint_mode(F/A,Mode),
6708 filter_mode(NPairs,Pairs,Mode,NMode),
6709 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6710 ),
6711 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6712 append(NPairs,VarDict1,DA_), % order important here
6713 translate(GroundVars1,DA_,GroundVarsA),
6714 translate(GroundVars1,VarDict1,GroundVarsB),
6715 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6716 Goal =
6717 (
6718 ExistentialLookup,
6719 DiffSuspGoals,
6720 MatchingGoal2
6721 ),
6722 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6724 inline_matching_goal(A==B,true,GVA,GVB) :-
6725 memberchk_eq(A,GVA),
6726 memberchk_eq(B,GVB),
6727 A=B, !.
6729 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6730 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6731 inline_matching_goal(A,A2,GVA,GVB),
6732 inline_matching_goal(B,B2,GVA,GVB).
6733 inline_matching_goal(X,X,_,_).
6736 filter_mode([],_,_,[]).
6737 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6738 ( Var == V ->
6739 Modes = [M|MT],
6740 filter_mode(Rest,R,Ms,MT)
6741 ;
6742 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6743 ).
6745 check_unique_keys([],_).
6746 check_unique_keys([V|Vs],Dict) :-
6747 lookup_eq(Dict,V,_),
6748 check_unique_keys(Vs,Dict).
6750 % Generates tests to ensure the found constraint differs from previously found constraints
6751 % TODO: detect more cases where constraints need be different
6752 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6753 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6754 list2conj(DiffSuspGoalList,DiffSuspGoals).
6756 different_from_other_susps_(_,[],_,_,[]) :- !.
6757 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6758 ( functor(Head,F,A), functor(PreHead,F,A),
6759 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6760 \+ \+ PreHeadCopy = HeadCopy ->
6762 List = [Susp \== PreSusp | Tail]
6763 ;
6764 List = Tail
6765 ),
6766 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6768 % passive_head_via(in,in,in,in,out,out,out) :-
6769 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6770 functor(Head,F,A),
6771 get_constraint_index(F/A,Pos),
6772 common_variables(Head,PrevHeads,CommonVars),
6773 global_list_store_name(F/A,Name),
6774 GlobalGoal = nb_getval(Name,AllSusps),
6775 get_constraint_mode(F/A,ArgModes),
6776 ( Vars == [] ->
6777 Goal = GlobalGoal
6778 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6779 translate([CommonVar],VarDict,[Var]),
6780 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6781 Goal = AttrGoal
6782 ;
6783 translate(CommonVars,VarDict,Vars),
6784 add_heads_types(PrevHeads,[],TypeDict),
6785 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6786 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6787 Goal =
6788 ( ViaGoal ->
6789 AttrGoal
6790 ;
6791 GlobalGoal
6792 )
6793 ).
6795 common_variables(T,Ts,Vs) :-
6796 term_variables(T,V1),
6797 term_variables(Ts,V2),
6798 intersect_eq(V1,V2,Vs).
6800 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6801 get_target_module(Mod),
6802 ( Vars = [A] ->
6803 lookup_eq(TypeDict,A,Type),
6804 ( atomic_type(Type) ->
6805 ViaGoal = var(A),
6806 A = V
6807 ;
6808 ViaGoal = 'chr newvia_1'(A,V)
6809 )
6810 ; Vars = [A,B] ->
6811 ViaGoal = 'chr newvia_2'(A,B,V)
6812 ;
6813 ViaGoal = 'chr newvia'(Vars,V)
6814 ),
6815 AttrGoal =
6816 ( get_attr(V,Mod,TSusps),
6817 TSuspsEqSusps % TSusps = Susps
6818 ),
6819 get_max_constraint_index(N),
6820 ( N == 1 ->
6821 TSuspsEqSusps = true, % TSusps = Susps
6822 AllSusps = TSusps
6823 ;
6824 get_constraint_index(FA,Pos),
6825 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6826 ).
6827 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6828 get_target_module(Mod),
6829 AttrGoal =
6830 ( get_attr(Var,Mod,TSusps),
6831 TSuspsEqSusps % TSusps = Susps
6832 ),
6833 get_max_constraint_index(N),
6834 ( N == 1 ->
6835 TSuspsEqSusps = true, % TSusps = Susps
6836 AllSusps = TSusps
6837 ;
6838 get_constraint_index(FA,Pos),
6839 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6840 ).
6842 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6843 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6844 list2conj(GuardCopyList,GuardCopy).
6846 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6847 Rule = rule(H,_,Guard,Body),
6848 conj2list(Guard,GuardList),
6849 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6850 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6852 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6853 term_variables(RestGuardList,GuardVars),
6854 term_variables(RestGuardListCopyCore,GuardCopyVars),
6855 % variables that are declared to be ground don't need to be locked
6856 ground_vars(H,GroundVars),
6857 list_difference_eq(GuardVars,GroundVars,GuardVars_),
6858 ( chr_pp_flag(guard_locks,on),
6859 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6860 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
6861 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
6862 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
6863 ),
6864 LocksUnlocks) ->
6865 once(pairup(Locks,Unlocks,LocksUnlocks))
6866 ;
6867 Locks = [],
6868 Unlocks = []
6869 ),
6870 list2conj(Locks,LockPhase),
6871 list2conj(Unlocks,UnlockPhase),
6872 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
6873 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
6874 my_term_copy(Body,VarDict2,BodyCopy).
6877 split_off_simple_guard([],_,[],[]).
6878 split_off_simple_guard([G|Gs],VarDict,S,C) :-
6879 ( simple_guard(G,VarDict) ->
6880 S = [G|Ss],
6881 split_off_simple_guard(Gs,VarDict,Ss,C)
6882 ;
6883 S = [],
6884 C = [G|Gs]
6885 ).
6887 % simple guard: cheap and benign (does not bind variables)
6888 simple_guard(G,VarDict) :-
6889 binds_b(G,Vars),
6890 \+ (( member(V,Vars),
6891 lookup_eq(VarDict,V,_)
6892 )).
6894 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
6895 functor(Head,F,A),
6896 C = F/A,
6897 ( is_stored(C) ->
6898 (
6899 (
6900 Id == [0], chr_pp_flag(store_in_guards, off)
6901 ;
6902 ( get_allocation_occurrence(C,AO),
6903 get_max_occurrence(C,MO),
6904 MO < AO )
6905 ),
6906 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
6907 SuspDetachment = true
6908 ;
6909 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
6910 ( chr_pp_flag(late_allocation,on) ->
6911 SuspDetachment =
6912 ( var(Susp) ->
6913 true
6914 ;
6915 UnCondSuspDetachment
6916 )
6917 ;
6918 SuspDetachment = UnCondSuspDetachment
6919 )
6920 )
6921 ;
6922 SuspDetachment = true
6923 ).
6925 partner_constraint_detachments([],[],_,true).
6926 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
6927 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
6928 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
6930 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
6931 functor(Head,F,A),
6932 C = F/A,
6933 ( is_stored(C) ->
6934 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
6935 ( chr_pp_flag(debugable,on) ->
6936 DebugEvent = 'chr debug_event'(remove(Susp))
6937 ;
6938 DebugEvent = true
6939 ),
6940 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
6941 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
6942 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
6943 detach_constraint_atom(C,Vars,Susp,Detach)
6944 ;
6945 Detach = true
6946 )
6947 ;
6948 SuspDetachment = true
6949 ).
6951 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6953 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6954 %% ____ _ _ _ _
6955 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
6956 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
6957 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
6958 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
6959 %% |_| |___/
6961 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
6962 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
6963 Rule = rule(_Heads,Heads2,Guard,Body),
6965 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
6966 get_constraint_mode(F/A,Mode),
6967 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6969 build_head(F,A,Id,HeadVars,ClauseHead),
6971 append(RestHeads,Heads2,Heads),
6972 append(OtherIDs,Heads2IDs,IDs),
6973 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
6975 guard_splitting(Rule,GuardList0),
6976 ( is_stored_in_guard(F/A, RuleNb) ->
6977 GuardList = [Hole1|GuardList0]
6978 ;
6979 GuardList = GuardList0
6980 ),
6981 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6983 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6984 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
6986 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6988 ( is_stored_in_guard(F/A, RuleNb) ->
6989 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6990 GuardCopyList = [Hole1Copy|_],
6991 Hole1Copy = Attachment
6992 ;
6993 true
6994 ),
6996 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
6997 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
6998 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7000 ( chr_pp_flag(debugable,on) ->
7001 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7002 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7003 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7004 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7005 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7006 instrument_goal((!),DebugTry,DebugApply,Cut)
7007 ;
7008 Cut = (!)
7009 ),
7011 Clause = ( ClauseHead :-
7012 FirstMatching,
7013 RescheduledTest,
7014 Cut,
7015 SuspsDetachments,
7016 SuspDetachment,
7017 BodyCopy
7018 ),
7019 add_location(Clause,RuleNb,LocatedClause),
7020 L = [LocatedClause | T].
7022 split_by_ids([],[],_,[],[]).
7023 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7024 ( memberchk_eq(I,I1s) ->
7025 S1s = [S | R1s],
7026 S2s = R2s
7027 ;
7028 S1s = R1s,
7029 S2s = [S | R2s]
7030 ),
7031 split_by_ids(Is,Ss,I1s,R1s,R2s).
7033 split_by_ids([],[],_,[],[],[],[]).
7034 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7035 ( memberchk_eq(I,I1s) ->
7036 S1s = [S | R1s],
7037 SI1s = [I|RSI1s],
7038 S2s = R2s,
7039 SI2s = RSI2s
7040 ;
7041 S1s = R1s,
7042 SI1s = RSI1s,
7043 S2s = [S | R2s],
7044 SI2s = [I|RSI2s]
7045 ),
7046 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7047 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7050 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7051 %% ____ _ _ _ ____
7052 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7053 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7054 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7055 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7056 %% |_| |___/
7058 %% Genereate prelude + worker predicate
7059 %% prelude calls worker
7060 %% worker iterates over one type of removed constraints
7061 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7062 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7063 Rule = rule(Heads1,_,Guard,Body),
7064 append(Heads1,RestHeads2,Heads),
7065 append(IDs1,RestIDs,IDs),
7066 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7067 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7068 extend_id(Id,Id1),
7069 ( memberchk_eq(NID,IDs2) ->
7070 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7071 ;
7072 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7073 ),
7074 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
7075 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7077 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
7078 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7079 Heads = [Head|RHeads],
7080 inc_id(Id,Id1),
7081 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
7082 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
7083 ( memberchk_eq(ID,IDs2) ->
7084 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7085 ;
7086 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7087 ).
7089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7090 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7091 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7092 build_head(F,A,Id1,VarsSusp,ClauseHead),
7093 get_constraint_mode(F/A,Mode),
7094 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7096 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7098 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7100 extend_id(Id1,DelegateId),
7101 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7102 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7103 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
7105 PreludeClause =
7106 ( ClauseHead :-
7107 FirstMatching,
7108 ModConstraintsGoal,
7109 !,
7110 ConstraintAllocationGoal,
7111 Delegate
7112 ),
7113 add_dummy_location(PreludeClause,LocatedPreludeClause),
7114 L = [LocatedPreludeClause|T].
7116 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7117 Term =.. [_|Args],
7118 delegate_variables(Term,Terms,VarDict,Args,Vars).
7120 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7121 term_variables(PrevTerms,PrevVars),
7122 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7124 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7125 term_variables(Term,V1),
7126 term_variables(Terms,V2),
7127 intersect_eq(V1,V2,V3),
7128 list_difference_eq(V3,PrevVars,V4),
7129 translate(V4,VarDict,Vars).
7132 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7133 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7134 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7135 Rule = rule(_,_,Guard,Body),
7136 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7138 gen_var(OtherSusp),
7139 gen_var(OtherSusps),
7141 functor(CurrentHead,OtherF,OtherA),
7142 gen_vars(OtherA,OtherVars),
7143 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7144 get_constraint_mode(OtherF/OtherA,Mode),
7145 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7147 delay_phase_end(validate_store_type_assumptions,
7148 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7149 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7150 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7151 )
7152 ),
7153 % create_get_mutable_ref(active,State,GetMutable),
7154 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7155 CurrentSuspTest = (
7156 OtherSusp = OtherSuspension,
7157 GetState,
7158 DiffSuspGoals,
7159 FirstMatching
7160 ),
7162 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7163 build_head(F,A,Id,ClauseVars,ClauseHead),
7165 guard_splitting(Rule,GuardList0),
7166 ( is_stored_in_guard(F/A, RuleNb) ->
7167 GuardList = [Hole1|GuardList0]
7168 ;
7169 GuardList = GuardList0
7170 ),
7171 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7173 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7174 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7175 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7177 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7179 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7180 build_head(F,A,Id,RecursiveVars,RecursiveCall),
7181 RecursiveVars2 = [[]|PreVarsAndSusps],
7182 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
7184 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7185 ( is_stored_in_guard(F/A, RuleNb) ->
7186 GuardCopyList = [GuardAttachment|_] % once( ) ??
7187 ;
7188 true
7189 ),
7191 ( is_observed(F/A,O) ->
7192 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7193 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7194 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7195 ;
7196 Attachment = true,
7197 ConditionalRecursiveCall = RecursiveCall,
7198 ConditionalRecursiveCall2 = RecursiveCall2
7199 ),
7201 ( chr_pp_flag(debugable,on) ->
7202 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7203 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7204 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7205 ;
7206 DebugTry = true,
7207 DebugApply = true
7208 ),
7210 ( is_stored_in_guard(F/A, RuleNb) ->
7211 GuardAttachment = Attachment,
7212 BodyAttachment = true
7213 ;
7214 GuardAttachment = true,
7215 BodyAttachment = Attachment % will be true if not observed at all
7216 ),
7218 ( member(unique(ID1,UniqueKeys), Pragmas),
7219 check_unique_keys(UniqueKeys,VarDict) ->
7220 Clause =
7221 ( ClauseHead :-
7222 ( CurrentSuspTest ->
7223 ( RescheduledTest,
7224 DebugTry ->
7225 DebugApply,
7226 Susps1Detachments,
7227 BodyAttachment,
7228 BodyCopy,
7229 ConditionalRecursiveCall2
7230 ;
7231 RecursiveCall2
7232 )
7233 ;
7234 RecursiveCall
7235 )
7236 )
7237 ;
7238 Clause =
7239 ( ClauseHead :-
7240 ( CurrentSuspTest,
7241 RescheduledTest,
7242 DebugTry ->
7243 DebugApply,
7244 Susps1Detachments,
7245 BodyAttachment,
7246 BodyCopy,
7247 ConditionalRecursiveCall
7248 ;
7249 RecursiveCall
7250 )
7251 )
7252 ),
7253 add_location(Clause,RuleNb,LocatedClause),
7254 L = [LocatedClause | T].
7256 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7257 ( may_trigger(FA) ->
7258 does_use_field(FA,generation),
7259 delay_phase_end(validate_store_type_assumptions,
7260 ( static_suspension_term(FA,Suspension),
7261 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7262 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7263 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7264 )
7265 )
7266 ;
7267 delay_phase_end(validate_store_type_assumptions,
7268 ( static_suspension_term(FA,Suspension),
7269 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7270 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7271 )
7272 ),
7273 GetGeneration = true
7274 ),
7275 ConditionalCall =
7276 ( Susp = Suspension,
7277 GetState,
7278 GetGeneration ->
7279 UpdateState,
7280 Call
7281 ;
7282 true
7283 ).
7285 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7288 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7289 %% ____ _ _
7290 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7291 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7292 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7293 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7294 %% |_| |___/
7296 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7297 ( RestHeads == [] ->
7298 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7299 ;
7300 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7301 ).
7302 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7303 %% Single headed propagation
7304 %% everything in a single clause
7305 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7306 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7307 build_head(F,A,Id,VarsSusp,ClauseHead),
7309 inc_id(Id,NextId),
7310 build_head(F,A,NextId,VarsSusp,NextHead),
7312 get_constraint_mode(F/A,Mode),
7313 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7314 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7316 % - recursive call -
7317 RecursiveCall = NextHead,
7319 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7320 ActualCut = true
7321 ;
7322 ActualCut = !
7323 ),
7325 Rule = rule(_,_,Guard,Body),
7326 ( chr_pp_flag(debugable,on) ->
7327 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7328 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7329 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7330 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7331 ;
7332 Cut = ActualCut
7333 ),
7334 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7335 use_auxiliary_predicate(novel_production),
7336 use_auxiliary_predicate(extend_history),
7337 does_use_history(F/A,O),
7338 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7340 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7341 ( HistoryIDs == [] ->
7342 empty_named_history_novel_production(HistoryName,NovelProduction),
7343 empty_named_history_extend_history(HistoryName,ExtendHistory)
7344 ;
7345 Tuple = HistoryName
7346 )
7347 ;
7348 Tuple = RuleNb
7349 ),
7351 ( var(NovelProduction) ->
7352 NovelProduction = '$novel_production'(Susp,Tuple),
7353 ExtendHistory = '$extend_history'(Susp,Tuple)
7354 ;
7355 true
7356 ),
7358 ( is_observed(F/A,O) ->
7359 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7360 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7361 ;
7362 Attachment = true,
7363 ConditionalRecursiveCall = RecursiveCall
7364 )
7365 ;
7366 Allocation = true,
7367 NovelProduction = true,
7368 ExtendHistory = true,
7370 ( is_observed(F/A,O) ->
7371 get_allocation_occurrence(F/A,AllocO),
7372 ( O == AllocO ->
7373 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7374 Generation = 0
7375 ; % more room for improvement?
7376 Attachment = (Attachment1, Attachment2),
7377 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7378 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7379 ),
7380 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7381 ;
7382 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7383 ConditionalRecursiveCall = RecursiveCall
7384 )
7385 ),
7387 ( is_stored_in_guard(F/A, RuleNb) ->
7388 GuardAttachment = Attachment,
7389 BodyAttachment = true
7390 ;
7391 GuardAttachment = true,
7392 BodyAttachment = Attachment % will be true if not observed at all
7393 ),
7395 Clause = (
7396 ClauseHead :-
7397 HeadMatching,
7398 Allocation,
7399 NovelProduction,
7400 GuardAttachment,
7401 GuardCopy,
7402 Cut,
7403 ExtendHistory,
7404 BodyAttachment,
7405 BodyCopy,
7406 ConditionalRecursiveCall
7407 ),
7408 add_location(Clause,RuleNb,LocatedClause),
7409 ProgramList = [LocatedClause | ProgramTail].
7411 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7412 %% multi headed propagation
7413 %% prelude + predicates to accumulate the necessary combinations of suspended
7414 %% constraints + predicate to execute the body
7415 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7416 RestHeads = [First|Rest],
7417 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7418 extend_id(Id,ExtendedId),
7419 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7422 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7423 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7424 build_head(F,A,Id,VarsSusp,PreludeHead),
7425 get_constraint_mode(F/A,Mode),
7426 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7427 Rule = rule(_,_,Guard,Body),
7428 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7430 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7432 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7434 extend_id(Id,NestedId),
7435 append([Susps|VarsSusp],ExtraVars,NestedVars),
7436 build_head(F,A,NestedId,NestedVars,NestedHead),
7437 NestedCall = NestedHead,
7439 Prelude = (
7440 PreludeHead :-
7441 FirstMatching,
7442 FirstSuspGoal,
7443 !,
7444 CondAllocation,
7445 NestedCall
7446 ),
7447 add_dummy_location(Prelude,LocatedPrelude),
7448 L = [LocatedPrelude|T].
7450 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7451 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7452 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
7453 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7455 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7456 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
7457 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
7458 inc_id(Id,IncId),
7459 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7461 %check_fd_lookup_condition(_,_,_,_) :- fail.
7462 check_fd_lookup_condition(F,A,_,_) :-
7463 get_store_type(F/A,global_singleton), !.
7464 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7465 \+ may_trigger(F/A),
7466 get_functional_dependency(F/A,1,P,K),
7467 copy_term(P-K,CurrentHead-Key),
7468 term_variables(PreHeads,PreVars),
7469 intersect_eq(Key,PreVars,Key),!.
7471 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7472 Rule = rule(_,H2,Guard,Body),
7473 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7474 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7475 init(AllSusps,RestSusps),
7476 last(AllSusps,Susp),
7477 gen_var(OtherSusp),
7478 gen_var(OtherSusps),
7479 functor(CurrentHead,OtherF,OtherA),
7480 gen_vars(OtherA,OtherVars),
7481 delay_phase_end(validate_store_type_assumptions,
7482 ( static_suspension_term(OtherF/OtherA,Suspension),
7483 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7484 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7485 )
7486 ),
7487 % create_get_mutable_ref(active,State,GetMutable),
7488 CurrentSuspTest = (
7489 OtherSusp = Suspension,
7490 GetState
7491 ),
7492 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7493 build_head(F,A,Id,ClauseVars,ClauseHead),
7494 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7495 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
7496 RecursiveVars = PreVarsAndSusps1
7497 ;
7498 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7499 PrevId = Id
7500 ),
7501 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7502 RecursiveCall = RecursiveHead,
7503 CurrentHead =.. [_|OtherArgs],
7504 pairup(OtherArgs,OtherVars,OtherPairs),
7505 get_constraint_mode(OtherF/OtherA,Mode),
7506 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7508 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7509 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7510 get_occurrence(F/A,O,_,ID),
7512 ( is_observed(F/A,O) ->
7513 init(FirstVarsSusp,FirstVars),
7514 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7515 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7516 ;
7517 Attachment = true,
7518 ConditionalRecursiveCall = RecursiveCall
7519 ),
7520 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7521 NovelProduction = true,
7522 ExtendHistory = true
7523 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7524 NovelProduction = true,
7525 ExtendHistory = true
7526 ;
7527 get_occurrence(F/A,O,_,ID),
7528 use_auxiliary_predicate(novel_production),
7529 use_auxiliary_predicate(extend_history),
7530 does_use_history(F/A,O),
7531 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7532 ( HistoryIDs == [] ->
7533 empty_named_history_novel_production(HistoryName,NovelProduction),
7534 empty_named_history_extend_history(HistoryName,ExtendHistory)
7535 ;
7536 reverse([OtherSusp|RestSusps],NamedSusps),
7537 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7538 HistorySusps = [HistorySusp|_],
7540 ( length(HistoryIDs, 1) ->
7541 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7542 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7543 ;
7544 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7545 Tuple =.. [t,HistoryName|HistorySusps]
7546 )
7547 )
7548 ;
7549 HistorySusp = Susp,
7550 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7551 sort([ID|RestIDs],HistoryIDs),
7552 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7553 Tuple =.. [t,RuleNb|HistorySusps]
7554 ),
7556 ( var(NovelProduction) ->
7557 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7558 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7559 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7560 ;
7561 true
7562 )
7563 ),
7566 ( chr_pp_flag(debugable,on) ->
7567 Rule = rule(_,_,Guard,Body),
7568 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7569 get_occurrence(F/A,O,_,ID),
7570 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7571 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7572 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7573 ;
7574 DebugTry = true,
7575 DebugApply = true
7576 ),
7578 ( is_stored_in_guard(F/A, RuleNb) ->
7579 GuardAttachment = Attachment,
7580 BodyAttachment = true
7581 ;
7582 GuardAttachment = true,
7583 BodyAttachment = Attachment % will be true if not observed at all
7584 ),
7586 Clause = (
7587 ClauseHead :-
7588 ( CurrentSuspTest,
7589 DiffSuspGoals,
7590 Matching,
7591 NovelProduction,
7592 GuardAttachment,
7593 GuardCopy,
7594 DebugTry ->
7595 DebugApply,
7596 ExtendHistory,
7597 BodyAttachment,
7598 BodyCopy,
7599 ConditionalRecursiveCall
7600 ; RecursiveCall
7601 )
7602 ),
7603 add_location(Clause,RuleNb,LocatedClause),
7604 L = [LocatedClause|T].
7606 novel_production_calls([],[],[],_,_,true).
7607 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7608 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7609 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7610 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7612 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7613 reverse(ReversedRestSusps,RestSusps),
7614 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7616 named_history_susps([],_,_,[]).
7617 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7618 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7619 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7623 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7624 !,
7625 functor(Head,F,A),
7626 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7627 get_constraint_mode(F/A,Mode),
7628 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7629 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7630 append(VarsSusp,ExtraVars,HeadVars).
7631 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7632 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7633 functor(Head,F,A),
7634 gen_var(Susps),
7635 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7636 get_constraint_mode(F/A,Mode),
7637 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7638 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7639 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7641 % returns
7642 % VarDict for the copies of variables in the original heads
7643 % VarsSuspsList list of lists of arguments for the successive heads
7644 % FirstVarsSusp top level arguments
7645 % SuspList list of all suspensions
7646 % Iterators list of all iterators
7647 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7648 !,
7649 functor(Head,F,A),
7650 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7651 get_constraint_mode(F/A,Mode),
7652 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7653 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7654 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7655 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7656 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7657 functor(Head,F,A),
7658 gen_var(Susps),
7659 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7660 get_constraint_mode(F/A,Mode),
7661 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7662 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7663 append(HeadVars,[Susp,Susps],Vars).
7665 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7666 !,
7667 functor(Head,F,A),
7668 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7669 get_constraint_mode(F/A,Mode),
7670 head_arg_matches(Pairs,Mode,[],_,VarDict),
7671 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7672 append(VarsSusp,ExtraVars,HeadVars).
7673 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7674 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7675 functor(Head,F,A),
7676 gen_var(Susps),
7677 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7678 get_constraint_mode(F/A,Mode),
7679 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7680 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7681 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7683 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7685 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7686 %% ____ _ _ _ _
7687 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7688 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7689 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7690 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7691 %%
7692 %% ____ _ _ _
7693 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7694 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7695 %% | _ < __/ |_| | | | __/\ V / (_| | |
7696 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7697 %%
7698 %% ____ _ _
7699 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7700 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7701 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7702 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7703 %% |___/
7705 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7706 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7707 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7708 ;
7709 NRestHeads = RestHeads,
7710 NRestIDs = RestIDs
7711 ).
7713 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7714 term_variables(Head,Vars),
7715 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7716 copy_term_nat(InitialData,InitialDataCopy),
7717 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7718 InitialDataCopy = InitialData,
7719 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7720 reverse(RNRestHeads,NRestHeads),
7721 reverse(RNRestIDs,NRestIDs).
7723 final_data(Entry) :-
7724 Entry = entry(_,_,_,_,[],_).
7726 expand_data(Entry,NEntry,Cost) :-
7727 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7728 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7729 term_variables([Head1|Vars],Vars1),
7730 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7731 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7733 % Assigns score to head based on known variables and heads to lookup
7734 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7735 functor(Head,F,A),
7736 get_store_type(F/A,StoreType),
7737 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7739 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7740 term_variables(Head,HeadVars),
7741 term_variables(RestHeads,RestVars),
7742 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7743 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7744 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7745 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7746 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7747 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7748 term_variables(Head,HeadVars),
7749 term_variables(RestHeads,RestVars),
7750 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7751 Score is Score_ * 2.
7752 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7753 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7754 Score = 1. % guaranteed O(1)
7756 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7757 find_with_var_identity(
7758 S,
7759 t(Head,KnownVars,RestHeads),
7760 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7761 Scores
7762 ),
7763 min_list(Scores,Score).
7764 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7765 Score = 10.
7766 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7767 Score = 10.
7769 order_score_indexes([],_,_,Score,NScore) :-
7770 Score > 0, NScore = 100.
7771 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7772 multi_hash_key_args(I,Head,Args),
7773 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7774 Score1 is Score + 1
7775 ;
7776 Score1 = Score
7777 ),
7778 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7780 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7781 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7782 ( K-R-O == 0-0-0 ->
7783 Score = 0
7784 ; K > 0 ->
7785 Score is max(10 - K,0)
7786 ; R > 0 ->
7787 Score is max(10 - R,1) * 10
7788 ;
7789 Score is max(10-O,1) * 100
7790 ).
7791 order_score_count_vars([],_,_,0-0-0).
7792 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7793 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7794 ( memberchk_eq(V,KnownVars) ->
7795 NK is K + 1,
7796 NR = R, NO = O
7797 ; memberchk_eq(V,RestVars) ->
7798 NR is R + 1,
7799 NK = K, NO = O
7800 ;
7801 NO is O + 1,
7802 NK = K, NR = R
7803 ).
7805 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7806 %% ___ _ _ _
7807 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
7808 %% | || '_ \| | | '_ \| | '_ \ / _` |
7809 %% | || | | | | | | | | | | | | (_| |
7810 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7811 %% |___/
7813 %% SWI begin
7814 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7815 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7816 %% SWI end
7818 %% SICStus begin
7819 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7820 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7821 %% SICStus end
7823 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7826 %% _ _ _ _ _ _ _
7827 %% | | | | |_(_) (_) |_ _ _
7828 %% | | | | __| | | | __| | | |
7829 %% | |_| | |_| | | | |_| |_| |
7830 %% \___/ \__|_|_|_|\__|\__, |
7831 %% |___/
7833 % Create a fresh variable.
7834 gen_var(_).
7836 % Create =N= fresh variables.
7837 gen_vars(N,Xs) :-
7838 length(Xs,N).
7840 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7841 vars_susp(A,Vars,Susp,VarsSusp),
7842 Head =.. [_|Args],
7843 pairup(Args,Vars,HeadPairs).
7845 inc_id([N|Ns],[O|Ns]) :-
7846 O is N + 1.
7847 dec_id([N|Ns],[M|Ns]) :-
7848 M is N - 1.
7850 extend_id(Id,[0|Id]).
7852 next_id([_,N|Ns],[O|Ns]) :-
7853 O is N + 1.
7855 % return clause Head
7856 % for F/A constraint symbol, predicate identifier Id and arguments Head
7857 build_head(F,A,Id,Args,Head) :-
7858 buildName(F,A,Id,Name),
7859 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
7860 ( may_trigger(F/A) ;
7861 get_allocation_occurrence(F/A,AO),
7862 get_max_occurrence(F/A,MO),
7863 MO >= AO ) ) ->
7864 Head =.. [Name|Args]
7865 ;
7866 init(Args,ArgsWOSusp), % XXX not entirely correct!
7867 Head =.. [Name|ArgsWOSusp]
7868 ).
7870 % return predicate name Result
7871 % for Fct/Aty constraint symbol and predicate identifier List
7872 buildName(Fct,Aty,List,Result) :-
7873 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
7874 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
7875 MO >= AO ) ; List \= [0])) ) ) ->
7876 atom_concat(Fct, '___' ,FctSlash),
7877 atomic_concat(FctSlash,Aty,FctSlashAty),
7878 buildName_(List,FctSlashAty,Result)
7879 ;
7880 Result = Fct
7881 ).
7883 buildName_([],Name,Name).
7884 buildName_([N|Ns],Name,Result) :-
7885 buildName_(Ns,Name,Name1),
7886 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
7887 atomic_concat(NameDash,N,Result).
7889 vars_susp(A,Vars,Susp,VarsSusp) :-
7890 length(Vars,A),
7891 append(Vars,[Susp],VarsSusp).
7893 or_pattern(Pos,Pat) :-
7894 Pow is Pos - 1,
7895 Pat is 1 << Pow. % was 2 ** X
7897 and_pattern(Pos,Pat) :-
7898 X is Pos - 1,
7899 Y is 1 << X, % was 2 ** X
7900 Pat is (-1)*(Y + 1).
7902 make_name(Prefix,F/A,Name) :-
7903 atom_concat_list([Prefix,F,'___',A],Name).
7905 %===============================================================================
7906 % Attribute for attributed variables
7908 make_attr(N,Mask,SuspsList,Attr) :-
7909 length(SuspsList,N),
7910 Attr =.. [v,Mask|SuspsList].
7912 get_all_suspensions2(N,Attr,SuspensionsList) :-
7913 chr_pp_flag(dynattr,off), !,
7914 make_attr(N,_,SuspensionsList,Attr).
7916 % NEW
7917 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
7918 % writeln(get_all_suspensions2),
7919 length(SuspensionsList,N),
7920 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
7923 % NEW
7924 normalize_attr(Attr,NormalGoal,NormalAttr) :-
7925 % writeln(normalize_attr),
7926 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
7928 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
7929 chr_pp_flag(dynattr,off), !,
7930 make_attr(N,_,SuspsList,Attr),
7931 nth1(Position,SuspsList,Suspensions).
7933 % NEW
7934 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
7935 % writeln(get_suspensions),
7936 Goal =
7937 ( memberchk(Position-Suspensions,TAttr) ->
7938 true
7939 ;
7940 Suspensions = []
7941 ).
7943 %-------------------------------------------------------------------------------
7944 % +N: number of constraint symbols
7945 % +Suspension: source-level variable, for suspension
7946 % +Position: constraint symbol number
7947 % -Attr: source-level term, for new attribute
7948 singleton_attr(N,Suspension,Position,Attr) :-
7949 chr_pp_flag(dynattr,off), !,
7950 or_pattern(Position,Pattern),
7951 make_attr(N,Pattern,SuspsList,Attr),
7952 nth1(Position,SuspsList,[Suspension]),
7953 chr_delete(SuspsList,[Suspension],RestSuspsList),
7954 set_elems(RestSuspsList,[]).
7956 % NEW
7957 singleton_attr(N,Suspension,Position,Attr) :-
7958 % writeln(singleton_attr),
7959 Attr = [Position-[Suspension]].
7961 %-------------------------------------------------------------------------------
7962 % +N: number of constraint symbols
7963 % +Suspension: source-level variable, for suspension
7964 % +Position: constraint symbol number
7965 % +TAttr: source-level variable, for old attribute
7966 % -Goal: goal for creating new attribute
7967 % -NTAttr: source-level variable, for new attribute
7968 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7969 chr_pp_flag(dynattr,off), !,
7970 make_attr(N,Mask,SuspsList,Attr),
7971 or_pattern(Position,Pattern),
7972 nth1(Position,SuspsList,Susps),
7973 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
7974 make_attr(N,Mask,SuspsList1,NewAttr1),
7975 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
7976 make_attr(N,NewMask,SuspsList2,NewAttr2),
7977 Goal = (
7978 TAttr = Attr,
7979 ( Mask /\ Pattern =:= Pattern ->
7980 NTAttr = NewAttr1
7981 ;
7982 NewMask is Mask \/ Pattern,
7983 NTAttr = NewAttr2
7984 )
7985 ), !.
7987 % NEW
7988 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7989 % writeln(add_attr),
7990 Goal =
7991 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
7992 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
7993 ;
7994 NTAttr = [Position-[Suspension]|TAttr]
7995 ).
7997 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
7998 chr_pp_flag(dynattr,off), !,
7999 or_pattern(Position,Pattern),
8000 and_pattern(Position,DelPattern),
8001 make_attr(N,Mask,SuspsList,Attr),
8002 nth1(Position,SuspsList,Susps),
8003 substitute_eq(Susps,SuspsList,[],SuspsList1),
8004 make_attr(N,NewMask,SuspsList1,Attr1),
8005 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8006 make_attr(N,Mask,SuspsList2,Attr2),
8007 get_target_module(Mod),
8008 Goal = (
8009 TAttr = Attr,
8010 ( Mask /\ Pattern =:= Pattern ->
8011 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8012 ( NewSusps == [] ->
8013 NewMask is Mask /\ DelPattern,
8014 ( NewMask == 0 ->
8015 del_attr(Var,Mod)
8016 ;
8017 put_attr(Var,Mod,Attr1)
8018 )
8019 ;
8020 put_attr(Var,Mod,Attr2)
8021 )
8022 ;
8023 true
8024 )
8025 ), !.
8027 % NEW
8028 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8029 % writeln(rem_attr),
8030 get_target_module(Mod),
8031 Goal =
8032 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8033 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8034 ( NSuspensions == [] ->
8035 ( RAttr == [] ->
8036 del_attr(Var,Mod)
8037 ;
8038 put_attr(Var,Mod,RAttr)
8039 )
8040 ;
8041 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8042 )
8043 ;
8044 true
8045 ).
8047 %-------------------------------------------------------------------------------
8048 % +N: number of constraint symbols
8049 % +TAttr1: source-level variable, for attribute
8050 % +TAttr2: source-level variable, for other attribute
8051 % -Goal: goal for merging the two attributes
8052 % -Attr: source-level term, for merged attribute
8053 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8054 chr_pp_flag(dynattr,off), !,
8055 make_attr(N,Mask1,SuspsList1,Attr1),
8056 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8057 Goal = (
8058 TAttr1 = Attr1,
8059 Goal2
8060 ).
8062 % NEW
8063 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8064 % writeln(merge_attributes),
8065 Goal = (
8066 sort(TAttr1,Sorted1),
8067 sort(TAttr2,Sorted2),
8068 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8069 ).
8072 %-------------------------------------------------------------------------------
8073 % +N: number of constraint symbols
8074 % +Mask1: ...
8075 % +SuspsList1: static term, for suspensions list
8076 % +TAttr2: source-level variable, for other attribute
8077 % -Goal: goal for merging the two attributes
8078 % -Attr: source-level term, for merged attribute
8079 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8080 make_attr(N,Mask2,SuspsList2,Attr2),
8081 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8082 list2conj(Gs,SortGoals),
8083 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8084 make_attr(N,Mask,SuspsList,Attr),
8085 Goal = (
8086 TAttr2 = Attr2,
8087 SortGoals,
8088 Mask is Mask1 \/ Mask2
8089 ).
8092 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8093 % Storetype dependent lookup
8095 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8096 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8097 %% -Goal,-SuspensionList) is det.
8098 %
8099 % Create a universal lookup goal for given head.
8100 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8101 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8102 functor(Head,F,A),
8103 get_store_type(F/A,StoreType),
8104 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8106 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8107 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8108 %% -Goal,-SuspensionList) is det.
8109 %
8110 % Create a universal lookup goal for given head.
8111 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8112 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8113 functor(Head,F,A),
8114 get_store_type(F/A,StoreType),
8115 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8117 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8118 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8119 %% +GroundVars,-Goal,-SuspensionList) is det.
8120 %
8121 % Create a universal lookup goal for given head.
8122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8123 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8124 functor(Head,F,A),
8125 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8126 update_store_type(F/A,default).
8127 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8128 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8129 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8130 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8131 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8132 functor(Head,F,A),
8133 global_ground_store_name(F/A,StoreName),
8134 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8135 update_store_type(F/A,global_ground).
8136 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8137 arg(VarIndex,Head,OVar),
8138 arg(KeyIndex,Head,OKey),
8139 translate([OVar,OKey],VarDict,[Var,Key]),
8140 get_target_module(Module),
8141 Goal = (
8142 get_attr(Var,Module,AssocStore),
8143 lookup_assoc_store(AssocStore,Key,AllSusps)
8144 ).
8145 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8146 functor(Head,F,A),
8147 global_singleton_store_name(F/A,StoreName),
8148 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8149 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8150 update_store_type(F/A,global_singleton).
8151 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8152 once((
8153 member(ST,StoreTypes),
8154 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8155 )).
8156 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8157 functor(Head,F,A),
8158 arg(Index,Head,Var),
8159 translate([Var],VarDict,[KeyVar]),
8160 delay_phase_end(validate_store_type_assumptions,
8161 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8162 ),
8163 update_store_type(F/A,identifier_store(Index)),
8164 get_identifier_index(F/A,Index,_).
8165 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8166 functor(Head,F,A),
8167 arg(Index,Head,Var),
8168 ( var(Var) ->
8169 translate([Var],VarDict,[KeyVar]),
8170 Goal = StructGoal
8171 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8172 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8173 Goal = (LookupGoal,StructGoal)
8174 ),
8175 delay_phase_end(validate_store_type_assumptions,
8176 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8177 ),
8178 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8179 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8181 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8182 get_identifier_size(ISize),
8183 functor(Struct,struct,ISize),
8184 get_identifier_index(C,Index,IIndex),
8185 arg(IIndex,Struct,AllSusps),
8186 Goal = (KeyVar = Struct).
8188 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8189 type_indexed_identifier_structure(IndexType,Struct),
8190 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8191 arg(IIndex,Struct,AllSusps),
8192 Goal = (KeyVar = Struct).
8194 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8195 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8196 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8197 %
8198 % Create a universal hash lookup goal for given head.
8199 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8200 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8201 once((
8202 member(Index,Indexes),
8203 multi_hash_key_args(Index,Head,KeyArgs),
8204 (
8205 translate(KeyArgs,VarDict,KeyArgCopies)
8206 ;
8207 ground(KeyArgs), KeyArgCopies = KeyArgs
8208 )
8209 )),
8210 ( KeyArgCopies = [KeyCopy] ->
8211 true
8212 ;
8213 KeyCopy =.. [k|KeyArgCopies]
8214 ),
8215 functor(Head,F,A),
8216 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8218 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8219 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8221 Goal = (GroundCheck,LookupGoal),
8223 ( HashType == inthash ->
8224 update_store_type(F/A,multi_inthash([Index]))
8225 ;
8226 update_store_type(F/A,multi_hash([Index]))
8227 ).
8229 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8230 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8231 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8232 %% +VarArgDict,-NewVarArgDict) is det.
8233 %
8234 % Create existential lookup goal for given head.
8235 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8236 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8237 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8238 sbag_member_call(Susp,AllSusps,Sbag),
8239 functor(Head,F,A),
8240 delay_phase_end(validate_store_type_assumptions,
8241 ( static_suspension_term(F/A,SuspTerm),
8242 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8243 )
8244 ),
8245 Goal = (
8246 UniversalGoal,
8247 Sbag,
8248 Susp = SuspTerm,
8249 GetState
8250 ).
8251 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8252 functor(Head,F,A),
8253 global_singleton_store_name(F/A,StoreName),
8254 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8255 Goal = (
8256 GetStoreGoal, % nb_getval(StoreName,Susp),
8257 Susp \== [],
8258 Susp = SuspTerm
8259 ),
8260 update_store_type(F/A,global_singleton).
8261 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8262 once((
8263 member(ST,StoreTypes),
8264 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8265 )).
8266 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8267 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8268 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8269 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8270 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8271 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8272 hash_index_filter(Pairs,Index,NPairs),
8274 functor(Head,F,A),
8275 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8276 Sbag = (AllSusps = [Susp])
8277 ;
8278 sbag_member_call(Susp,AllSusps,Sbag)
8279 ),
8280 delay_phase_end(validate_store_type_assumptions,
8281 ( static_suspension_term(F/A,SuspTerm),
8282 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8283 )
8284 ),
8285 Goal = (
8286 LookupGoal,
8287 Sbag,
8288 Susp = SuspTerm, % not inlined
8289 GetState
8290 ).
8291 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8292 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8293 hash_index_filter(Pairs,Index,NPairs),
8295 functor(Head,F,A),
8296 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8297 Sbag = (AllSusps = [Susp])
8298 ;
8299 sbag_member_call(Susp,AllSusps,Sbag)
8300 ),
8301 delay_phase_end(validate_store_type_assumptions,
8302 ( static_suspension_term(F/A,SuspTerm),
8303 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8304 )
8305 ),
8306 Goal = (
8307 LookupGoal,
8308 Sbag,
8309 Susp = SuspTerm, % not inlined
8310 GetState
8311 ).
8312 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8313 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8314 sbag_member_call(Susp,Susps,Sbag),
8315 functor(Head,F,A),
8316 delay_phase_end(validate_store_type_assumptions,
8317 ( static_suspension_term(F/A,SuspTerm),
8318 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8319 )
8320 ),
8321 Goal = (
8322 UGoal,
8323 Sbag,
8324 Susp = SuspTerm, % not inlined
8325 GetState
8326 ).
8328 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8329 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8330 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8331 %% +VarArgDict,-NewVarArgDict) is det.
8332 %
8333 % Create existential hash lookup goal for given head.
8334 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8335 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8336 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8338 hash_index_filter(Pairs,Index,NPairs),
8340 functor(Head,F,A),
8341 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8342 Sbag = (AllSusps = [Susp])
8343 ;
8344 sbag_member_call(Susp,AllSusps,Sbag)
8345 ),
8346 delay_phase_end(validate_store_type_assumptions,
8347 ( static_suspension_term(F/A,SuspTerm),
8348 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8349 )
8350 ),
8351 Goal = (
8352 LookupGoal,
8353 Sbag,
8354 Susp = SuspTerm, % not inlined
8355 GetState
8356 ).
8358 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8359 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8360 %
8361 % Filter out pairs already covered by given hash index.
8362 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8363 hash_index_filter(Pairs,Index,NPairs) :-
8364 ( integer(Index) ->
8365 NIndex = [Index]
8366 ;
8367 NIndex = Index
8368 ),
8369 hash_index_filter(Pairs,NIndex,1,NPairs).
8371 hash_index_filter([],_,_,[]).
8372 hash_index_filter([P|Ps],Index,N,NPairs) :-
8373 ( Index = [I|Is] ->
8374 NN is N + 1,
8375 ( I > N ->
8376 NPairs = [P|NPs],
8377 hash_index_filter(Ps,[I|Is],NN,NPs)
8378 ; I == N ->
8379 hash_index_filter(Ps,Is,NN,NPairs)
8380 )
8381 ;
8382 NPairs = [P|Ps]
8383 ).
8385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8386 %------------------------------------------------------------------------------%
8387 %% assume_constraint_stores(+ConstraintSymbols) is det.
8388 %
8389 % Compute all constraint store types that are possible for the given
8390 % =ConstraintSymbols=.
8391 %------------------------------------------------------------------------------%
8392 assume_constraint_stores([]).
8393 assume_constraint_stores([C|Cs]) :-
8394 ( chr_pp_flag(debugable,off),
8395 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8396 is_stored(C),
8397 get_store_type(C,default) ->
8398 get_indexed_arguments(C,AllIndexedArgs),
8399 get_constraint_mode(C,Modes),
8400 findall(Index,(member(Index,AllIndexedArgs),
8401 nth(Index,Modes,+)),IndexedArgs),
8402 length(IndexedArgs,NbIndexedArgs),
8403 % Construct Index Combinations
8404 ( NbIndexedArgs > 10 ->
8405 findall([Index],member(Index,IndexedArgs),Indexes)
8406 ;
8407 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8408 predsort(longer_list,UnsortedIndexes,Indexes)
8409 ),
8410 % Choose Index Type
8411 ( get_functional_dependency(C,1,Pattern,Key),
8412 all_distinct_var_args(Pattern), Key == [] ->
8413 assumed_store_type(C,global_singleton)
8414 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8415 get_constraint_type_det(C,ArgTypes),
8416 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8418 ( IntHashIndexes = [] ->
8419 Stores = Stores1
8420 ;
8421 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8422 ),
8423 ( HashIndexes = [] ->
8424 Stores1 = Stores2
8425 ;
8426 Stores1 = [multi_hash(HashIndexes)|Stores2]
8427 ),
8428 ( IdentifierIndexes = [] ->
8429 Stores2 = Stores3
8430 ;
8431 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8432 append(WrappedIdentifierIndexes,Stores3,Stores2)
8433 ),
8434 append(CompoundIdentifierIndexes,Stores4,Stores3),
8435 ( only_ground_indexed_arguments(C)
8436 -> Stores4 = [global_ground]
8437 ; Stores4 = [default]
8438 ),
8439 assumed_store_type(C,multi_store(Stores))
8440 ; true
8441 )
8442 ;
8443 true
8444 ),
8445 assume_constraint_stores(Cs).
8447 %------------------------------------------------------------------------------%
8448 %% partition_indexes(+Indexes,+Types,
8449 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8450 %------------------------------------------------------------------------------%
8451 partition_indexes([],_,[],[],[],[]).
8452 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8453 ( Index = [I],
8454 nth(I,Types,Type),
8455 unalias_type(Type,UnAliasedType),
8456 UnAliasedType == chr_identifier ->
8457 IdentifierIndexes = [I|RIdentifierIndexes],
8458 IntHashIndexes = RIntHashIndexes,
8459 HashIndexes = RHashIndexes,
8460 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8461 ; Index = [I],
8462 nth(I,Types,Type),
8463 unalias_type(Type,UnAliasedType),
8464 nonvar(UnAliasedType),
8465 UnAliasedType = chr_identifier(IndexType) ->
8466 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8467 IdentifierIndexes = RIdentifierIndexes,
8468 IntHashIndexes = RIntHashIndexes,
8469 HashIndexes = RHashIndexes
8470 ; Index = [I],
8471 nth(I,Types,Type),
8472 unalias_type(Type,UnAliasedType),
8473 UnAliasedType == dense_int ->
8474 IntHashIndexes = [Index|RIntHashIndexes],
8475 HashIndexes = RHashIndexes,
8476 IdentifierIndexes = RIdentifierIndexes,
8477 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8478 ; member(I,Index),
8479 nth(I,Types,Type),
8480 unalias_type(Type,UnAliasedType),
8481 nonvar(UnAliasedType),
8482 UnAliasedType = chr_identifier(_) ->
8483 % don't use chr_identifiers in hash indexes
8484 IntHashIndexes = RIntHashIndexes,
8485 HashIndexes = RHashIndexes,
8486 IdentifierIndexes = RIdentifierIndexes,
8487 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8488 ;
8489 IntHashIndexes = RIntHashIndexes,
8490 HashIndexes = [Index|RHashIndexes],
8491 IdentifierIndexes = RIdentifierIndexes,
8492 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8493 ),
8494 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8496 longer_list(R,L1,L2) :-
8497 length(L1,N1),
8498 length(L2,N2),
8499 compare(Rt,N2,N1),
8500 ( Rt == (=) ->
8501 compare(R,L1,L2)
8502 ;
8503 R = Rt
8504 ).
8506 all_distinct_var_args(Term) :-
8507 Term =.. [_|Args],
8508 copy_term_nat(Args,NArgs),
8509 all_distinct_var_args_(NArgs).
8511 all_distinct_var_args_([]).
8512 all_distinct_var_args_([X|Xs]) :-
8513 var(X),
8514 X = t,
8515 all_distinct_var_args_(Xs).
8517 get_indexed_arguments(C,IndexedArgs) :-
8518 C = F/A,
8519 get_indexed_arguments(1,A,C,IndexedArgs).
8521 get_indexed_arguments(I,N,C,L) :-
8522 ( I > N ->
8523 L = []
8524 ; ( is_indexed_argument(C,I) ->
8525 L = [I|T]
8526 ;
8527 L = T
8528 ),
8529 J is I + 1,
8530 get_indexed_arguments(J,N,C,T)
8531 ).
8533 validate_store_type_assumptions([]).
8534 validate_store_type_assumptions([C|Cs]) :-
8535 validate_store_type_assumption(C),
8536 validate_store_type_assumptions(Cs).
8538 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8539 % new code generation
8540 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
8541 Rule = rule(H1,_,Guard,Body),
8542 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8543 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8544 flatten(VarsAndSuspsList,VarsAndSusps),
8545 Vars = [ [] | VarsAndSusps],
8546 build_head(F,A,Id,Vars,Head),
8547 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8548 Clause = ( Head :- PredecessorCall),
8549 add_dummy_location(Clause,LocatedClause),
8550 L = [LocatedClause | T].
8551 % ( H1 == [],
8552 % functor(CurrentHead,CF,CA),
8553 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8554 % L = T
8555 % ;
8556 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8557 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8558 % flatten(VarsAndSuspsList,VarsAndSusps),
8559 % Vars = [ [] | VarsAndSusps],
8560 % build_head(F,A,Id,Vars,Head),
8561 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8562 % Clause = ( Head :- PredecessorCall),
8563 % L = [Clause | T]
8564 % ).
8566 % skips back intelligently over global_singleton lookups
8567 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8568 ( Id = [0|_] ->
8569 next_id(Id,PrevId),
8570 PrevVarsAndSusps = BaseCallArgs
8571 ;
8572 VarsAndSuspsList = [_|AllButFirstList],
8573 dec_id(Id,PrevId1),
8574 ( PrevHeads = [PrevHead|PrevHeads1],
8575 functor(PrevHead,F,A),
8576 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8577 PrevIterators = [_|PrevIterators1],
8578 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8579 ;
8580 PrevId = PrevId1,
8581 flatten(AllButFirstList,AllButFirst),
8582 PrevIterators = [PrevIterator|_],
8583 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8584 )
8585 ).
8587 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
8588 Rule = rule(_,_,Guard,Body),
8589 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8590 init(AllSusps,PreSusps),
8591 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8592 gen_var(OtherSusps),
8593 functor(CurrentHead,OtherF,OtherA),
8594 gen_vars(OtherA,OtherVars),
8595 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8596 get_constraint_mode(OtherF/OtherA,Mode),
8597 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8599 delay_phase_end(validate_store_type_assumptions,
8600 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8601 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8602 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8603 )
8604 ),
8606 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8607 % create_get_mutable_ref(active,State,GetMutable),
8608 CurrentSuspTest = (
8609 OtherSusp = OtherSuspension,
8610 GetState,
8611 DiffSuspGoals,
8612 FirstMatching
8613 ),
8614 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8615 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8616 inc_id(Id,NestedId),
8617 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8618 build_head(F,A,Id,ClauseVars,ClauseHead),
8619 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8620 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8621 build_head(F,A,NestedId,NestedVars,NestedHead),
8623 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8624 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
8625 RecursiveVars = PreVarsAndSusps1
8626 ;
8627 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8628 PrevId = Id
8629 ),
8630 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8632 Clause = (
8633 ClauseHead :-
8634 ( CurrentSuspTest,
8635 NextSuspGoal
8636 ->
8637 NestedHead
8638 ; RecursiveHead
8639 )
8640 ),
8641 add_dummy_location(Clause,LocatedClause),
8642 L = [LocatedClause|T].
8644 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8646 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8647 % Observation Analysis
8648 %
8649 % CLASSIFICATION
8650 % Enabled
8651 %
8652 % Analysis based on Abstract Interpretation paper.
8653 %
8654 % TODO:
8655 % stronger analysis domain [research]
8657 :- chr_constraint
8658 initial_call_pattern/1,
8659 call_pattern/1,
8660 call_pattern_worker/1,
8661 final_answer_pattern/2,
8662 abstract_constraints/1,
8663 depends_on/2,
8664 depends_on_ap/4,
8665 depends_on_goal/2,
8666 ai_observed_internal/2,
8667 % ai_observed/2,
8668 ai_not_observed_internal/2,
8669 ai_not_observed/2,
8670 ai_is_observed/2,
8671 depends_on_as/3,
8672 ai_observation_gather_results/0.
8674 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8675 :- chr_type program_point == any.
8677 :- chr_option(mode,initial_call_pattern(+)).
8678 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8680 :- chr_option(mode,call_pattern(+)).
8681 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8683 :- chr_option(mode,call_pattern_worker(+)).
8684 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8686 :- chr_option(mode,final_answer_pattern(+,+)).
8687 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8689 :- chr_option(mode,abstract_constraints(+)).
8690 :- chr_option(type_declaration,abstract_constraints(list)).
8692 :- chr_option(mode,depends_on(+,+)).
8693 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8695 :- chr_option(mode,depends_on_as(+,+,+)).
8696 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8697 :- chr_option(mode,depends_on_goal(+,+)).
8698 :- chr_option(mode,ai_is_observed(+,+)).
8699 :- chr_option(mode,ai_not_observed(+,+)).
8700 % :- chr_option(mode,ai_observed(+,+)).
8701 :- chr_option(mode,ai_not_observed_internal(+,+)).
8702 :- chr_option(mode,ai_observed_internal(+,+)).
8705 abstract_constraints_fd @
8706 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8708 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8709 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8710 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8712 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8713 ai_is_observed(_,_) <=> true.
8715 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8716 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8717 ai_observation_gather_results <=> true.
8719 %------------------------------------------------------------------------------%
8720 % Main Analysis Entry
8721 %------------------------------------------------------------------------------%
8722 ai_observation_analysis(ACs) :-
8723 ( chr_pp_flag(ai_observation_analysis,on),
8724 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8725 list_to_ord_set(ACs,ACSet),
8726 abstract_constraints(ACSet),
8727 ai_observation_schedule_initial_calls(ACSet,ACSet),
8728 ai_observation_gather_results
8729 ;
8730 true
8731 ).
8733 ai_observation_schedule_initial_calls([],_).
8734 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8735 ai_observation_schedule_initial_call(AC,ACs),
8736 ai_observation_schedule_initial_calls(RACs,ACs).
8738 ai_observation_schedule_initial_call(AC,ACs) :-
8739 ai_observation_top(AC,CallPattern),
8740 % ai_observation_bot(AC,ACs,CallPattern),
8741 initial_call_pattern(CallPattern).
8743 ai_observation_schedule_new_calls([],AP).
8744 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8745 AP = odom(_,Set),
8746 initial_call_pattern(odom(AC,Set)),
8747 ai_observation_schedule_new_calls(ACs,AP).
8749 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8750 <=>
8751 ai_observation_leq(AP2,AP1)
8752 |
8753 true.
8755 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
8757 initial_call_pattern(CP) ==> call_pattern(CP).
8759 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
8760 ==>
8761 ai_observation_schedule_new_calls(ACs,AP)
8762 pragma
8763 passive(ID3).
8765 call_pattern(CP) \ call_pattern(CP) <=> true.
8767 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
8768 final_answer_pattern(CP1,AP).
8770 %call_pattern(CP) ==> writeln(call_pattern(CP)).
8772 call_pattern(CP) ==> call_pattern_worker(CP).
8774 %------------------------------------------------------------------------------%
8775 % Abstract Goal
8776 %------------------------------------------------------------------------------%
8778 % AbstractGoala
8779 %call_pattern(odom([],Set)) ==>
8780 % final_answer_pattern(odom([],Set),odom([],Set)).
8782 call_pattern_worker(odom([],Set)) <=>
8783 % writeln(' - AbstractGoal'(odom([],Set))),
8784 final_answer_pattern(odom([],Set),odom([],Set)).
8786 % AbstractGoalb
8787 call_pattern_worker(odom([G|Gs],Set)) <=>
8788 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
8789 CP1 = odom(G,Set),
8790 depends_on_goal(odom([G|Gs],Set),CP1),
8791 call_pattern(CP1).
8793 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
8794 <=> true pragma passive(ID).
8795 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
8796 ==>
8797 CP1 = odom([_|Gs],_),
8798 AP2 = odom([],Set),
8799 CCP = odom(Gs,Set),
8800 call_pattern(CCP),
8801 depends_on(CP1,CCP).
8803 %------------------------------------------------------------------------------%
8804 % Abstract Disjunction
8805 %------------------------------------------------------------------------------%
8807 call_pattern_worker(odom((AG1;AG2),Set)) <=>
8808 CP = odom((AG1;AG2),Set),
8809 InitialAnswerApproximation = odom([],Set),
8810 final_answer_pattern(CP,InitialAnswerApproximation),
8811 CP1 = odom(AG1,Set),
8812 CP2 = odom(AG2,Set),
8813 call_pattern(CP1),
8814 call_pattern(CP2),
8815 depends_on_as(CP,CP1,CP2).
8817 %------------------------------------------------------------------------------%
8818 % Abstract Solve
8819 %------------------------------------------------------------------------------%
8820 call_pattern_worker(odom(builtin,Set)) <=>
8821 % writeln(' - AbstractSolve'(odom(builtin,Set))),
8822 ord_empty(EmptySet),
8823 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
8825 %------------------------------------------------------------------------------%
8826 % Abstract Drop
8827 %------------------------------------------------------------------------------%
8828 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8829 <=>
8830 O > MO
8831 |
8832 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
8833 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8834 pragma
8835 passive(ID2).
8837 %------------------------------------------------------------------------------%
8838 % Abstract Activate
8839 %------------------------------------------------------------------------------%
8840 call_pattern_worker(odom(AC,Set))
8841 <=>
8842 AC = _ / _
8843 |
8844 % writeln(' - AbstractActivate'(odom(AC,Set))),
8845 CP = odom(occ(AC,1),Set),
8846 call_pattern(CP),
8847 depends_on(odom(AC,Set),CP).
8849 %------------------------------------------------------------------------------%
8850 % Abstract Passive
8851 %------------------------------------------------------------------------------%
8852 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8853 <=>
8854 is_passive(RuleNb,ID)
8855 |
8856 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8857 % DEFAULT
8858 NO is O + 1,
8859 DCP = odom(occ(C,NO),Set),
8860 call_pattern(DCP),
8861 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
8862 depends_on(odom(occ(C,O),Set),DCP)
8863 pragma
8864 passive(ID2).
8865 %------------------------------------------------------------------------------%
8866 % Abstract Simplify
8867 %------------------------------------------------------------------------------%
8869 % AbstractSimplify
8870 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8871 <=>
8872 \+ is_passive(RuleNb,ID)
8873 |
8874 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8875 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
8876 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
8877 ai_observation_memo_abstract_goal(RuleNb,AG),
8878 call_pattern(odom(AG,Set2)),
8879 % DEFAULT
8880 NO is O + 1,
8881 DCP = odom(occ(C,NO),Set),
8882 call_pattern(DCP),
8883 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
8884 % DEADLOCK AVOIDANCE
8885 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8886 pragma
8887 passive(ID2).
8889 depends_on_as(CP,CPS,CPD),
8890 final_answer_pattern(CPS,APS),
8891 final_answer_pattern(CPD,APD) ==>
8892 ai_observation_lub(APS,APD,AP),
8893 final_answer_pattern(CP,AP).
8896 :- chr_constraint
8897 ai_observation_memo_simplification_rest_heads/3,
8898 ai_observation_memoed_simplification_rest_heads/3.
8900 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
8901 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
8903 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8904 <=>
8905 QRH = RH.
8906 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8907 <=>
8908 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
8909 once(select2(ID,_,IDs1,H1,_,RestH1)),
8910 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
8911 ai_observation_abstract_constraints(H2,ACs,AH2),
8912 append(ARestHeads,AH2,AbstractHeads),
8913 sort(AbstractHeads,QRH),
8914 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
8915 pragma
8916 passive(ID1),
8917 passive(ID2),
8918 passive(ID3).
8920 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
8922 %------------------------------------------------------------------------------%
8923 % Abstract Propagate
8924 %------------------------------------------------------------------------------%
8927 % AbstractPropagate
8928 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8929 <=>
8930 \+ is_passive(RuleNb,ID)
8931 |
8932 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
8933 % observe partners
8934 ai_observation_memo_propagation_rest_heads(C,O,AHs),
8935 ai_observation_observe_set(Set,AHs,Set2),
8936 ord_add_element(Set2,C,Set3),
8937 ai_observation_memo_abstract_goal(RuleNb,AG),
8938 call_pattern(odom(AG,Set3)),
8939 ( ord_memberchk(C,Set2) ->
8940 Delete = no
8941 ;
8942 Delete = yes
8943 ),
8944 % DEFAULT
8945 NO is O + 1,
8946 DCP = odom(occ(C,NO),Set),
8947 call_pattern(DCP),
8948 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
8949 pragma
8950 passive(ID2).
8952 :- chr_constraint
8953 ai_observation_memo_propagation_rest_heads/3,
8954 ai_observation_memoed_propagation_rest_heads/3.
8956 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
8957 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
8959 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8960 <=>
8961 QRH = RH.
8962 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8963 <=>
8964 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
8965 once(select2(ID,_,IDs2,H2,_,RestH2)),
8966 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
8967 ai_observation_abstract_constraints(H1,ACs,AH1),
8968 append(ARestHeads,AH1,AbstractHeads),
8969 sort(AbstractHeads,QRH),
8970 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
8971 pragma
8972 passive(ID1),
8973 passive(ID2),
8974 passive(ID3).
8976 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
8978 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
8979 final_answer_pattern(CP,APD).
8980 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
8981 final_answer_pattern(CPD,APD) ==>
8982 true |
8983 CP = odom(occ(C,O),_),
8984 ( ai_observation_is_observed(APP,C) ->
8985 ai_observed_internal(C,O)
8986 ;
8987 ai_not_observed_internal(C,O)
8988 ),
8989 ( Delete == yes ->
8990 APP = odom([],Set0),
8991 ord_del_element(Set0,C,Set),
8992 NAPP = odom([],Set)
8993 ;
8994 NAPP = APP
8995 ),
8996 ai_observation_lub(NAPP,APD,AP),
8997 final_answer_pattern(CP,AP).
8999 %------------------------------------------------------------------------------%
9000 % Catch All
9001 %------------------------------------------------------------------------------%
9003 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9005 %------------------------------------------------------------------------------%
9006 % Auxiliary Predicates
9007 %------------------------------------------------------------------------------%
9009 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9010 ord_intersection(S1,S2,S3).
9012 ai_observation_bot(AG,AS,odom(AG,AS)).
9014 ai_observation_top(AG,odom(AG,EmptyS)) :-
9015 ord_empty(EmptyS).
9017 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9018 ord_subset(S2,S1).
9020 ai_observation_observe_set(S,ACSet,NS) :-
9021 ord_subtract(S,ACSet,NS).
9023 ai_observation_abstract_constraint(C,ACs,AC) :-
9024 functor(C,F,A),
9025 AC = F/A,
9026 memberchk(AC,ACs).
9028 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9029 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9031 %------------------------------------------------------------------------------%
9032 % Abstraction of Rule Bodies
9033 %------------------------------------------------------------------------------%
9035 :- chr_constraint
9036 ai_observation_memoed_abstract_goal/2,
9037 ai_observation_memo_abstract_goal/2.
9039 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9040 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9042 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9043 <=>
9044 QAG = AG
9045 pragma
9046 passive(ID1).
9048 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9049 <=>
9050 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9051 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9052 QAG = AG,
9053 ai_observation_memoed_abstract_goal(RuleNb,AG)
9054 pragma
9055 passive(ID1),
9056 passive(ID2).
9058 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9059 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9060 term_variables((H1,H2,Guard),HVars),
9061 append(H1,H2,Heads),
9062 % variables that are declared to be ground are safe,
9063 ground_vars(Heads,GroundVars),
9064 % so we remove them from the list of 'dangerous' head variables
9065 list_difference_eq(HVars,GroundVars,HV),
9066 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9067 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9068 % HV are 'dangerous' variables, all others are fresh and safe
9070 ground_vars([],[]).
9071 ground_vars([H|Hs],GroundVars) :-
9072 functor(H,F,A),
9073 get_constraint_mode(F/A,Mode),
9074 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9075 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9076 ground_vars(Hs,GroundVars2),
9077 append(GroundVars1,GroundVars2,GroundVars).
9079 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9080 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9081 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9082 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9083 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9084 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9085 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9086 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9087 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9088 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9089 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9090 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9091 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9092 % non-CHR constraint is safe if it only binds fresh variables
9093 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9094 builtin_binds_b(G,Vars),
9095 intersect_eq(Vars,HV,[]),
9096 !.
9097 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9098 AG = builtin. % default case if goal is not recognized/safe
9100 ai_observation_is_observed(odom(_,ACSet),AC) :-
9101 \+ ord_memberchk(AC,ACSet).
9103 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9104 unconditional_occurrence(C,O) :-
9105 get_occurrence(C,O,RuleNb,ID),
9106 get_rule(RuleNb,PRule),
9107 PRule = pragma(ORule,_,_,_,_),
9108 copy_term_nat(ORule,Rule),
9109 Rule = rule(H1,H2,Guard,_),
9110 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9111 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9112 once((
9113 H1 = [Head], H2 == []
9114 ;
9115 H2 = [Head], H1 == [], \+ may_trigger(C)
9116 )),
9117 functor(Head,F,A),
9118 Head =.. [_|Args],
9119 unconditional_occurrence_args(Args).
9121 unconditional_occurrence_args([]).
9122 unconditional_occurrence_args([X|Xs]) :-
9123 var(X),
9124 X = x,
9125 unconditional_occurrence_args(Xs).
9127 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9129 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9130 % Partial wake analysis
9131 %
9132 % In a Var = Var unification do not wake up constraints of both variables,
9133 % but rather only those of one variable.
9134 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9136 :- chr_constraint partial_wake_analysis/0.
9137 :- chr_constraint no_partial_wake/1.
9138 :- chr_option(mode,no_partial_wake(+)).
9139 :- chr_constraint wakes_partially/1.
9140 :- chr_option(mode,wakes_partially(+)).
9142 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9143 ==>
9144 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9145 ( is_passive(RuleNb,ID) ->
9146 true
9147 ; Type == simplification ->
9148 select(H,H1,RestH1),
9149 H =.. [_|Args],
9150 term_variables(Guard,Vars),
9151 partial_wake_args(Args,ArgModes,Vars,FA)
9152 ; % Type == propagation ->
9153 select(H,H2,RestH2),
9154 H =.. [_|Args],
9155 term_variables(Guard,Vars),
9156 partial_wake_args(Args,ArgModes,Vars,FA)
9157 ).
9159 partial_wake_args([],_,_,_).
9160 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9161 ( Mode \== (+) ->
9162 ( nonvar(Arg) ->
9163 no_partial_wake(C)
9164 ; memberchk_eq(Arg,Vars) ->
9165 no_partial_wake(C)
9166 ;
9167 true
9168 )
9169 ;
9170 true
9171 ),
9172 partial_wake_args(Args,Modes,Vars,C).
9174 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9176 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9178 wakes_partially(C) <=> true.
9181 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9182 % Generate rules that implement chr_show_store/1 functionality.
9183 %
9184 % CLASSIFICATION
9185 % Experimental
9186 % Unused
9187 %
9188 % Generates additional rules:
9189 %
9190 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9191 % ...
9192 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9193 % $show <=> true.
9195 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9196 ( chr_pp_flag(show,on) ->
9197 Constraints = ['$show'/0|Constraints0],
9198 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9199 inc_rule_count(RuleNb),
9200 Rule = pragma(
9201 rule(['$show'],[],true,true),
9202 ids([0],[]),
9203 [],
9204 no,
9205 RuleNb
9206 )
9207 ;
9208 Constraints = Constraints0,
9209 Rules = Rules0
9210 ).
9212 generate_show_rules([],Rules,Rules).
9213 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9214 functor(C,F,A),
9215 inc_rule_count(RuleNb),
9216 Rule = pragma(
9217 rule([],['$show',C],true,writeln(C)),
9218 ids([],[0,1]),
9219 [passive(1)],
9220 no,
9221 RuleNb
9222 ),
9223 generate_show_rules(Rest,Tail,Rules).
9225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9226 % Custom supension term layout
9228 static_suspension_term(F/A,Suspension) :-
9229 suspension_term_base(F/A,Base),
9230 Arity is Base + A,
9231 functor(Suspension,suspension,Arity).
9233 has_suspension_field(FA,Field) :-
9234 suspension_term_base_fields(FA,Fields),
9235 memberchk(Field,Fields).
9237 suspension_term_base(FA,Base) :-
9238 suspension_term_base_fields(FA,Fields),
9239 length(Fields,Base).
9241 suspension_term_base_fields(FA,Fields) :-
9242 ( chr_pp_flag(debugable,on) ->
9243 % 1. ID
9244 % 2. State
9245 % 3. Propagation History
9246 % 4. Generation Number
9247 % 5. Continuation Goal
9248 % 6. Functor
9249 Fields = [id,state,history,generation,continuation,functor]
9250 ;
9251 ( uses_history(FA) ->
9252 Fields = [id,state,history|Fields2]
9253 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9254 Fields = [state|Fields2]
9255 ;
9256 Fields = [id,state|Fields2]
9257 ),
9258 ( only_ground_indexed_arguments(FA) ->
9259 get_store_type(FA,StoreType),
9260 basic_store_types(StoreType,BasicStoreTypes),
9261 ( memberchk(global_ground,BasicStoreTypes) ->
9262 % 1. ID
9263 % 2. State
9264 % 3. Propagation History
9265 % 4. Global List Prev
9266 Fields2 = [global_list_prev|Fields3]
9267 ;
9268 % 1. ID
9269 % 2. State
9270 % 3. Propagation History
9271 Fields2 = Fields3
9272 ),
9273 ( chr_pp_flag(ht_removal,on)
9274 -> ht_prev_fields(BasicStoreTypes,Fields3)
9275 ; Fields3 = []
9276 )
9277 ; may_trigger(FA) ->
9278 % 1. ID
9279 % 2. State
9280 % 3. Propagation History
9281 ( uses_field(FA,generation) ->
9282 % 4. Generation Number
9283 % 5. Global List Prev
9284 Fields2 = [generation,global_list_prev|Fields3]
9285 ;
9286 Fields2 = [global_list_prev|Fields3]
9287 ),
9288 ( chr_pp_flag(mixed_stores,on),
9289 chr_pp_flag(ht_removal,on)
9290 -> get_store_type(FA,StoreType),
9291 basic_store_types(StoreType,BasicStoreTypes),
9292 ht_prev_fields(BasicStoreTypes,Fields3)
9293 ; Fields3 = []
9294 )
9295 ;
9296 % 1. ID
9297 % 2. State
9298 % 3. Propagation History
9299 % 4. Global List Prev
9300 Fields2 = [global_list_prev|Fields3],
9301 ( chr_pp_flag(mixed_stores,on),
9302 chr_pp_flag(ht_removal,on)
9303 -> get_store_type(FA,StoreType),
9304 basic_store_types(StoreType,BasicStoreTypes),
9305 ht_prev_fields(BasicStoreTypes,Fields3)
9306 ; Fields3 = []
9307 )
9308 )
9309 ).
9311 ht_prev_fields(Stores,Prevs) :-
9312 ht_prev_fields_int(Stores,PrevsList),
9313 append(PrevsList,Prevs).
9314 ht_prev_fields_int([],[]).
9315 ht_prev_fields_int([H|T],Fields) :-
9316 ( H = multi_hash(Indexes)
9317 -> maplist(ht_prev_field,Indexes,FH),
9318 Fields = [FH|FT]
9319 ; Fields = FT
9320 ),
9321 ht_prev_fields_int(T,FT).
9323 ht_prev_field(Index,Field) :-
9324 ( integer(Index)
9325 -> atom_concat('multi_hash_prev-',Index,Field)
9326 ; Index = [_|_]
9327 -> concat_atom(['multi_hash_prev-'|Index],Field)
9328 ).
9330 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9331 suspension_term_base_fields(FA,Fields),
9332 nth(Index,Fields,FieldName), !,
9333 arg(Index,StaticSuspension,Field).
9334 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9335 suspension_term_base(FA,Base),
9336 StaticSuspension =.. [_|Args],
9337 drop(Base,Args,Field).
9338 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9339 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9342 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9343 suspension_term_base_fields(FA,Fields),
9344 nth(Index,Fields,FieldName), !,
9345 Goal = arg(Index,DynamicSuspension,Field).
9346 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9347 static_suspension_term(FA,StaticSuspension),
9348 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9349 Goal = (DynamicSuspension = StaticSuspension).
9350 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9351 suspension_term_base(FA,Base),
9352 Index is I + Base,
9353 Goal = arg(Index,DynamicSuspension,Field).
9354 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9355 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9358 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9359 suspension_term_base_fields(FA,Fields),
9360 nth(Index,Fields,FieldName), !,
9361 Goal = setarg(Index,DynamicSuspension,Field).
9362 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9363 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9365 basic_store_types(multi_store(Types),Types) :- !.
9366 basic_store_types(Type,[Type]).
9368 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9369 %
9371 :- chr_constraint
9372 phase_end/1,
9373 delay_phase_end/2.
9375 :- chr_option(mode,phase_end(+)).
9376 :- chr_option(mode,delay_phase_end(+,?)).
9378 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9379 % phase_end(Phase) <=> true.
9382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9383 :- chr_constraint
9384 does_use_history/2,
9385 uses_history/1,
9386 novel_production_call/4.
9388 :- chr_option(mode,uses_history(+)).
9389 :- chr_option(mode,does_use_history(+,+)).
9390 :- chr_option(mode,novel_production_call(+,+,?,?)).
9392 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9393 does_use_history(FA,_) \ uses_history(FA) <=> true.
9394 uses_history(_FA) <=> fail.
9396 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9397 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9399 :- chr_constraint
9400 does_use_field/2,
9401 uses_field/2.
9403 :- chr_option(mode,uses_field(+,+)).
9404 :- chr_option(mode,does_use_field(+,+)).
9406 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9407 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9408 uses_field(_FA,_Field) <=> fail.
9410 :- chr_constraint
9411 uses_state/2,
9412 if_used_state/5,
9413 used_states_known/0.
9415 :- chr_option(mode,uses_state(+,+)).
9416 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9419 % states ::= not_stored_yet | passive | active | triggered | removed
9420 %
9421 % allocate CREATES not_stored_yet
9422 % remove CHECKS not_stored_yet
9423 % activate CHECKS not_stored_yet
9424 %
9425 % ==> no allocate THEN no not_stored_yet
9427 % recurs CREATES inactive
9428 % lookup CHECKS inactive
9430 % insert CREATES active
9431 % activate CREATES active
9432 % lookup CHECKS active
9433 % recurs CHECKS active
9435 % runsusp CREATES triggered
9436 % lookup CHECKS triggered
9437 %
9438 % ==> no runsusp THEN no triggered
9440 % remove CREATES removed
9441 % runsusp CHECKS removed
9442 % lookup CHECKS removed
9443 % recurs CHECKS removed
9444 %
9445 % ==> no remove THEN no removed
9447 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9449 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9451 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9452 <=> ResultGoal = Used.
9453 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9454 <=> ResultGoal = NotUsed.
9456 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9457 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9458 % (Feature for SSS)
9459 %
9460 % 1. Checking
9461 % ~~~~~~~~~~~
9462 %
9463 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9464 %
9465 % :- chr_option(declare_stored_constraints,on).
9466 %
9467 % the compiler will check for the storedness of constraints.
9468 %
9469 % By default, the compiler assumes that the programmer wants his constraints to
9470 % be never-stored. Hence, a warning will be issues when a constraint is actually
9471 % stored.
9472 %
9473 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9474 % to a constraint declaration, i.e. writes
9475 %
9476 % :- chr_constraint c(...) # stored.
9477 %
9478 % In that case a warning is issued when the constraint is never-stored.
9479 %
9480 % NOTE: Checking is only performed if `debug' mode is off. Otherwise, all
9481 % constraints are stored anyway.
9482 %
9483 %
9484 % 2. Rule Generation
9485 % ~~~~~~~~~~~~~~~~~~
9486 %
9487 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9488 %
9489 % :- chr_option(declare_stored_constraints,on).
9490 %
9491 % the compiler will generate default simplification rules for constraints.
9492 %
9493 % By default, no default rule is generated for a constraint. However, if the
9494 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9495 %
9496 % :- chr_constraint c(...) # default(Goal).
9497 %
9498 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9499 % the compiler generates a rule:
9500 %
9501 % c(_,...,_) <=> Goal.
9502 %
9503 % at the end of the program. If multiple default rules are generated, for several constraints,
9504 % then the order of the default rules is not specified.
9507 :- chr_constraint stored_assertion/1.
9508 :- chr_option(mode,stored_assertion(+)).
9509 :- chr_option(type_declaration,stored_assertion(constraint)).
9511 :- chr_constraint never_stored_default/2.
9512 :- chr_option(mode,never_stored_default(+,?)).
9513 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9515 % Rule Generation
9516 % ~~~~~~~~~~~~~~~
9518 generate_never_stored_rules(Constraints,Rules) :-
9519 ( chr_pp_flag(declare_stored_constraints,on) ->
9520 never_stored_rules(Constraints,Rules)
9521 ;
9522 Rules = []
9523 ).
9525 :- chr_constraint never_stored_rules/2.
9526 :- chr_option(mode,never_stored_rules(+,?)).
9527 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9529 never_stored_rules([],Rules) <=> Rules = [].
9530 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9531 Constraint = F/A,
9532 functor(Head,F,A),
9533 inc_rule_count(RuleNb),
9534 Rule = pragma(
9535 rule([Head],[],true,Goal),
9536 ids([0],[]),
9537 [],
9538 no,
9539 RuleNb
9540 ),
9541 Rules = [Rule|Tail],
9542 never_stored_rules(Constraints,Tail).
9543 never_stored_rules([_|Constraints],Rules) <=>
9544 never_stored_rules(Constraints,Rules).
9546 % Checking
9547 % ~~~~~~~~
9549 check_storedness_assertions(Constraints) :-
9550 ( chr_pp_flag(debugable,off), chr_pp_flag(declare_stored_constraints,on) ->
9551 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9552 ;
9553 true
9554 ).
9557 :- chr_constraint check_storedness_assertion/1.
9558 :- chr_option(mode,check_storedness_assertion(+)).
9559 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9561 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9562 <=> ( is_stored(Constraint) ->
9563 true
9564 ;
9565 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9566 ).
9567 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9568 <=> ( is_finally_stored(Constraint) ->
9569 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9570 ; is_stored(Constraint) ->
9571 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9572 ;
9573 true
9574 ).
9575 % never-stored, no default goal
9576 check_storedness_assertion(Constraint)
9577 <=> ( is_finally_stored(Constraint) ->
9578 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9579 ; is_stored(Constraint) ->
9580 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9581 ;
9582 true
9583 ).