| blob | 4425d7fa287212a04401a9f740ebc51804fc253b |
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)].
173 :- chr_type list == list(any).
175 :- chr_type mode ---> (+) ; (-) ; (?).
177 :- chr_type maybe(T) ---> yes(T) ; no.
179 :- chr_type constraint ---> any / any.
181 :- chr_type module_name == any.
183 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
184 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
185 :- chr_type idspair ---> ids(list(id),list(id)).
187 :- chr_type pragma_type ---> passive(id)
188 ; mpassive(list(id))
189 ; already_in_heads
190 ; already_in_heads(id)
191 ; no_history
192 ; history(history_name,list(id)).
193 :- chr_type history_name== any.
195 :- chr_type rule_name == any.
196 :- chr_type rule_nb == natural.
197 :- chr_type id == natural.
198 :- chr_type occurrence == int.
200 :- chr_type goal == any.
202 :- chr_type store_type ---> default
203 ; multi_store(list(store_type))
204 ; multi_hash(list(list(int)))
205 ; multi_inthash(list(list(int)))
206 ; global_singleton
207 ; global_ground
208 % EXPERIMENTAL STORES
209 ; atomic_constants(list(int),list(any),atomic_coverage)
210 ; ground_constants(list(int),list(any))
211 ; var_assoc_store(int,list(int))
212 ; identifier_store(int)
213 ; type_indexed_identifier_store(int,any).
214 :- chr_type atomic_coverage ---> complete ; incomplete.
216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
218 %------------------------------------------------------------------------------%
219 :- chr_constraint chr_source_file/1.
220 :- chr_option(mode,chr_source_file(+)).
221 :- chr_option(type_declaration,chr_source_file(module_name)).
222 %------------------------------------------------------------------------------%
223 chr_source_file(_) \ chr_source_file(_) <=> true.
225 %------------------------------------------------------------------------------%
226 :- chr_constraint get_chr_source_file/1.
227 :- chr_option(mode,get_chr_source_file(-)).
228 :- chr_option(type_declaration,get_chr_source_file(module_name)).
229 %------------------------------------------------------------------------------%
230 chr_source_file(Mod) \ get_chr_source_file(Query)
231 <=> Query = Mod .
232 get_chr_source_file(Query)
233 <=> Query = user.
236 %------------------------------------------------------------------------------%
237 :- chr_constraint target_module/1.
238 :- chr_option(mode,target_module(+)).
239 :- chr_option(type_declaration,target_module(module_name)).
240 %------------------------------------------------------------------------------%
241 target_module(_) \ target_module(_) <=> true.
243 %------------------------------------------------------------------------------%
244 :- chr_constraint get_target_module/1.
245 :- chr_option(mode,get_target_module(-)).
246 :- chr_option(type_declaration,get_target_module(module_name)).
247 %------------------------------------------------------------------------------%
248 target_module(Mod) \ get_target_module(Query)
249 <=> Query = Mod .
250 get_target_module(Query)
251 <=> Query = user.
253 %------------------------------------------------------------------------------%
254 :- chr_constraint line_number/2.
255 :- chr_option(mode,line_number(+,+)).
256 :- chr_option(type_declaration,line_number(rule_nb,int)).
257 %------------------------------------------------------------------------------%
258 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
260 %------------------------------------------------------------------------------%
261 :- chr_constraint get_line_number/2.
262 :- chr_option(mode,get_line_number(+,-)).
263 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
264 %------------------------------------------------------------------------------%
265 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
266 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
268 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
269 :- chr_option(mode,indexed_argument(+,+)).
270 :- chr_option(type_declaration,indexed_argument(constraint,int)).
272 :- chr_constraint is_indexed_argument/2.
273 :- chr_option(mode,is_indexed_argument(+,+)).
274 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
276 :- chr_constraint constraint_mode/2.
277 :- chr_option(mode,constraint_mode(+,+)).
278 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
280 :- chr_constraint get_constraint_mode/2.
281 :- chr_option(mode,get_constraint_mode(+,-)).
282 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
284 :- chr_constraint may_trigger/1.
285 :- chr_option(mode,may_trigger(+)).
286 :- chr_option(type_declaration,may_trigger(constraint)).
288 :- chr_constraint only_ground_indexed_arguments/1.
289 :- chr_option(mode,only_ground_indexed_arguments(+)).
290 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
292 :- chr_constraint none_suspended_on_variables/0.
294 :- chr_constraint are_none_suspended_on_variables/0.
296 :- chr_constraint store_type/2.
297 :- chr_option(mode,store_type(+,+)).
298 :- chr_option(type_declaration,store_type(constraint,store_type)).
300 :- chr_constraint get_store_type/2.
301 :- chr_option(mode,get_store_type(+,?)).
302 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
304 :- chr_constraint update_store_type/2.
305 :- chr_option(mode,update_store_type(+,+)).
306 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
308 :- chr_constraint actual_store_types/2.
309 :- chr_option(mode,actual_store_types(+,+)).
310 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
312 :- chr_constraint assumed_store_type/2.
313 :- chr_option(mode,assumed_store_type(+,+)).
314 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
316 :- chr_constraint validate_store_type_assumption/1.
317 :- chr_option(mode,validate_store_type_assumption(+)).
318 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
320 :- chr_constraint rule_count/1.
321 :- chr_option(mode,rule_count(+)).
322 :- chr_option(type_declaration,rule_count(natural)).
324 :- chr_constraint inc_rule_count/1.
325 :- chr_option(mode,inc_rule_count(-)).
326 :- chr_option(type_declaration,inc_rule_count(natural)).
328 rule_count(_) \ rule_count(_)
329 <=> true.
330 rule_count(C), inc_rule_count(NC)
331 <=> NC is C + 1, rule_count(NC).
332 inc_rule_count(NC)
333 <=> NC = 1, rule_count(NC).
335 :- chr_constraint passive/2.
336 :- chr_option(mode,passive(+,+)).
338 :- chr_constraint is_passive/2.
339 :- chr_option(mode,is_passive(+,+)).
341 :- chr_constraint any_passive_head/1.
342 :- chr_option(mode,any_passive_head(+)).
344 :- chr_constraint new_occurrence/4.
345 :- chr_option(mode,new_occurrence(+,+,+,+)).
347 :- chr_constraint occurrence/5.
348 :- chr_option(mode,occurrence(+,+,+,+,+)).
349 :- chr_type occurrence_type ---> simplification ; propagation.
350 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
352 :- chr_constraint get_occurrence/4.
353 :- chr_option(mode,get_occurrence(+,+,-,-)).
355 :- chr_constraint get_occurrence_from_id/4.
356 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
358 :- chr_constraint max_occurrence/2.
359 :- chr_option(mode,max_occurrence(+,+)).
361 :- chr_constraint get_max_occurrence/2.
362 :- chr_option(mode,get_max_occurrence(+,-)).
364 :- chr_constraint allocation_occurrence/2.
365 :- chr_option(mode,allocation_occurrence(+,+)).
367 :- chr_constraint get_allocation_occurrence/2.
368 :- chr_option(mode,get_allocation_occurrence(+,-)).
370 :- chr_constraint rule/2.
371 :- chr_option(mode,rule(+,+)).
372 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
374 :- chr_constraint get_rule/2.
375 :- chr_option(mode,get_rule(+,-)).
376 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
378 :- chr_constraint least_occurrence/2.
379 :- chr_option(mode,least_occurrence(+,+)).
380 :- chr_option(type_declaration,least_occurrence(any,list)).
382 :- chr_constraint is_least_occurrence/1.
383 :- chr_option(mode,is_least_occurrence(+)).
386 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
387 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
388 is_indexed_argument(_,_) <=> fail.
390 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
392 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
393 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
394 Q = Mode.
395 get_constraint_mode(FA,Q) <=>
396 FA = _ / N,
397 replicate(N,(?),Q).
399 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
402 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
403 nth1(I,Mode,M),
404 M \== (+) |
405 is_stored(FA).
406 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
408 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
409 <=>
410 nth1(I,Mode,M),
411 M \== (+)
412 |
413 fail.
414 only_ground_indexed_arguments(_) <=>
415 true.
417 none_suspended_on_variables \ none_suspended_on_variables <=> true.
418 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
419 are_none_suspended_on_variables <=> fail.
420 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
421 % STORE TYPES
422 %
423 % The functionality for inspecting and deciding on the different types of constraint
424 % store / indexes for constraints.
426 store_type(FA,StoreType)
427 ==> chr_pp_flag(verbose,on)
428 |
429 format('The indexes for ~w are:\n',[FA]),
430 format_storetype(StoreType).
431 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
433 format_storetype(multi_store(StoreTypes)) :- !,
434 forall(member(StoreType,StoreTypes), format_storetype(StoreType)).
435 format_storetype(atomic_constants(Index,Constants,_)) :-
436 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
437 format_storetype(ground_constants(Index,Constants)) :-
438 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
439 format_storetype(StoreType) :-
440 format('\t* ~w\n',[StoreType]).
443 % 1. Inspection
444 % ~~~~~~~~~~~~~
445 %
446 %
448 get_store_type_normal @
449 store_type(FA,Store) \ get_store_type(FA,Query)
450 <=> Query = Store.
452 get_store_type_assumed @
453 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
454 <=> Query = Store.
456 get_store_type_default @
457 get_store_type(_,Query)
458 <=> Query = default.
460 % 2. Store type registration
461 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
463 actual_store_types(C,STs) \ update_store_type(C,ST)
464 <=> member(ST,STs) | true.
465 update_store_type(C,ST), actual_store_types(C,STs)
466 <=>
467 actual_store_types(C,[ST|STs]).
468 update_store_type(C,ST)
469 <=>
470 actual_store_types(C,[ST]).
472 % 3. Final decision on store types
473 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
476 <=>
477 true % chr_pp_flag(experiment,on)
478 |
479 delete(STs,multi_hash([Index]),STs0),
480 Index = [IndexPos],
481 ( get_constraint_type(C,Types),
482 nth1(IndexPos,Types,Type),
483 enumerated_atomic_type(Type,Atoms),
484 sort(Atoms,Keys) ->
485 Completeness = complete
486 ;
487 Completeness = incomplete
488 ),
489 actual_store_types(C,[atomic_constants(Index,Keys,Completeness)|STs0]).
490 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Keys)
491 <=>
492 true % chr_pp_flag(experiment,on)
493 |
494 delete(STs,multi_hash([Index]),STs0),
495 actual_store_types(C,[ground_constants(Index,Keys)|STs0]).
496 validate_store_type_assumption(C) \ actual_store_types(C,STs)
497 <=>
498 % chr_pp_flag(experiment,on),
499 memberchk(multi_hash([[Index]]),STs),
500 get_constraint_type(C,Types),
501 nth1(Index,Types,Type),
502 enumerated_atomic_type(Type,Atoms)
503 |
504 delete(STs,multi_hash([[Index]]),STs0),
505 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
506 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
507 <=>
508 ( /* chr_pp_flag(experiment,on), */ forall(member(ST,STs), partial_store(ST)) ->
509 Stores0 = [global_ground|STs]
510 ;
511 Stores0 = STs
512 ),
513 prune_stores(Stores0,Stores),
514 store_type(C,multi_store(Stores)).
515 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
516 <=>
517 store_type(C,multi_store(STs)).
518 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
519 <=>
520 chr_pp_flag(debugable,on)
521 |
522 store_type(C,default).
523 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
524 <=> store_type(C,global_ground).
525 validate_store_type_assumption(C)
526 <=> true.
528 partial_store(ground_constants(_,_)).
529 partial_store(atomic_constants(_,_,incomplete)).
531 % heuristic to reduce the number of indexes
532 % prune_stores(Stores0,Stores) :-
533 % select(multi_hash([Indexes1]),Stores0,Stores1),
534 % Indexes1 = [_,_,_|_],
535 % member(multi_hash([Indexes2]),Stores1),
536 % Indexes2 = [_,_|_],
537 % subset(Indexes2,Indexes1),
538 % !,
539 % Stores = Stores1.
540 % default case
541 prune_stores(Stores,Stores).
543 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
544 passive(R,ID) \ passive(R,ID) <=> true.
546 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
547 is_passive(_,_) <=> fail.
549 passive(RuleNb,_) \ any_passive_head(RuleNb)
550 <=> true.
551 any_passive_head(_)
552 <=> fail.
553 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
555 max_occurrence(C,N) \ max_occurrence(C,M)
556 <=> N >= M | true.
558 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
559 NO is MO + 1,
560 occurrence(C,NO,RuleNb,ID,Type),
561 max_occurrence(C,NO).
562 new_occurrence(C,RuleNb,ID,_) <=>
563 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
565 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
566 <=> Q = MON.
567 get_max_occurrence(C,Q)
568 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
570 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
571 <=> Rule = QRule, ID = QID.
572 get_occurrence(C,O,_,_)
573 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
575 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
576 <=> QC = C, QON = ON.
577 get_occurrence_from_id(C,O,_,_)
578 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
580 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
581 % Late allocation
583 late_allocation_analysis(Cs) :-
584 ( chr_pp_flag(late_allocation,on) ->
585 maplist(late_allocation, Cs)
586 ;
587 true
588 ).
590 late_allocation(C) :- late_allocation(C,0).
591 late_allocation(C,O) :- allocation_occurrence(C,O), !.
592 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
594 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
596 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
598 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
599 \+ is_passive(RuleNb,Id),
600 Type == propagation,
601 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
602 true
603 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
604 is_observed(C,O)
605 ; is_least_occurrence(RuleNb) -> % propagation rule
606 is_observed(C,O)
607 ;
608 true
609 ).
611 stored_in_guard_before_next_kept_occurrence(C,O) :-
612 chr_pp_flag(store_in_guards, on),
613 NO is O + 1,
614 stored_in_guard_lookahead(C,NO).
616 :- chr_constraint stored_in_guard_lookahead/2.
617 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
619 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
620 NO is O + 1, stored_in_guard_lookahead(C,NO).
621 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
622 Type == simplification,
623 ( is_stored_in_guard(C,RuleNb) ->
624 true
625 ;
626 NO is O + 1, stored_in_guard_lookahead(C,NO)
627 ).
628 stored_in_guard_lookahead(_,_) <=> fail.
631 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
632 \ least_occurrence(RuleNb,[ID|IDs])
633 <=> AO >= O, \+ may_trigger(C) |
634 least_occurrence(RuleNb,IDs).
635 rule(RuleNb,Rule), passive(RuleNb,ID)
636 \ least_occurrence(RuleNb,[ID|IDs])
637 <=> least_occurrence(RuleNb,IDs).
639 rule(RuleNb,Rule)
640 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
641 least_occurrence(RuleNb,IDs).
643 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
644 <=> true.
645 is_least_occurrence(_)
646 <=> fail.
648 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
649 <=> Q = O.
650 get_allocation_occurrence(_,Q)
651 <=> chr_pp_flag(late_allocation,off), Q=0.
652 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
654 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
655 <=> Q = Rule.
656 get_rule(_,_)
657 <=> fail.
659 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
661 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
662 %
663 % Default store constraint index assignment.
665 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
666 :- chr_option(mode,constraint_index(+,+)).
667 :- chr_option(type_declaration,constraint_index(constraint,int)).
669 :- chr_constraint get_constraint_index/2.
670 :- chr_option(mode,get_constraint_index(+,-)).
671 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
673 :- chr_constraint get_indexed_constraint/2.
674 :- chr_option(mode,get_indexed_constraint(+,-)).
675 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
677 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
678 :- chr_option(mode,max_constraint_index(+)).
679 :- chr_option(type_declaration,max_constraint_index(int)).
681 :- chr_constraint get_max_constraint_index/1.
682 :- chr_option(mode,get_max_constraint_index(-)).
683 :- chr_option(type_declaration,get_max_constraint_index(int)).
685 constraint_index(C,Index) \ get_constraint_index(C,Query)
686 <=> Query = Index.
687 get_constraint_index(C,Query)
688 <=> fail.
690 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
691 <=> Q = C.
692 get_indexed_constraint(Index,Q)
693 <=> fail.
695 max_constraint_index(Index) \ get_max_constraint_index(Query)
696 <=> Query = Index.
697 get_max_constraint_index(Query)
698 <=> Query = 0.
700 set_constraint_indices(Constraints) :-
701 set_constraint_indices(Constraints,1).
702 set_constraint_indices([],M) :-
703 N is M - 1,
704 max_constraint_index(N).
705 set_constraint_indices([C|Cs],N) :-
706 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
707 ; get_store_type(C,var_assoc_store(_,_))) ->
708 constraint_index(C,N),
709 M is N + 1,
710 set_constraint_indices(Cs,M)
711 ;
712 set_constraint_indices(Cs,N)
713 ).
715 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
716 % Identifier Indexes
718 :- chr_constraint identifier_size/1.
719 :- chr_option(mode,identifier_size(+)).
720 :- chr_option(type_declaration,identifier_size(natural)).
722 identifier_size(_) \ identifier_size(_)
723 <=>
724 true.
726 :- chr_constraint get_identifier_size/1.
727 :- chr_option(mode,get_identifier_size(-)).
728 :- chr_option(type_declaration,get_identifier_size(natural)).
730 identifier_size(Size) \ get_identifier_size(Q)
731 <=>
732 Q = Size.
734 get_identifier_size(Q)
735 <=>
736 Q = 1.
738 :- chr_constraint identifier_index/3.
739 :- chr_option(mode,identifier_index(+,+,+)).
740 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
742 identifier_index(C,I,_) \ identifier_index(C,I,_)
743 <=>
744 true.
746 :- chr_constraint get_identifier_index/3.
747 :- chr_option(mode,get_identifier_index(+,+,-)).
748 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
750 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
751 <=>
752 Q = II.
753 identifier_size(Size), get_identifier_index(C,I,Q)
754 <=>
755 NSize is Size + 1,
756 identifier_index(C,I,NSize),
757 identifier_size(NSize),
758 Q = NSize.
759 get_identifier_index(C,I,Q)
760 <=>
761 identifier_index(C,I,2),
762 identifier_size(2),
763 Q = 2.
765 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
766 % Type Indexed Identifier Indexes
768 :- chr_constraint type_indexed_identifier_size/2.
769 :- chr_option(mode,type_indexed_identifier_size(+,+)).
770 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
772 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
773 <=>
774 true.
776 :- chr_constraint get_type_indexed_identifier_size/2.
777 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
778 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
780 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
781 <=>
782 Q = Size.
784 get_type_indexed_identifier_size(IndexType,Q)
785 <=>
786 Q = 1.
788 :- chr_constraint type_indexed_identifier_index/4.
789 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
790 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
792 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
793 <=>
794 true.
796 :- chr_constraint get_type_indexed_identifier_index/4.
797 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
798 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
800 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
801 <=>
802 Q = II.
803 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
804 <=>
805 NSize is Size + 1,
806 type_indexed_identifier_index(IndexType,C,I,NSize),
807 type_indexed_identifier_size(IndexType,NSize),
808 Q = NSize.
809 get_type_indexed_identifier_index(IndexType,C,I,Q)
810 <=>
811 type_indexed_identifier_index(IndexType,C,I,2),
812 type_indexed_identifier_size(IndexType,2),
813 Q = 2.
815 type_indexed_identifier_structure(IndexType,Structure) :-
816 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
817 get_type_indexed_identifier_size(IndexType,Arity),
818 functor(Structure,Functor,Arity).
819 type_indexed_identifier_name(IndexType,Prefix,Name) :-
820 ( atom(IndexType) ->
821 IndexTypeName = IndexType
822 ;
823 term_to_atom(IndexType,IndexTypeName)
824 ),
825 atom_concat_list([Prefix,'_',IndexTypeName],Name).
827 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
832 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
833 %%
834 %% Translation
836 chr_translate(Declarations,NewDeclarations) :-
837 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
839 chr_translate_line_info(Declarations,File,NewDeclarations) :-
840 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',[]),
841 init_chr_pp_flags,
842 chr_source_file(File),
843 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
844 chr_compiler_options:sanity_check,
845 check_declared_constraints(Constraints0),
846 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
847 add_constraints(Constraints),
848 add_rules(Rules1),
849 generate_never_stored_rules(Constraints,NewRules),
850 add_rules(NewRules),
851 append(Rules1,NewRules,Rules),
852 % start analysis
853 check_rules(Rules,Constraints),
854 time('type checking',chr_translate:static_type_check),
855 add_occurrences(Rules),
856 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
857 time('set semantics',chr_translate:set_semantics_rules(Rules)),
858 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
859 time('guard simplification',chr_translate:guard_simplification),
860 time('late storage',chr_translate:storage_analysis(Constraints)),
861 time('observation',chr_translate:observation_analysis(Constraints)),
862 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
863 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
864 partial_wake_analysis,
865 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
866 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
867 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
868 success_continuation_analysis(Constraints),
869 % end analysis
870 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
871 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
872 phase_end(validate_store_type_assumptions),
873 used_states_known,
874 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
875 insert_declarations(OtherClauses, Clauses0),
876 chr_module_declaration(CHRModuleDeclaration),
877 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
878 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
879 append([Clauses0,GeneratedClauses], NewDeclarations).
881 store_management_preds(Constraints,Clauses) :-
882 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
883 generate_attr_unify_hook(AttrUnifyHookClauses),
884 generate_attach_increment(AttachIncrementClauses),
885 generate_extra_clauses(Constraints,ExtraClauses),
886 generate_insert_delete_constraints(Constraints,DeleteClauses),
887 generate_attach_code(Constraints,StoreClauses),
888 generate_counter_code(CounterClauses),
889 generate_dynamic_type_check_clauses(TypeCheckClauses),
890 append([AttachAConstraintClauses
891 ,AttachIncrementClauses
892 ,AttrUnifyHookClauses
893 ,ExtraClauses
894 ,DeleteClauses
895 ,StoreClauses
896 ,CounterClauses
897 ,TypeCheckClauses
898 ]
899 ,Clauses).
902 insert_declarations(Clauses0, Clauses) :-
903 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
904 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
906 auxiliary_module(chr_hashtable_store).
907 auxiliary_module(chr_integertable_store).
908 auxiliary_module(chr_assoc_store).
910 generate_counter_code(Clauses) :-
911 ( chr_pp_flag(store_counter,on) ->
912 Clauses = [
913 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
914 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
915 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
916 (:- '$counter_init'('$insert_counter')),
917 (:- '$counter_init'('$delete_counter')),
918 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
919 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
920 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
921 ]
922 ;
923 Clauses = []
924 ).
926 % for systems with multifile declaration
927 chr_module_declaration(CHRModuleDeclaration) :-
928 get_target_module(Mod),
929 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
930 CHRModuleDeclaration = [
931 (:- multifile chr:'$chr_module'/1),
932 chr:'$chr_module'(Mod)
933 ]
934 ;
935 CHRModuleDeclaration = []
936 ).
939 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
940 %%
941 %% Partitioning of clauses into constraint declarations, chr rules and other
942 %% clauses
944 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
945 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
946 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
947 partition_clauses([],[],[],[]).
948 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
949 ( parse_rule(Clause,Rule) ->
950 ConstraintDeclarations = RestConstraintDeclarations,
951 Rules = [Rule|RestRules],
952 OtherClauses = RestOtherClauses
953 ; is_declaration(Clause,ConstraintDeclaration) ->
954 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
955 Rules = RestRules,
956 OtherClauses = RestOtherClauses
957 ; is_module_declaration(Clause,Mod) ->
958 target_module(Mod),
959 ConstraintDeclarations = RestConstraintDeclarations,
960 Rules = RestRules,
961 OtherClauses = [Clause|RestOtherClauses]
962 ; is_type_definition(Clause) ->
963 ConstraintDeclarations = RestConstraintDeclarations,
964 Rules = RestRules,
965 OtherClauses = RestOtherClauses
966 ; Clause = (handler _) ->
967 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
968 ConstraintDeclarations = RestConstraintDeclarations,
969 Rules = RestRules,
970 OtherClauses = RestOtherClauses
971 ; Clause = (rules _) ->
972 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
973 ConstraintDeclarations = RestConstraintDeclarations,
974 Rules = RestRules,
975 OtherClauses = RestOtherClauses
976 ; Clause = option(OptionName,OptionValue) ->
977 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
978 handle_option(OptionName,OptionValue),
979 ConstraintDeclarations = RestConstraintDeclarations,
980 Rules = RestRules,
981 OtherClauses = RestOtherClauses
982 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
983 handle_option(OptionName,OptionValue),
984 ConstraintDeclarations = RestConstraintDeclarations,
985 Rules = RestRules,
986 OtherClauses = RestOtherClauses
987 ; Clause = ('$chr_compiled_with_version'(_)) ->
988 ConstraintDeclarations = RestConstraintDeclarations,
989 Rules = RestRules,
990 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
991 ; ConstraintDeclarations = RestConstraintDeclarations,
992 Rules = RestRules,
993 OtherClauses = [Clause|RestOtherClauses]
994 ),
995 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
997 '$chr_compiled_with_version'(2).
999 is_declaration(D, Constraints) :- %% constraint declaration
1000 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1001 conj2list(Cs,Constraints0)
1002 ;
1003 ( D = (:- Decl) ->
1004 Decl =.. [constraints,Cs]
1005 ;
1006 D =.. [constraints,Cs]
1007 ),
1008 conj2list(Cs,Constraints0),
1009 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1010 ),
1011 extract_type_mode(Constraints0,Constraints).
1013 extract_type_mode([],[]).
1014 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1015 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1016 ( C0 = C # Annotation ->
1017 functor(C,F,A),
1018 extract_annotation(Annotation,F/A)
1019 ;
1020 C0 = C,
1021 functor(C,F,A)
1022 ),
1023 ConstraintSymbol = F/A,
1024 C =.. [_|Args],
1025 extract_types_and_modes(Args,ArgTypes,ArgModes),
1026 assert_constraint_type(ConstraintSymbol,ArgTypes),
1027 constraint_mode(ConstraintSymbol,ArgModes),
1028 extract_type_mode(R,R2).
1030 extract_annotation(stored,Symbol) :-
1031 stored_assertion(Symbol).
1032 extract_annotation(default(Goal),Symbol) :-
1033 never_stored_default(Symbol,Goal).
1035 extract_types_and_modes([],[],[]).
1036 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1037 extract_type_and_mode(X,T,M),
1038 extract_types_and_modes(R,R2,R3).
1040 extract_type_and_mode(+(T),T,(+)) :- !.
1041 extract_type_and_mode(?(T),T,(?)) :- !.
1042 extract_type_and_mode(-(T),T,(-)) :- !.
1043 extract_type_and_mode((+),any,(+)) :- !.
1044 extract_type_and_mode((?),any,(?)) :- !.
1045 extract_type_and_mode((-),any,(-)) :- !.
1046 extract_type_and_mode(Illegal,_,_) :-
1047 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1049 is_type_definition(Declaration) :-
1050 ( Declaration = (:- TDef) ->
1051 true
1052 ;
1053 Declaration = TDef
1054 ),
1055 TDef =.. [chr_type,TypeDef],
1056 ( TypeDef = (Name ---> Def) ->
1057 tdisj2list(Def,DefList),
1058 type_definition(Name,DefList)
1059 ; TypeDef = (Alias == Name) ->
1060 type_alias(Alias,Name)
1061 ;
1062 type_definition(TypeDef,[]),
1063 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1064 ).
1066 %% tdisj2list(+Goal,-ListOfGoals) is det.
1067 %
1068 % no removal of fails, e.g. :- type bool ---> true ; fail.
1069 tdisj2list(Conj,L) :-
1070 tdisj2list(Conj,L,[]).
1072 tdisj2list(Conj,L,T) :-
1073 Conj = (G1;G2), !,
1074 tdisj2list(G1,L,T1),
1075 tdisj2list(G2,T1,T).
1076 tdisj2list(G,[G | T],T).
1079 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1080 %% parse_rule(+term,-pragma_rule) is semidet.
1081 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1082 parse_rule(RI,R) :- %% name @ rule
1083 RI = (Name @ RI2), !,
1084 rule(RI2,yes(Name),R).
1085 parse_rule(RI,R) :-
1086 rule(RI,no,R).
1088 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1089 %% parse_rule(+term,-pragma_rule) is semidet.
1090 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1091 rule(RI,Name,R) :-
1092 RI = (RI2 pragma P), !, %% pragmas
1093 ( var(P) ->
1094 Ps = [_] % intercept variable
1095 ;
1096 conj2list(P,Ps)
1097 ),
1098 inc_rule_count(RuleCount),
1099 R = pragma(R1,IDs,Ps,Name,RuleCount),
1100 is_rule(RI2,R1,IDs,R).
1101 rule(RI,Name,R) :-
1102 inc_rule_count(RuleCount),
1103 R = pragma(R1,IDs,[],Name,RuleCount),
1104 is_rule(RI,R1,IDs,R).
1106 is_rule(RI,R,IDs,RC) :- %% propagation rule
1107 RI = (H ==> B), !,
1108 conj2list(H,Head2i),
1109 get_ids(Head2i,IDs2,Head2,RC),
1110 IDs = ids([],IDs2),
1111 ( B = (G | RB) ->
1112 R = rule([],Head2,G,RB)
1113 ;
1114 R = rule([],Head2,true,B)
1115 ).
1116 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1117 RI = (H <=> B), !,
1118 ( B = (G | RB) ->
1119 Guard = G,
1120 Body = RB
1121 ; Guard = true,
1122 Body = B
1123 ),
1124 ( H = (H1 \ H2) ->
1125 conj2list(H1,Head2i),
1126 conj2list(H2,Head1i),
1127 get_ids(Head2i,IDs2,Head2,0,N,RC),
1128 get_ids(Head1i,IDs1,Head1,N,_,RC),
1129 IDs = ids(IDs1,IDs2)
1130 ; conj2list(H,Head1i),
1131 Head2 = [],
1132 get_ids(Head1i,IDs1,Head1,RC),
1133 IDs = ids(IDs1,[])
1134 ),
1135 R = rule(Head1,Head2,Guard,Body).
1137 get_ids(Cs,IDs,NCs,RC) :-
1138 get_ids(Cs,IDs,NCs,0,_,RC).
1140 get_ids([],[],[],N,N,_).
1141 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1142 ( C = (NC # N1) ->
1143 ( var(N1) ->
1144 N1 = N
1145 ;
1146 check_direct_pragma(N1,N,RC)
1147 )
1148 ;
1149 NC = C
1150 ),
1151 M is N + 1,
1152 get_ids(Cs,IDs,NCs, M,NN,RC).
1154 check_direct_pragma(passive,Id,PragmaRule) :- !,
1155 PragmaRule = pragma(_,_,_,_,RuleNb),
1156 passive(RuleNb,Id).
1157 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1158 ( direct_pragma(FullPragma),
1159 atom_concat(Abbrev,Remainder,FullPragma) ->
1160 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1161 ;
1162 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1163 ).
1165 direct_pragma(passive).
1167 is_module_declaration((:- module(Mod)),Mod).
1168 is_module_declaration((:- module(Mod,_)),Mod).
1170 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1173 % Add constraints
1174 add_constraints([]).
1175 add_constraints([C|Cs]) :-
1176 max_occurrence(C,0),
1177 C = _/A,
1178 length(Mode,A),
1179 set_elems(Mode,?),
1180 constraint_mode(C,Mode),
1181 add_constraints(Cs).
1183 % Add rules
1184 add_rules([]).
1185 add_rules([Rule|Rules]) :-
1186 Rule = pragma(_,_,_,_,RuleNb),
1187 rule(RuleNb,Rule),
1188 add_rules(Rules).
1190 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1192 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1193 %% Some input verification:
1195 check_declared_constraints(Constraints) :-
1196 check_declared_constraints(Constraints,[]).
1198 check_declared_constraints([],_).
1199 check_declared_constraints([C|Cs],Acc) :-
1200 ( memberchk_eq(C,Acc) ->
1201 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1202 ;
1203 true
1204 ),
1205 check_declared_constraints(Cs,[C|Acc]).
1207 %% - all constraints in heads are declared constraints
1208 %% - all passive pragmas refer to actual head constraints
1210 check_rules([],_).
1211 check_rules([PragmaRule|Rest],Decls) :-
1212 check_rule(PragmaRule,Decls),
1213 check_rules(Rest,Decls).
1215 check_rule(PragmaRule,Decls) :-
1216 check_rule_indexing(PragmaRule),
1217 check_trivial_propagation_rule(PragmaRule),
1218 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1219 Rule = rule(H1,H2,_,_),
1220 append(H1,H2,HeadConstraints),
1221 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1222 check_pragmas(Pragmas,PragmaRule).
1224 % Make all heads passive in trivial propagation rule
1225 % ... ==> ... | true.
1226 check_trivial_propagation_rule(PragmaRule) :-
1227 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1228 ( Rule = rule([],_,_,true) ->
1229 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1230 set_all_passive(RuleNb)
1231 ;
1232 true
1233 ).
1235 check_head_constraints([],_,_).
1236 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1237 functor(Constr,F,A),
1238 ( member(F/A,Decls) ->
1239 check_head_constraints(Rest,Decls,PragmaRule)
1240 ;
1241 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1242 ).
1244 check_pragmas([],_).
1245 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1246 check_pragma(Pragma,PragmaRule),
1247 check_pragmas(Pragmas,PragmaRule).
1249 check_pragma(Pragma,PragmaRule) :-
1250 var(Pragma), !,
1251 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1252 check_pragma(passive(ID), PragmaRule) :-
1253 !,
1254 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1255 ( memberchk_eq(ID,IDs1) ->
1256 true
1257 ; memberchk_eq(ID,IDs2) ->
1258 true
1259 ;
1260 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1261 ),
1262 passive(RuleNb,ID).
1264 check_pragma(mpassive(IDs), PragmaRule) :-
1265 !,
1266 PragmaRule = pragma(_,_,_,_,RuleNb),
1267 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1268 maplist(passive(RuleNb),IDs).
1270 check_pragma(Pragma, PragmaRule) :-
1271 Pragma = already_in_heads,
1272 !,
1273 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1275 check_pragma(Pragma, PragmaRule) :-
1276 Pragma = already_in_head(_),
1277 !,
1278 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1280 check_pragma(Pragma, PragmaRule) :-
1281 Pragma = no_history,
1282 !,
1283 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1284 PragmaRule = pragma(_,_,_,_,N),
1285 no_history(N).
1287 check_pragma(Pragma, PragmaRule) :-
1288 Pragma = history(HistoryName,IDs),
1289 !,
1290 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1291 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1292 ( IDs1 \== [] ->
1293 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1294 ; \+ atom(HistoryName) ->
1295 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1296 ; \+ is_set(IDs) ->
1297 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1298 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1299 history(RuleNb,HistoryName,IDs)
1300 ;
1301 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1302 ).
1303 check_pragma(Pragma,PragmaRule) :-
1304 Pragma = line_number(LineNumber),
1305 !,
1306 PragmaRule = pragma(_,_,_,_,RuleNb),
1307 line_number(RuleNb,LineNumber).
1309 check_history_pragma_ids([], _, _).
1310 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1311 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1312 check_history_pragma_ids(IDs,IDs1,IDs2).
1314 check_pragma(Pragma,PragmaRule) :-
1315 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1317 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1318 %% no_history(+RuleNb) is det.
1319 :- chr_constraint no_history/1.
1320 :- chr_option(mode,no_history(+)).
1321 :- chr_option(type_declaration,no_history(int)).
1323 %% has_no_history(+RuleNb) is semidet.
1324 :- chr_constraint has_no_history/1.
1325 :- chr_option(mode,has_no_history(+)).
1326 :- chr_option(type_declaration,has_no_history(int)).
1328 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1329 has_no_history(_) <=> fail.
1331 :- chr_constraint history/3.
1332 :- chr_option(mode,history(+,+,+)).
1333 :- chr_option(type_declaration,history(any,any,list)).
1335 :- chr_constraint named_history/3.
1337 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1338 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1340 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1341 length(IDs1,L1), length(IDs2,L2),
1342 ( L1 \== L2 ->
1343 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1344 ;
1345 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1346 ).
1348 test_named_history_id_pairs(_, [], _, []).
1349 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1350 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1351 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1353 :- chr_constraint test_named_history_id_pair/4.
1354 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1356 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1357 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1358 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1359 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1361 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1362 named_history(_,_,_) <=> fail.
1364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1367 format_rule(PragmaRule) :-
1368 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1369 ( MaybeName = yes(Name) ->
1370 write('rule '), write(Name)
1371 ;
1372 write('rule number '), write(RuleNumber)
1373 ),
1374 get_line_number(RuleNumber,LineNumber),
1375 write(' (line '),
1376 write(LineNumber),
1377 write(')').
1379 check_rule_indexing(PragmaRule) :-
1380 PragmaRule = pragma(Rule,_,_,_,_),
1381 Rule = rule(H1,H2,G,_),
1382 term_variables(H1-H2,HeadVars),
1383 remove_anti_monotonic_guards(G,HeadVars,NG),
1384 check_indexing(H1,NG-H2),
1385 check_indexing(H2,NG-H1),
1386 % EXPERIMENT
1387 ( chr_pp_flag(term_indexing,on) ->
1388 term_variables(NG,GuardVariables),
1389 append(H1,H2,Heads),
1390 check_specs_indexing(Heads,GuardVariables,Specs)
1391 ;
1392 true
1393 ).
1395 :- chr_constraint indexing_spec/2.
1396 :- chr_option(mode,indexing_spec(+,+)).
1398 :- chr_constraint get_indexing_spec/2.
1399 :- chr_option(mode,get_indexing_spec(+,-)).
1402 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1403 get_indexing_spec(_,Spec) <=> Spec = [].
1405 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1406 <=>
1407 append(Specs1,Specs2,Specs),
1408 indexing_spec(FA,Specs).
1410 remove_anti_monotonic_guards(G,Vars,NG) :-
1411 conj2list(G,GL),
1412 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1413 list2conj(NGL,NG).
1415 remove_anti_monotonic_guard_list([],_,[]).
1416 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1417 ( G = var(X), memberchk_eq(X,Vars) ->
1418 NGs = RGs
1419 % TODO: this is not correct
1420 % ; G = functor(Term,Functor,Arity), % isotonic
1421 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1422 % NGs = RGs
1423 ;
1424 NGs = [G|RGs]
1425 ),
1426 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1428 check_indexing([],_).
1429 check_indexing([Head|Heads],Other) :-
1430 functor(Head,F,A),
1431 Head =.. [_|Args],
1432 term_variables(Heads-Other,OtherVars),
1433 check_indexing(Args,1,F/A,OtherVars),
1434 check_indexing(Heads,[Head|Other]).
1436 check_indexing([],_,_,_).
1437 check_indexing([Arg|Args],I,FA,OtherVars) :-
1438 ( is_indexed_argument(FA,I) ->
1439 true
1440 ; nonvar(Arg) ->
1441 indexed_argument(FA,I)
1442 ; % var(Arg) ->
1443 term_variables(Args,ArgsVars),
1444 append(ArgsVars,OtherVars,RestVars),
1445 ( memberchk_eq(Arg,RestVars) ->
1446 indexed_argument(FA,I)
1447 ;
1448 true
1449 )
1450 ),
1451 J is I + 1,
1452 term_variables(Arg,NVars),
1453 append(NVars,OtherVars,NOtherVars),
1454 check_indexing(Args,J,FA,NOtherVars).
1456 check_specs_indexing([],_,[]).
1457 check_specs_indexing([Head|Heads],Variables,Specs) :-
1458 Specs = [Spec|RSpecs],
1459 term_variables(Heads,OtherVariables,Variables),
1460 check_spec_indexing(Head,OtherVariables,Spec),
1461 term_variables(Head,NVariables,Variables),
1462 check_specs_indexing(Heads,NVariables,RSpecs).
1464 check_spec_indexing(Head,OtherVariables,Spec) :-
1465 functor(Head,F,A),
1466 Spec = spec(F,A,ArgSpecs),
1467 Head =.. [_|Args],
1468 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1469 indexing_spec(F/A,[ArgSpecs]).
1471 check_args_spec_indexing([],_,_,[]).
1472 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1473 term_variables(Args,Variables,OtherVariables),
1474 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1475 ArgSpecs = [ArgSpec|RArgSpecs]
1476 ;
1477 ArgSpecs = RArgSpecs
1478 ),
1479 J is I + 1,
1480 term_variables(Arg,NOtherVariables,OtherVariables),
1481 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1483 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1484 ( var(Arg) ->
1485 memberchk_eq(Arg,Variables),
1486 ArgSpec = specinfo(I,any,[])
1487 ;
1488 functor(Arg,F,A),
1489 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1490 Arg =.. [_|Args],
1491 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1492 ).
1494 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1496 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1497 % Occurrences
1499 add_occurrences([]).
1500 add_occurrences([Rule|Rules]) :-
1501 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1502 add_occurrences(H1,IDs1,simplification,Nb),
1503 add_occurrences(H2,IDs2,propagation,Nb),
1504 add_occurrences(Rules).
1506 add_occurrences([],[],_,_).
1507 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1508 functor(H,F,A),
1509 FA = F/A,
1510 new_occurrence(FA,RuleNb,ID,Type),
1511 add_occurrences(Hs,IDs,Type,RuleNb).
1513 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1515 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1516 % Observation Analysis
1517 %
1518 % CLASSIFICATION
1519 %
1520 %
1521 %
1522 %
1523 %
1524 %
1526 :- chr_constraint observation_analysis/1.
1527 :- chr_option(mode, observation_analysis(+)).
1529 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1530 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1531 ( chr_pp_flag(store_in_guards, on) ->
1532 observation_analysis(RuleNb, Guard, guard, Cs)
1533 ;
1534 true
1535 ),
1536 observation_analysis(RuleNb, Body, body, Cs)
1538 pragma passive(Id).
1539 observation_analysis(_) <=> true.
1541 observation_analysis(RuleNb, Term, GB, Cs) :-
1542 ( all_spawned(RuleNb,GB) ->
1543 true
1544 ; var(Term) ->
1545 spawns_all(RuleNb,GB)
1546 ; Term = true ->
1547 true
1548 ; Term = fail ->
1549 true
1550 ; Term = '!' ->
1551 true
1552 ; Term = (T1,T2) ->
1553 observation_analysis(RuleNb,T1,GB,Cs),
1554 observation_analysis(RuleNb,T2,GB,Cs)
1555 ; Term = (T1;T2) ->
1556 observation_analysis(RuleNb,T1,GB,Cs),
1557 observation_analysis(RuleNb,T2,GB,Cs)
1558 ; Term = (T1->T2) ->
1559 observation_analysis(RuleNb,T1,GB,Cs),
1560 observation_analysis(RuleNb,T2,GB,Cs)
1561 ; Term = (\+ T) ->
1562 observation_analysis(RuleNb,T,GB,Cs)
1563 ; functor(Term,F,A), member(F/A,Cs) ->
1564 spawns(RuleNb,GB,F/A)
1565 ; Term = (_ = _) ->
1566 spawns_all_triggers(RuleNb,GB)
1567 ; Term = (_ is _) ->
1568 spawns_all_triggers(RuleNb,GB)
1569 ; builtin_binds_b(Term,Vars) ->
1570 ( Vars == [] ->
1571 true
1572 ;
1573 spawns_all_triggers(RuleNb,GB)
1574 )
1575 ;
1576 spawns_all(RuleNb,GB)
1577 ).
1579 :- chr_constraint spawns/3.
1580 :- chr_option(mode, spawns(+,+,+)).
1581 :- chr_type spawns_type ---> guard ; body.
1582 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1584 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1585 :- chr_option(mode, spawns_all(+,+)).
1586 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1587 :- chr_option(mode, spawns_all_triggers(+,+)).
1588 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1590 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1591 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1592 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1593 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1594 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1595 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1597 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1598 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1599 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1600 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1602 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1603 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1605 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1606 \
1607 spawns(RuleNb1,GB,C1)
1608 <=>
1609 \+ is_passive(RuleNb2,O)
1610 |
1611 spawns_all(RuleNb1,GB)
1612 pragma
1613 passive(Id).
1615 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1616 ==>
1617 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1618 \+ is_passive(RuleNb2,O), may_trigger(C1)
1619 |
1620 spawns_all_triggers_implies_spawns_all
1621 pragma
1622 passive(Id).
1624 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1625 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1626 spawns_all_triggers_implies_spawns_all \
1627 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1629 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1630 \
1631 spawns(RuleNb1,GB,C1)
1632 <=>
1633 may_trigger(C1),
1634 \+ is_passive(RuleNb2,O)
1635 |
1636 spawns_all_triggers(RuleNb1,GB)
1637 pragma
1638 passive(Id).
1640 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1641 spawns(RuleNb1,GB,C1)
1642 ==>
1643 \+ may_trigger(C1),
1644 \+ is_passive(RuleNb2,O)
1645 |
1646 spawns_all_triggers(RuleNb1,GB)
1647 pragma
1648 passive(Id).
1650 % a bit dangerous this rule: could start propagating too much too soon?
1651 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1652 spawns(RuleNb1,GB,C1)
1653 ==>
1654 RuleNb1 \== RuleNb2, C1 \== C2,
1655 \+ is_passive(RuleNb2,O)
1656 |
1657 spawns(RuleNb1,GB,C2)
1658 pragma
1659 passive(Id).
1661 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1662 spawns_all_triggers(RuleNb1,GB)
1663 ==>
1664 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1665 |
1666 spawns(RuleNb1,GB,C2)
1667 pragma
1668 passive(Id).
1671 :- chr_constraint all_spawned/2.
1672 :- chr_option(mode, all_spawned(+,+)).
1673 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1674 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1675 all_spawned(RuleNb,GB) <=> fail.
1678 % Overview of the supported queries:
1679 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1680 % only succeeds if the occurrence is observed by the
1681 % guard resp. body (depending on the last argument) of its rule
1682 % is_observed(+functor/artiy, +occurrence_number, -)
1683 % succeeds if the occurrence is observed by either the guard or
1684 % the body of its rule
1685 % NOTE: the last argument is NOT bound by this query
1686 %
1687 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1688 % succeeds if the given constraint is observed by the given
1689 % guard resp. body
1690 % do_is_observed(+functor/artiy,+rule_number)
1691 % succeeds if the given constraint is observed by the given
1692 % rule (either its guard or its body)
1695 is_observed(C,O) :-
1696 is_observed(C,O,_),
1697 ai_is_observed(C,O).
1699 is_stored_in_guard(C,RuleNb) :-
1700 chr_pp_flag(store_in_guards, on),
1701 do_is_observed(C,RuleNb,guard).
1703 :- chr_constraint is_observed/3.
1704 :- chr_option(mode, is_observed(+,+,+)).
1705 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1706 is_observed(_,_,_) <=> fail. % this will not happen in practice
1709 :- chr_constraint do_is_observed/3.
1710 :- chr_option(mode, do_is_observed(+,+,+)).
1711 :- chr_constraint do_is_observed/2.
1712 :- chr_option(mode, do_is_observed(+,+)).
1714 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1716 % (1) spawns_all
1717 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1718 % and some non-passive occurrence of some (possibly other) constraint
1719 % exists in a rule (could be same rule) with at least one occurrence of C
1721 spawns_all(RuleNb,GB),
1722 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1723 \
1724 do_is_observed(C,RuleNb,GB)
1725 <=>
1726 \+ is_passive(RuleNb2,O)
1727 |
1728 true.
1730 spawns_all(RuleNb,_),
1731 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1732 \
1733 do_is_observed(C,RuleNb)
1734 <=>
1735 \+ is_passive(RuleNb2,O)
1736 |
1737 true.
1739 % (2) spawns
1740 % a constraint C is observed if the GB of the rule it occurs in spawns a
1741 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1742 % as an occurrence of C
1744 spawns(RuleNb,GB,C2),
1745 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1746 \
1747 do_is_observed(C,RuleNb,GB)
1748 <=>
1749 \+ is_passive(RuleNb2,O)
1750 |
1751 true.
1753 spawns(RuleNb,_,C2),
1754 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1755 \
1756 do_is_observed(C,RuleNb)
1757 <=>
1758 \+ is_passive(RuleNb2,O)
1759 |
1760 true.
1762 % (3) spawns_all_triggers
1763 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1764 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1765 % exists in a rule (could be same rule) with at least one occurrence of C
1767 spawns_all_triggers(RuleNb,GB),
1768 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1769 \
1770 do_is_observed(C,RuleNb,GB)
1771 <=>
1772 \+ is_passive(RuleNb2,O), may_trigger(C2)
1773 |
1774 true.
1776 spawns_all_triggers(RuleNb,_),
1777 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1778 \
1779 do_is_observed(C,RuleNb)
1780 <=>
1781 \+ is_passive(RuleNb2,O), may_trigger(C2)
1782 |
1783 true.
1785 % (4) conservativeness
1786 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1787 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1792 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1794 %%
1795 %% Generated predicates
1796 %% attach_$CONSTRAINT
1797 %% attach_increment
1798 %% detach_$CONSTRAINT
1799 %% attr_unify_hook
1801 %% attach_$CONSTRAINT
1802 generate_attach_detach_a_constraint_all([],[]).
1803 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1804 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1805 generate_attach_a_constraint(Constraint,Clauses1),
1806 generate_detach_a_constraint(Constraint,Clauses2)
1807 ;
1808 Clauses1 = [],
1809 Clauses2 = []
1810 ),
1811 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1812 append([Clauses1,Clauses2,Clauses3],Clauses).
1814 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1815 generate_attach_a_constraint_nil(Constraint,Clause1),
1816 generate_attach_a_constraint_cons(Constraint,Clause2).
1818 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1819 make_name('attach_',FA,Name),
1820 Atom =.. [Name,Vars,Susp].
1822 generate_attach_a_constraint_nil(FA,Clause) :-
1823 Clause = (Head :- true),
1824 attach_constraint_atom(FA,[],_,Head).
1826 generate_attach_a_constraint_cons(FA,Clause) :-
1827 Clause = (Head :- Body),
1828 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1829 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1830 Body = ( AttachBody, Subscribe, RecursiveCall ),
1831 get_max_constraint_index(N),
1832 ( N == 1 ->
1833 generate_attach_body_1(FA,Var,Susp,AttachBody)
1834 ;
1835 generate_attach_body_n(FA,Var,Susp,AttachBody)
1836 ),
1837 % SWI-Prolog specific code
1838 chr_pp_flag(solver_events,NMod),
1839 ( NMod \== none ->
1840 Args = [[Var|_],Susp],
1841 get_target_module(Mod),
1842 use_auxiliary_predicate(run_suspensions),
1843 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1844 ;
1845 Subscribe = true
1846 ).
1848 generate_attach_body_1(FA,Var,Susp,Body) :-
1849 get_target_module(Mod),
1850 Body =
1851 ( get_attr(Var, Mod, Susps) ->
1852 put_attr(Var, Mod, [Susp|Susps])
1853 ;
1854 put_attr(Var, Mod, [Susp])
1855 ).
1857 generate_attach_body_n(F/A,Var,Susp,Body) :-
1858 get_constraint_index(F/A,Position),
1859 get_max_constraint_index(Total),
1860 get_target_module(Mod),
1861 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1862 singleton_attr(Total,Susp,Position,NewAttr3),
1863 Body =
1864 ( get_attr(Var,Mod,TAttr) ->
1865 AddGoal,
1866 put_attr(Var,Mod,NTAttr)
1867 ;
1868 put_attr(Var,Mod,NewAttr3)
1869 ), !.
1871 %% detach_$CONSTRAINT
1872 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1873 generate_detach_a_constraint_nil(Constraint,Clause1),
1874 generate_detach_a_constraint_cons(Constraint,Clause2).
1876 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1877 make_name('detach_',FA,Name),
1878 Atom =.. [Name,Vars,Susp].
1880 generate_detach_a_constraint_nil(FA,Clause) :-
1881 Clause = ( Head :- true),
1882 detach_constraint_atom(FA,[],_,Head).
1884 generate_detach_a_constraint_cons(FA,Clause) :-
1885 Clause = (Head :- Body),
1886 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1887 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1888 Body = ( DetachBody, RecursiveCall ),
1889 get_max_constraint_index(N),
1890 ( N == 1 ->
1891 generate_detach_body_1(FA,Var,Susp,DetachBody)
1892 ;
1893 generate_detach_body_n(FA,Var,Susp,DetachBody)
1894 ).
1896 generate_detach_body_1(FA,Var,Susp,Body) :-
1897 get_target_module(Mod),
1898 Body =
1899 ( get_attr(Var,Mod,Susps) ->
1900 'chr sbag_del_element'(Susps,Susp,NewSusps),
1901 ( NewSusps == [] ->
1902 del_attr(Var,Mod)
1903 ;
1904 put_attr(Var,Mod,NewSusps)
1905 )
1906 ;
1907 true
1908 ).
1910 generate_detach_body_n(F/A,Var,Susp,Body) :-
1911 get_constraint_index(F/A,Position),
1912 get_max_constraint_index(Total),
1913 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1914 get_target_module(Mod),
1915 Body =
1916 ( get_attr(Var,Mod,TAttr) ->
1917 RemGoal
1918 ;
1919 true
1920 ), !.
1922 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1923 %-------------------------------------------------------------------------------
1924 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1925 :- chr_constraint generate_indexed_variables_body/4.
1926 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1927 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1928 %-------------------------------------------------------------------------------
1929 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1930 get_indexing_spec(F/A,Specs),
1931 ( chr_pp_flag(term_indexing,on) ->
1932 spectermvars(Specs,Args,F,A,Body,Vars)
1933 ;
1934 get_constraint_type_det(F/A,ArgTypes),
1935 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1936 ( MaybeBody == empty ->
1937 Body = true,
1938 Vars = []
1939 ; N == 0 ->
1940 ( Args = [Term] ->
1941 true
1942 ;
1943 Term =.. [term|Args]
1944 ),
1945 Body = term_variables(Term,Vars)
1946 ;
1947 MaybeBody = Body
1948 )
1949 ).
1950 generate_indexed_variables_body(FA,_,_,_) <=>
1951 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1952 %===============================================================================
1954 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1955 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1956 J is I + 1,
1957 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1958 ( Mode == (?),
1959 is_indexed_argument(FA,I) ->
1960 ( atomic_type(Type) ->
1961 Body =
1962 (
1963 ( var(V) ->
1964 Vars = [V|Tail]
1965 ;
1966 Vars = Tail
1967 ),
1968 Continuation
1969 ),
1970 ( RBody == empty ->
1971 Continuation = true, Tail = []
1972 ;
1973 Continuation = RBody
1974 )
1975 ;
1976 ( RBody == empty ->
1977 Body = term_variables(V,Vars)
1978 ;
1979 Body = (term_variables(V,Vars,Tail),RBody)
1980 )
1981 ),
1982 N = M
1983 ; Mode == (-), is_indexed_argument(FA,I) ->
1984 ( RBody == empty ->
1985 Body = (Vars = [V])
1986 ;
1987 Body = (Vars = [V|Tail],RBody)
1988 ),
1989 N is M + 1
1990 ;
1991 Vars = Tail,
1992 Body = RBody,
1993 N is M + 1
1994 ).
1995 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1996 % EXPERIMENTAL
1997 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1998 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2000 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2001 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2002 Goal = (ArgGoal,RGoal),
2003 argspecs(Specs,I,TempArgSpecs,RSpecs),
2004 merge_argspecs(TempArgSpecs,ArgSpecs),
2005 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2006 J is I + 1,
2007 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2009 argspecs([],_,[],[]).
2010 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2011 argspecs(Rest,I,ArgSpecs,RestSpecs).
2012 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2013 ( I == J ->
2014 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2015 ( Specs = [] ->
2016 RRestSpecs = RestSpecs
2017 ;
2018 RestSpecs = [Specs|RRestSpecs]
2019 )
2020 ;
2021 ArgSpecs = RArgSpecs,
2022 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2023 ),
2024 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2026 merge_argspecs(In,Out) :-
2027 sort(In,Sorted),
2028 merge_argspecs_(Sorted,Out).
2030 merge_argspecs_([],[]).
2031 merge_argspecs_([X],R) :- !, R = [X].
2032 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2033 ( (F1 == any ; F2 == any) ->
2034 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2035 ; F1 == F2 ->
2036 append(A1,A2,A),
2037 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2038 ;
2039 R = [specinfo(I,F1,A1)|RR],
2040 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2041 ).
2043 arggoal(List,Arg,Goal,L,T) :-
2044 ( List == [] ->
2045 L = T,
2046 Goal = true
2047 ; List = [specinfo(_,any,_)] ->
2048 Goal = term_variables(Arg,L,T)
2049 ;
2050 Goal =
2051 ( var(Arg) ->
2052 L = [Arg|T]
2053 ;
2054 Cases
2055 ),
2056 arggoal_cases(List,Arg,L,T,Cases)
2057 ).
2059 arggoal_cases([],_,L,T,L=T).
2060 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2061 ( ArgSpecs == [] ->
2062 Cases = RCases
2063 ; ArgSpecs == [[]] ->
2064 Cases = RCases
2065 ; FA = F/A ->
2066 Cases = (Case ; RCases),
2067 functor(Term,F,A),
2068 Term =.. [_|Args],
2069 Case = (Arg = Term -> ArgsGoal),
2070 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2071 ),
2072 arggoal_cases(Rest,Arg,L,T,RCases).
2073 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2075 generate_extra_clauses(Constraints,List) :-
2076 generate_activate_clauses(Constraints,List,Tail0),
2077 generate_remove_clauses(Constraints,Tail0,Tail1),
2078 generate_allocate_clauses(Constraints,Tail1,Tail2),
2079 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2080 generate_novel_production(Tail3,Tail4),
2081 generate_extend_history(Tail4,Tail5),
2082 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2083 generate_empty_named_history_initialisations(Tail6,Tail7),
2084 Tail7 = [].
2086 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2087 % remove_constraint_internal/[1/3]
2089 generate_remove_clauses([],List,List).
2090 generate_remove_clauses([C|Cs],List,Tail) :-
2091 generate_remove_clause(C,List,List1),
2092 generate_remove_clauses(Cs,List1,Tail).
2094 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2095 uses_state(Constraint,removed),
2096 ( chr_pp_flag(inline_insertremove,off) ->
2097 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2098 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2099 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2100 ;
2101 delay_phase_end(validate_store_type_assumptions,
2102 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2103 )
2104 ).
2106 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2107 make_name('$remove_constraint_internal_',Constraint,Name),
2108 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2109 Goal =.. [Name, Susp,Delete]
2110 ;
2111 Goal =.. [Name,Susp,Agenda,Delete]
2112 ).
2114 generate_remove_clause(Constraint,List,Tail) :-
2115 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2116 List = [RemoveClause|Tail],
2117 RemoveClause = (Head :- RemoveBody),
2118 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2119 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2120 ;
2121 List = Tail
2122 ).
2124 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2125 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2126 ( Role == active ->
2127 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2128 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2129 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2130 ; Role == partner ->
2131 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2132 GetStateValue = true,
2133 MaybeDelete = DeleteYes
2134 ),
2135 RemoveBody =
2136 (
2137 GetState,
2138 GetStateValue,
2139 UpdateState,
2140 MaybeDelete
2141 )
2142 ;
2143 static_suspension_term(Constraint,Susp2),
2144 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2145 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2146 ( chr_pp_flag(debugable,on) ->
2147 Constraint = Functor / _,
2148 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2149 ;
2150 true
2151 ),
2152 ( Role == active ->
2153 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2154 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2155 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2156 ; Role == partner ->
2157 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2158 GetStateValue = true,
2159 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2160 ),
2161 RemoveBody =
2162 (
2163 Susp = Susp2,
2164 GetStateValue,
2165 UpdateState,
2166 MaybeDelete
2167 )
2168 ).
2170 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2171 % activate_constraint/4
2173 generate_activate_clauses([],List,List).
2174 generate_activate_clauses([C|Cs],List,Tail) :-
2175 generate_activate_clause(C,List,List1),
2176 generate_activate_clauses(Cs,List1,Tail).
2178 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2179 ( chr_pp_flag(inline_insertremove,off) ->
2180 use_auxiliary_predicate(activate_constraint,Constraint),
2181 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2182 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2183 ;
2184 delay_phase_end(validate_store_type_assumptions,
2185 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2186 )
2187 ).
2189 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2190 make_name('$activate_constraint_',Constraint,Name),
2191 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2192 Goal =.. [Name,Store, Susp]
2193 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2194 Goal =.. [Name,Store, Susp, Generation]
2195 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2196 Goal =.. [Name,Store, Vars, Susp, Generation]
2197 ;
2198 Goal =.. [Name,Store, Vars, Susp]
2199 ).
2201 generate_activate_clause(Constraint,List,Tail) :-
2202 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2203 List = [Clause|Tail],
2204 Clause = (Head :- Body),
2205 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2206 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2207 ;
2208 List = Tail
2209 ).
2211 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2212 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2213 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2214 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2215 ;
2216 GenerationHandling = true
2217 ),
2218 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2219 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2220 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2221 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2222 ;
2223 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2224 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2225 ( chr_pp_flag(guard_locks,off) ->
2226 NoneLocked = true
2227 ;
2228 NoneLocked = 'chr none_locked'( Vars)
2229 ),
2230 if_used_state(Constraint,not_stored_yet,
2231 ( State == not_stored_yet ->
2232 ArgumentsGoal,
2233 IndexedVariablesBody,
2234 NoneLocked,
2235 StoreYes
2236 ;
2237 % Vars = [],
2238 StoreNo
2239 ),
2240 % (Vars = [],StoreNo),StoreVarsGoal)
2241 StoreNo,StoreVarsGoal)
2242 ),
2243 Body =
2244 (
2245 GetState,
2246 GetStateValue,
2247 UpdateState,
2248 GenerationHandling,
2249 StoreVarsGoal
2250 ).
2251 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2252 % allocate_constraint/4
2254 generate_allocate_clauses([],List,List).
2255 generate_allocate_clauses([C|Cs],List,Tail) :-
2256 generate_allocate_clause(C,List,List1),
2257 generate_allocate_clauses(Cs,List1,Tail).
2259 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2260 uses_state(Constraint,not_stored_yet),
2261 ( chr_pp_flag(inline_insertremove,off) ->
2262 use_auxiliary_predicate(allocate_constraint,Constraint),
2263 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2264 ;
2265 Goal = (Susp = Suspension, Goal0),
2266 delay_phase_end(validate_store_type_assumptions,
2267 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2268 )
2269 ).
2271 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2272 make_name('$allocate_constraint_',Constraint,Name),
2273 Goal =.. [Name,Susp|Args].
2275 generate_allocate_clause(Constraint,List,Tail) :-
2276 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2277 List = [Clause|Tail],
2278 Clause = (Head :- Body),
2279 Constraint = _/A,
2280 length(Args,A),
2281 allocate_constraint_atom(Constraint,Susp,Args,Head),
2282 allocate_constraint_body(Constraint,Susp,Args,Body)
2283 ;
2284 List = Tail
2285 ).
2287 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2288 static_suspension_term(Constraint,Suspension),
2289 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2290 ( chr_pp_flag(debugable,on) ->
2291 Constraint = Functor / _,
2292 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2293 ;
2294 true
2295 ),
2296 ( chr_pp_flag(debugable,on) ->
2297 ( may_trigger(Constraint) ->
2298 append(Args,[Susp],VarsSusp),
2299 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2300 get_target_module(Mod),
2301 Continuation = Mod : ContinuationGoal
2302 ;
2303 Continuation = true
2304 ),
2305 Init = (Susp = Suspension),
2306 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2307 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2308 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2309 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2310 Susp = Suspension, Init = true, CreateContinuation = true
2311 ;
2312 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2313 ),
2314 ( uses_history(Constraint) ->
2315 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2316 ;
2317 CreateHistory = true
2318 ),
2319 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2320 ( has_suspension_field(Constraint,id) ->
2321 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2322 gen_id(Id,GenID)
2323 ;
2324 GenID = true
2325 ),
2326 Body =
2327 (
2328 Init,
2329 CreateContinuation,
2330 CreateGeneration,
2331 CreateHistory,
2332 CreateState,
2333 GenID
2334 ).
2336 gen_id(Id,'chr gen_id'(Id)).
2337 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2338 % insert_constraint_internal
2340 generate_insert_constraint_internal_clauses([],List,List).
2341 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2342 generate_insert_constraint_internal_clause(C,List,List1),
2343 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2345 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2346 ( chr_pp_flag(inline_insertremove,off) ->
2347 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2348 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2349 ;
2350 delay_phase_end(validate_store_type_assumptions,
2351 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2352 )
2353 ).
2356 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2357 insert_constraint_internal_constraint_name(Constraint,Name),
2358 ( chr_pp_flag(debugable,on) ->
2359 Goal =.. [Name, Vars, Self, Closure | Args]
2360 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2361 Goal =.. [Name,Self | Args]
2362 ;
2363 Goal =.. [Name,Vars, Self | Args]
2364 ).
2366 insert_constraint_internal_constraint_name(Constraint,Name) :-
2367 make_name('$insert_constraint_internal_',Constraint,Name).
2369 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2370 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2371 List = [Clause|Tail],
2372 Clause = (Head :- Body),
2373 Constraint = _/A,
2374 length(Args,A),
2375 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2376 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2377 ;
2378 List = Tail
2379 ).
2382 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2383 static_suspension_term(Constraint,Suspension),
2384 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2385 ( chr_pp_flag(debugable,on) ->
2386 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2387 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2388 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2389 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2390 ;
2391 CreateGeneration = true
2392 ),
2393 ( chr_pp_flag(debugable,on) ->
2394 Constraint = Functor / _,
2395 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2396 ;
2397 true
2398 ),
2399 ( uses_history(Constraint) ->
2400 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2401 ;
2402 CreateHistory = true
2403 ),
2404 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2405 List = [Clause|Tail],
2406 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2407 suspension_term_base_fields(Constraint,BaseFields),
2408 ( has_suspension_field(Constraint,id) ->
2409 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2410 gen_id(Id,GenID)
2411 ;
2412 GenID = true
2413 ),
2414 Body =
2415 (
2416 Susp = Suspension,
2417 CreateState,
2418 CreateGeneration,
2419 CreateHistory,
2420 GenID
2421 )
2422 ;
2423 ( has_suspension_field(Constraint,id) ->
2424 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2425 gen_id(Id,GenID)
2426 ;
2427 GenID = true
2428 ),
2429 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2430 ( chr_pp_flag(guard_locks,off) ->
2431 NoneLocked = true
2432 ;
2433 NoneLocked = 'chr none_locked'( Vars)
2434 ),
2435 Body =
2436 (
2437 Susp = Suspension,
2438 IndexedVariablesBody,
2439 NoneLocked,
2440 CreateState,
2441 CreateGeneration,
2442 CreateHistory,
2443 GenID
2444 )
2445 ).
2447 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2448 % novel_production/2
2450 generate_novel_production(List,Tail) :-
2451 ( is_used_auxiliary_predicate(novel_production) ->
2452 List = [Clause|Tail],
2453 Clause =
2454 (
2455 '$novel_production'( Self, Tuple) :-
2456 % arg( 3, Self, Ref), % ARGXXX
2457 % 'chr get_mutable'( History, Ref),
2458 arg( 3, Self, History), % ARGXXX
2459 ( hprolog:get_ds( Tuple, History, _) ->
2460 fail
2461 ;
2462 true
2463 )
2464 )
2465 ;
2466 List = Tail
2467 ).
2469 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2470 % extend_history/2
2472 generate_extend_history(List,Tail) :-
2473 ( is_used_auxiliary_predicate(extend_history) ->
2474 List = [Clause|Tail],
2475 Clause =
2476 (
2477 '$extend_history'( Self, Tuple) :-
2478 % arg( 3, Self, Ref), % ARGXXX
2479 % 'chr get_mutable'( History, Ref),
2480 arg( 3, Self, History), % ARGXXX
2481 hprolog:put_ds( Tuple, History, x, NewHistory),
2482 setarg( 3, Self, NewHistory) % ARGXXX
2483 )
2484 ;
2485 List = Tail
2486 ).
2488 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2489 %
2490 :- chr_constraint
2491 empty_named_history_initialisations/2,
2492 generate_empty_named_history_initialisation/1,
2493 find_empty_named_histories/0.
2495 generate_empty_named_history_initialisations(List, Tail) :-
2496 empty_named_history_initialisations(List, Tail),
2497 find_empty_named_histories.
2499 find_empty_named_histories, history(_, Name, []) ==>
2500 generate_empty_named_history_initialisation(Name).
2502 generate_empty_named_history_initialisation(Name) \
2503 generate_empty_named_history_initialisation(Name) <=> true.
2504 generate_empty_named_history_initialisation(Name) \
2505 empty_named_history_initialisations(List, Tail) # Passive
2506 <=>
2507 empty_named_history_global_variable(Name, GlobalVariable),
2508 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2509 empty_named_history_initialisations(Rest, Tail)
2510 pragma passive(Passive).
2512 find_empty_named_histories \
2513 generate_empty_named_history_initialisation(_) # Passive <=> true
2514 pragma passive(Passive).
2516 find_empty_named_histories,
2517 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2518 pragma passive(Passive).
2520 find_empty_named_histories <=>
2521 chr_error(internal, 'find_empty_named_histories was not removed', []).
2524 empty_named_history_global_variable(Name, GlobalVariable) :-
2525 atom_concat('chr empty named history ', Name, GlobalVariable).
2527 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2528 empty_named_history_global_variable(Name, GlobalVariable).
2530 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2531 empty_named_history_global_variable(Name, GlobalVariable).
2534 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2535 % run_suspensions/2
2537 generate_run_suspensions_clauses([],List,List).
2538 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2539 generate_run_suspensions_clause(C,List,List1),
2540 generate_run_suspensions_clauses(Cs,List1,Tail).
2542 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2543 make_name('$run_suspensions_',Constraint,Name),
2544 Goal =.. [Name,Suspensions].
2546 generate_run_suspensions_clause(Constraint,List,Tail) :-
2547 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2548 List = [Clause1,Clause2|Tail],
2549 run_suspensions_goal(Constraint,[],Clause1),
2550 ( chr_pp_flag(debugable,on) ->
2551 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2552 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2553 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2554 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2555 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2556 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2557 Clause2 =
2558 (
2559 Clause2Head :-
2560 GetState,
2561 GetStateValue,
2562 ( State==active ->
2563 UpdateState,
2564 GetGeneration,
2565 GetGenerationValue,
2566 Generation is Gen+1,
2567 UpdateGeneration,
2568 GetContinuation,
2569 (
2570 'chr debug_event'(wake(Suspension)),
2571 call(Continuation)
2572 ;
2573 'chr debug_event'(fail(Suspension)), !,
2574 fail
2575 ),
2576 (
2577 'chr debug_event'(exit(Suspension))
2578 ;
2579 'chr debug_event'(redo(Suspension)),
2580 fail
2581 ),
2582 GetPost,
2583 GetPostValue,
2584 ( Post==triggered ->
2585 UpdatePost % catching constraints that did not do anything
2586 ;
2587 true
2588 )
2589 ;
2590 true
2591 ),
2592 Clause2Recursion
2593 )
2594 ;
2595 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2596 static_suspension_term(Constraint,SuspensionTerm),
2597 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2598 append(Arguments,[Suspension],VarsSusp),
2599 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2600 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2601 ( uses_field(Constraint,generation) ->
2602 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2603 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2604 ;
2605 GenerationHandling = true
2606 ),
2607 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2608 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2609 if_used_state(Constraint,removed,
2610 ( GetState,
2611 ( State==active
2612 -> ReactivateConstraint
2613 ; true)
2614 ),ReactivateConstraint,CondReactivate),
2615 ReactivateConstraint =
2616 (
2617 UpdateState,
2618 GenerationHandling,
2619 Continuation,
2620 GetPostState,
2621 ( Post==triggered ->
2622 UpdatePostState % catching constraints that did not do anything
2623 ;
2624 true
2625 )
2626 ),
2627 Clause2 =
2628 (
2629 Clause2Head :-
2630 Suspension = SuspensionTerm,
2631 CondReactivate,
2632 Clause2Recursion
2633 )
2634 )
2635 ;
2636 List = Tail
2637 ).
2639 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2641 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2642 generate_attach_increment(Clauses) :-
2643 get_max_constraint_index(N),
2644 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2645 Clauses = [Clause1,Clause2],
2646 generate_attach_increment_empty(Clause1),
2647 ( N == 1 ->
2648 generate_attach_increment_one(Clause2)
2649 ;
2650 generate_attach_increment_many(N,Clause2)
2651 )
2652 ;
2653 Clauses = []
2654 ).
2656 generate_attach_increment_empty((attach_increment([],_) :- true)).
2658 generate_attach_increment_one(Clause) :-
2659 Head = attach_increment([Var|Vars],Susps),
2660 get_target_module(Mod),
2661 ( chr_pp_flag(guard_locks,off) ->
2662 NotLocked = true
2663 ;
2664 NotLocked = 'chr not_locked'( Var)
2665 ),
2666 Body =
2667 (
2668 NotLocked,
2669 ( get_attr(Var,Mod,VarSusps) ->
2670 sort(VarSusps,SortedVarSusps),
2671 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2672 put_attr(Var,Mod,MergedSusps)
2673 ;
2674 put_attr(Var,Mod,Susps)
2675 ),
2676 attach_increment(Vars,Susps)
2677 ),
2678 Clause = (Head :- Body).
2680 generate_attach_increment_many(N,Clause) :-
2681 Head = attach_increment([Var|Vars],TAttr1),
2682 % writeln(merge_attributes_1_before),
2683 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2684 % writeln(merge_attributes_1_after),
2685 get_target_module(Mod),
2686 ( chr_pp_flag(guard_locks,off) ->
2687 NotLocked = true
2688 ;
2689 NotLocked = 'chr not_locked'( Var)
2690 ),
2691 Body =
2692 (
2693 NotLocked,
2694 ( get_attr(Var,Mod,TAttr2) ->
2695 MergeGoal,
2696 put_attr(Var,Mod,Attr)
2697 ;
2698 put_attr(Var,Mod,TAttr1)
2699 ),
2700 attach_increment(Vars,TAttr1)
2701 ),
2702 Clause = (Head :- Body).
2704 %% attr_unify_hook
2705 generate_attr_unify_hook(Clauses) :-
2706 get_max_constraint_index(N),
2707 ( N == 0 ->
2708 Clauses = []
2709 ;
2710 ( N == 1 ->
2711 generate_attr_unify_hook_one(Clauses)
2712 ;
2713 generate_attr_unify_hook_many(N,Clauses)
2714 )
2715 ).
2717 generate_attr_unify_hook_one([Clause]) :-
2718 Head = attr_unify_hook(Susps,Other),
2719 get_target_module(Mod),
2720 get_indexed_constraint(1,C),
2721 ( get_store_type(C,ST),
2722 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2723 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2724 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2725 ( atomic_types_suspended_constraint(C) ->
2726 SortGoal1 = true,
2727 SortedSusps = Susps,
2728 SortGoal2 = true,
2729 SortedOtherSusps = OtherSusps,
2730 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2731 NonvarBody = true
2732 ;
2733 SortGoal1 = sort(Susps, SortedSusps),
2734 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2735 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2736 use_auxiliary_predicate(attach_increment),
2737 NonvarBody =
2738 ( compound(Other) ->
2739 term_variables(Other,OtherVars),
2740 attach_increment(OtherVars, SortedSusps)
2741 ;
2742 true
2743 )
2744 ),
2745 Body =
2746 (
2747 SortGoal1,
2748 ( var(Other) ->
2749 ( get_attr(Other,Mod,OtherSusps) ->
2750 SortGoal2,
2751 MergeGoal,
2752 put_attr(Other,Mod,NewSusps),
2753 WakeNewSusps
2754 ;
2755 put_attr(Other,Mod,SortedSusps),
2756 WakeSusps
2757 )
2758 ;
2759 NonvarBody,
2760 WakeSusps
2761 )
2762 ),
2763 Clause = (Head :- Body)
2764 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2765 make_run_suspensions(List,List,WakeNewSusps),
2766 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2767 Body =
2768 ( get_attr(Other,Mod,OtherSusps) ->
2769 MergeGoal,
2770 WakeNewSusps
2771 ;
2772 put_attr(Other,Mod,Susps)
2773 ),
2774 Clause = (Head :- Body)
2775 ).
2778 generate_attr_unify_hook_many(N,[Clause]) :-
2779 chr_pp_flag(dynattr,off), !,
2780 Head = attr_unify_hook(Attr,Other),
2781 get_target_module(Mod),
2782 make_attr(N,Mask,SuspsList,Attr),
2783 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2784 list2conj(SortGoalList,SortGoals),
2785 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2786 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2787 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2788 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2789 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2790 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2791 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2792 NonvarBody = true
2793 ;
2794 use_auxiliary_predicate(attach_increment),
2795 NonvarBody =
2796 ( compound(Other) ->
2797 term_variables(Other,OtherVars),
2798 attach_increment(OtherVars,SortedAttr)
2799 ;
2800 true
2801 )
2802 ),
2803 Body =
2804 (
2805 SortGoals,
2806 ( var(Other) ->
2807 ( get_attr(Other,Mod,TOtherAttr) ->
2808 MergeGoal,
2809 put_attr(Other,Mod,MergedAttr),
2810 WakeMergedSusps
2811 ;
2812 put_attr(Other,Mod,SortedAttr),
2813 WakeSortedSusps
2814 )
2815 ;
2816 NonvarBody,
2817 WakeSortedSusps
2818 )
2819 ),
2820 Clause = (Head :- Body).
2822 % NEW
2823 generate_attr_unify_hook_many(N,Clauses) :-
2824 Head = attr_unify_hook(Attr,Other),
2825 get_target_module(Mod),
2826 normalize_attr(Attr,NormalGoal,NormalAttr),
2827 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2828 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2829 make_run_suspensions(N),
2830 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2831 NonvarBody = true
2832 ;
2833 use_auxiliary_predicate(attach_increment),
2834 NonvarBody =
2835 ( compound(Other) ->
2836 term_variables(Other,OtherVars),
2837 attach_increment(OtherVars,NormalAttr)
2838 ;
2839 true
2840 )
2841 ),
2842 Body =
2843 (
2844 NormalGoal,
2845 ( var(Other) ->
2846 ( get_attr(Other,Mod,OtherAttr) ->
2847 NormalOtherGoal,
2848 MergeGoal,
2849 put_attr(Other,Mod,MergedAttr),
2850 '$dispatch_run_suspensions'(MergedAttr)
2851 ;
2852 put_attr(Other,Mod,NormalAttr),
2853 '$dispatch_run_suspensions'(NormalAttr)
2854 )
2855 ;
2856 NonvarBody,
2857 '$dispatch_run_suspensions'(NormalAttr)
2858 )
2859 ),
2860 Clause = (Head :- Body),
2861 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2862 DispatchList1 = ('$dispatch_run_suspensions'([])),
2863 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2864 run_suspensions_dispatchers(N,[],Dispatchers).
2866 % NEW
2867 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2868 ( N > 0 ->
2869 get_indexed_constraint(N,C),
2870 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2871 ( may_trigger(C) ->
2872 run_suspensions_goal(C,List,Body)
2873 ;
2874 Body = true
2875 ),
2876 M is N - 1,
2877 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2878 ;
2879 Dispatchers = Acc
2880 ).
2882 % NEW
2883 make_run_suspensions(N) :-
2884 ( N > 0 ->
2885 ( get_indexed_constraint(N,C),
2886 may_trigger(C) ->
2887 use_auxiliary_predicate(run_suspensions,C)
2888 ;
2889 true
2890 ),
2891 M is N - 1,
2892 make_run_suspensions(M)
2893 ;
2894 true
2895 ).
2897 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2898 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2900 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2901 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2902 use_auxiliary_predicate(run_suspensions,C),
2903 ( wakes_partially(C) ->
2904 run_suspensions_goal(C,OneSusps,Goal)
2905 ;
2906 run_suspensions_goal(C,AllSusps,Goal)
2907 )
2908 ;
2909 Goal = true
2910 ).
2912 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2913 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2915 make_run_suspensions_loop([],[],_,true).
2916 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2917 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2918 J is I + 1,
2919 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2921 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2922 % $insert_in_store_F/A
2923 % $delete_from_store_F/A
2925 generate_insert_delete_constraints([],[]).
2926 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2927 ( is_stored(FA) ->
2928 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2929 ;
2930 Clauses = RestClauses
2931 ),
2932 generate_insert_delete_constraints(Rest,RestClauses).
2934 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2935 insert_constraint_clause(FA,Clauses,RestClauses1),
2936 delete_constraint_clause(FA,RestClauses1,RestClauses).
2938 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2939 % insert_in_store
2941 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2942 ( chr_pp_flag(inline_insertremove,off) ->
2943 use_auxiliary_predicate(insert_in_store,FA),
2944 insert_constraint_atom(FA,Susp,Goal)
2945 ;
2946 delay_phase_end(validate_store_type_assumptions,
2947 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2948 insert_constraint_direct_used_vars(UsedVars,Vars)
2949 )
2950 )
2951 ).
2953 insert_constraint_direct_used_vars([],_).
2954 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2955 nth1(Index,Vars,Var),
2956 insert_constraint_direct_used_vars(Rest,Vars).
2958 insert_constraint_atom(FA,Susp,Call) :-
2959 make_name('$insert_in_store_',FA,Functor),
2960 Call =.. [Functor,Susp].
2962 insert_constraint_clause(C,Clauses,RestClauses) :-
2963 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2964 Clauses = [Clause|RestClauses],
2965 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2966 insert_constraint_atom(C,Susp,Head),
2967 insert_constraint_body(C,Susp,UsedVars,Body),
2968 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2969 ( chr_pp_flag(store_counter,on) ->
2970 InsertCounterInc = '$insert_counter_inc'
2971 ;
2972 InsertCounterInc = true
2973 )
2974 ;
2975 Clauses = RestClauses
2976 ).
2978 insert_constraint_used_vars([],_,_,true).
2979 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2980 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2981 insert_constraint_used_vars(Rest,C,Susp,Goals).
2983 insert_constraint_body(C,Susp,UsedVars,Body) :-
2984 get_store_type(C,StoreType),
2985 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2987 insert_constraint_body(default,C,Susp,[],Body) :-
2988 global_list_store_name(C,StoreName),
2989 make_get_store_goal(StoreName,Store,GetStoreGoal),
2990 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2991 ( chr_pp_flag(debugable,on) ->
2992 Cell = [Susp|Store],
2993 Body =
2994 (
2995 GetStoreGoal,
2996 UpdateStoreGoal
2997 )
2998 ;
2999 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3000 Body =
3001 (
3002 GetStoreGoal,
3003 Cell = [Susp|Store],
3004 UpdateStoreGoal,
3005 ( Store = [NextSusp|_] ->
3006 SetGoal
3007 ;
3008 true
3009 )
3010 )
3011 ).
3012 % get_target_module(Mod),
3013 % get_max_constraint_index(Total),
3014 % ( Total == 1 ->
3015 % generate_attach_body_1(C,Store,Susp,AttachBody)
3016 % ;
3017 % generate_attach_body_n(C,Store,Susp,AttachBody)
3018 % ),
3019 % Body =
3020 % (
3021 % 'chr default_store'(Store),
3022 % AttachBody
3023 % ).
3024 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3025 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3026 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3027 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3028 sort_out_used_vars(MixedUsedVars,UsedVars).
3029 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3030 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3031 constants_store_index_name(C,Index,IndexName),
3032 IndexLookup =.. [IndexName,Key,StoreName],
3033 Body =
3034 ( IndexLookup ->
3035 nb_getval(StoreName,Store),
3036 b_setval(StoreName,[Susp|Store])
3037 ;
3038 true
3039 ).
3040 insert_constraint_body(ground_constants(Index,_),C,Susp,UsedVars,Body) :-
3041 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3042 constants_store_index_name(C,Index,IndexName),
3043 IndexLookup =.. [IndexName,Key,StoreName],
3044 Body =
3045 ( IndexLookup ->
3046 nb_getval(StoreName,Store),
3047 b_setval(StoreName,[Susp|Store])
3048 ;
3049 true
3050 ).
3051 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3052 global_ground_store_name(C,StoreName),
3053 make_get_store_goal(StoreName,Store,GetStoreGoal),
3054 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3055 ( chr_pp_flag(debugable,on) ->
3056 Cell = [Susp|Store],
3057 Body =
3058 (
3059 GetStoreGoal,
3060 UpdateStoreGoal
3061 )
3062 ;
3063 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3064 Body =
3065 (
3066 GetStoreGoal,
3067 Cell = [Susp|Store],
3068 UpdateStoreGoal,
3069 ( Store = [NextSusp|_] ->
3070 SetGoal
3071 ;
3072 true
3073 )
3074 )
3075 ).
3076 % global_ground_store_name(C,StoreName),
3077 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3078 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3079 % Body =
3080 % (
3081 % GetStoreGoal, % nb_getval(StoreName,Store),
3082 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3083 % ).
3084 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3085 % TODO: generalize to more than one !!!
3086 get_target_module(Module),
3087 Body = ( get_attr(Variable,Module,AssocStore) ->
3088 insert_assoc_store(AssocStore,Key,Susp)
3089 ;
3090 new_assoc_store(AssocStore),
3091 put_attr(Variable,Module,AssocStore),
3092 insert_assoc_store(AssocStore,Key,Susp)
3093 ).
3095 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3096 global_singleton_store_name(C,StoreName),
3097 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3098 Body =
3099 (
3100 UpdateStoreGoal
3101 ).
3102 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3103 find_with_var_identity(
3104 B-UV,
3105 [Susp],
3106 (
3107 member(ST,StoreTypes),
3108 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
3109 ),
3110 BodiesUsedVars
3111 ),
3112 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
3113 list2conj(Bodies,Body),
3114 sort_out_used_vars(NestedUsedVars,UsedVars).
3115 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3116 UsedVars = [Index-Var],
3117 get_identifier_size(ISize),
3118 functor(Struct,struct,ISize),
3119 get_identifier_index(C,Index,IIndex),
3120 arg(IIndex,Struct,Susps),
3121 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3122 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3123 UsedVars = [Index-Var],
3124 type_indexed_identifier_structure(IndexType,Struct),
3125 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3126 arg(IIndex,Struct,Susps),
3127 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3129 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3130 flatten(NestedUsedVars,FlatUsedVars),
3131 sort(FlatUsedVars,SortedFlatUsedVars),
3132 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3134 sort_out_used_vars1([],[]).
3135 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3136 sort_out_used_vars1([I-X,J-Y|R],L) :-
3137 ( I == J ->
3138 X = Y,
3139 sort_out_used_vars1([I-X|R],L)
3140 ;
3141 L = [I-X|T],
3142 sort_out_used_vars1([J-Y|R],T)
3143 ).
3145 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3146 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3147 multi_hash_store_name(FA,Index,StoreName),
3148 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3149 Body =
3150 (
3151 KeyBody,
3152 nb_getval(StoreName,Store),
3153 insert_iht(Store,Key,Susp)
3154 ),
3155 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3157 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3158 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3159 multi_hash_store_name(FA,Index,StoreName),
3160 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3161 make_get_store_goal(StoreName,Store,GetStoreGoal),
3162 ( chr_pp_flag(ht_removal,on)
3163 -> ht_prev_field(Index,PrevField),
3164 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3165 SetGoal),
3166 Body =
3167 (
3168 GetStoreGoal,
3169 insert_ht(Store,Key,Susp,Result),
3170 ( Result = [_,NextSusp|_]
3171 -> SetGoal
3172 ; true
3173 )
3174 )
3175 ; Body =
3176 (
3177 GetStoreGoal,
3178 insert_ht(Store,Key,Susp)
3179 )
3180 ),
3181 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3183 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3184 % Delete
3186 delete_constraint_clause(C,Clauses,RestClauses) :-
3187 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3188 Clauses = [Clause|RestClauses],
3189 Clause = (Head :- Body),
3190 delete_constraint_atom(C,Susp,Head),
3191 C = F/A,
3192 functor(Head,F,A),
3193 delete_constraint_body(C,Head,Susp,[],Body)
3194 ;
3195 Clauses = RestClauses
3196 ).
3198 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3199 functor(Head,F,A),
3200 C = F/A,
3201 ( chr_pp_flag(inline_insertremove,off) ->
3202 use_auxiliary_predicate(delete_from_store,C),
3203 delete_constraint_atom(C,Susp,Goal)
3204 ;
3205 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3206 ).
3208 delete_constraint_atom(C,Susp,Atom) :-
3209 make_name('$delete_from_store_',C,Functor),
3210 Atom =.. [Functor,Susp].
3213 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3214 Body = (CounterBody,DeleteBody),
3215 ( chr_pp_flag(store_counter,on) ->
3216 CounterBody = '$delete_counter_inc'
3217 ;
3218 CounterBody = true
3219 ),
3220 get_store_type(C,StoreType),
3221 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3223 delete_constraint_body(default,C,_,Susp,_,Body) :-
3224 ( chr_pp_flag(debugable,on) ->
3225 global_list_store_name(C,StoreName),
3226 make_get_store_goal(StoreName,Store,GetStoreGoal),
3227 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3228 Body =
3229 (
3230 GetStoreGoal, % nb_getval(StoreName,Store),
3231 'chr sbag_del_element'(Store,Susp,NStore),
3232 UpdateStoreGoal % b_setval(StoreName,NStore)
3233 )
3234 ;
3235 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3236 global_list_store_name(C,StoreName),
3237 make_get_store_goal(StoreName,Store,GetStoreGoal),
3238 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3239 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3240 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3241 Body =
3242 (
3243 GetGoal,
3244 ( var(PredCell) ->
3245 GetStoreGoal, % nb_getval(StoreName,Store),
3246 Store = [_|Tail],
3247 UpdateStoreGoal,
3248 ( Tail = [NextSusp|_] ->
3249 SetGoal1
3250 ;
3251 true
3252 )
3253 ;
3254 PredCell = [_,_|Tail],
3255 setarg(2,PredCell,Tail),
3256 ( Tail = [NextSusp|_] ->
3257 SetGoal2
3258 ;
3259 true
3260 )
3261 )
3262 )
3263 ).
3264 % get_target_module(Mod),
3265 % get_max_constraint_index(Total),
3266 % ( Total == 1 ->
3267 % generate_detach_body_1(C,Store,Susp,DetachBody),
3268 % Body =
3269 % (
3270 % 'chr default_store'(Store),
3271 % DetachBody
3272 % )
3273 % ;
3274 % generate_detach_body_n(C,Store,Susp,DetachBody),
3275 % Body =
3276 % (
3277 % 'chr default_store'(Store),
3278 % DetachBody
3279 % )
3280 % ).
3281 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3282 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3283 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3284 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3285 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3286 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3287 constants_store_index_name(C,Index,IndexName),
3288 IndexLookup =.. [IndexName,Key,StoreName],
3289 Body =
3290 ( KeyBody,
3291 ( IndexLookup ->
3292 nb_getval(StoreName,Store),
3293 'chr sbag_del_element'(Store,Susp,NStore),
3294 b_setval(StoreName,NStore)
3295 ;
3296 true
3297 )).
3298 delete_constraint_body(ground_constants(Index,_),C,Head,Susp,VarDict,Body) :-
3299 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3300 constants_store_index_name(C,Index,IndexName),
3301 IndexLookup =.. [IndexName,Key,StoreName],
3302 Body =
3303 ( KeyBody,
3304 ( IndexLookup ->
3305 nb_getval(StoreName,Store),
3306 'chr sbag_del_element'(Store,Susp,NStore),
3307 b_setval(StoreName,NStore)
3308 ;
3309 true
3310 )).
3311 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3312 ( chr_pp_flag(debugable,on) ->
3313 global_ground_store_name(C,StoreName),
3314 make_get_store_goal(StoreName,Store,GetStoreGoal),
3315 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3316 Body =
3317 (
3318 GetStoreGoal, % nb_getval(StoreName,Store),
3319 'chr sbag_del_element'(Store,Susp,NStore),
3320 UpdateStoreGoal % b_setval(StoreName,NStore)
3321 )
3322 ;
3323 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3324 global_ground_store_name(C,StoreName),
3325 make_get_store_goal(StoreName,Store,GetStoreGoal),
3326 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3327 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3328 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3329 Body =
3330 (
3331 GetGoal,
3332 ( var(PredCell) ->
3333 GetStoreGoal, % nb_getval(StoreName,Store),
3334 Store = [_|Tail],
3335 UpdateStoreGoal,
3336 ( Tail = [NextSusp|_] ->
3337 SetGoal1
3338 ;
3339 true
3340 )
3341 ;
3342 PredCell = [_,_|Tail],
3343 setarg(2,PredCell,Tail),
3344 ( Tail = [NextSusp|_] ->
3345 SetGoal2
3346 ;
3347 true
3348 )
3349 )
3350 )
3351 ).
3352 % global_ground_store_name(C,StoreName),
3353 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3354 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3355 % Body =
3356 % (
3357 % GetStoreGoal, % nb_getval(StoreName,Store),
3358 % 'chr sbag_del_element'(Store,Susp,NStore),
3359 % UpdateStoreGoal % b_setval(StoreName,NStore)
3360 % ).
3361 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3362 get_target_module(Module),
3363 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3364 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3365 Body = (
3366 VariableGoal,
3367 get_attr(Variable,Module,AssocStore),
3368 KeyGoal,
3369 delete_assoc_store(AssocStore,Key,Susp)
3370 ).
3371 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3372 global_singleton_store_name(C,StoreName),
3373 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3374 Body =
3375 (
3376 UpdateStoreGoal % b_setval(StoreName,[])
3377 ).
3378 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3379 find_with_var_identity(
3380 B,
3381 [Susp/VarDict/Head],
3382 (
3383 member(ST,StoreTypes),
3384 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3385 ),
3386 Bodies
3387 ),
3388 list2conj(Bodies,Body).
3389 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3390 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3391 get_identifier_size(ISize),
3392 functor(Struct,struct,ISize),
3393 get_identifier_index(C,Index,IIndex),
3394 arg(IIndex,Struct,Susps),
3395 Body = (
3396 VariableGoal,
3397 Variable = Struct,
3398 'chr sbag_del_element'(Susps,Susp,NSusps),
3399 setarg(IIndex,Variable,NSusps)
3400 ).
3401 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3402 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3403 type_indexed_identifier_structure(IndexType,Struct),
3404 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3405 arg(IIndex,Struct,Susps),
3406 Body = (
3407 VariableGoal,
3408 Variable = Struct,
3409 'chr sbag_del_element'(Susps,Susp,NSusps),
3410 setarg(IIndex,Variable,NSusps)
3411 ).
3413 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3414 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3415 multi_hash_store_name(FA,Index,StoreName),
3416 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3417 Body =
3418 (
3419 KeyBody,
3420 nb_getval(StoreName,Store),
3421 delete_iht(Store,Key,Susp)
3422 ),
3423 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3424 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3425 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3426 multi_hash_store_name(C,Index,StoreName),
3427 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3428 make_get_store_goal(StoreName,Store,GetStoreGoal),
3429 ( chr_pp_flag(ht_removal,on)
3430 -> ht_prev_field(Index,PrevField),
3431 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3432 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3433 SetGoal1),
3434 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3435 SetGoal2),
3436 Body =
3437 (
3438 GetGoal,
3439 ( var(Prev)
3440 -> GetStoreGoal,
3441 KeyBody,
3442 delete_first_ht(Store,Key,Values),
3443 ( Values = [NextSusp|_]
3444 -> SetGoal1
3445 ; true
3446 )
3447 ; Prev = [_,_|Values],
3448 setarg(2,Prev,Values),
3449 ( Values = [NextSusp|_]
3450 -> SetGoal2
3451 ; true
3452 )
3453 )
3454 )
3455 ; Body =
3456 (
3457 KeyBody,
3458 GetStoreGoal, % nb_getval(StoreName,Store),
3459 delete_ht(Store,Key,Susp)
3460 )
3461 ),
3462 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3464 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3466 :- chr_constraint
3467 module_initializer/1,
3468 module_initializers/1.
3470 module_initializers(G), module_initializer(Initializer) <=>
3471 G = (Initializer,Initializers),
3472 module_initializers(Initializers).
3474 module_initializers(G) <=>
3475 G = true.
3477 generate_attach_code(Constraints,[Enumerate|L]) :-
3478 enumerate_stores_code(Constraints,Enumerate),
3479 generate_attach_code(Constraints,L,T),
3480 module_initializers(Initializers),
3481 prolog_global_variables_code(PrologGlobalVariables),
3482 % Do not rename or the 'chr_initialization' predicate
3483 % without warning SSS
3484 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3486 generate_attach_code([],L,L).
3487 generate_attach_code([C|Cs],L,T) :-
3488 get_store_type(C,StoreType),
3489 generate_attach_code(StoreType,C,L,L1),
3490 generate_attach_code(Cs,L1,T).
3492 generate_attach_code(default,C,L,T) :-
3493 global_list_store_initialisation(C,L,T).
3494 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3495 multi_inthash_store_initialisations(Indexes,C,L,L1),
3496 multi_inthash_via_lookups(Indexes,C,L1,T).
3497 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3498 multi_hash_store_initialisations(Indexes,C,L,L1),
3499 multi_hash_lookups(Indexes,C,L1,T).
3500 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3501 constants_initializers(C,Index,Constants),
3502 atomic_constants_code(C,Index,Constants,L,T).
3503 generate_attach_code(ground_constants(Index,Constants),C,L,T) :-
3504 constants_initializers(C,Index,Constants),
3505 ground_constants_code(C,Index,Constants,L,T).
3506 generate_attach_code(global_ground,C,L,T) :-
3507 global_ground_store_initialisation(C,L,T).
3508 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3509 use_auxiliary_module(chr_assoc_store).
3510 generate_attach_code(global_singleton,C,L,T) :-
3511 global_singleton_store_initialisation(C,L,T).
3512 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3513 multi_store_generate_attach_code(StoreTypes,C,L,T).
3514 generate_attach_code(identifier_store(Index),C,L,T) :-
3515 get_identifier_index(C,Index,IIndex),
3516 ( IIndex == 2 ->
3517 get_identifier_size(ISize),
3518 functor(Struct,struct,ISize),
3519 Struct =.. [_,Label|Stores],
3520 set_elems(Stores,[]),
3521 Clause1 = new_identifier(Label,Struct),
3522 functor(Struct2,struct,ISize),
3523 arg(1,Struct2,Label2),
3524 Clause2 =
3525 ( user:portray(Struct2) :-
3526 write('<id:'),
3527 print(Label2),
3528 write('>')
3529 ),
3530 functor(Struct3,struct,ISize),
3531 arg(1,Struct3,Label3),
3532 Clause3 = identifier_label(Struct3,Label3),
3533 L = [Clause1,Clause2,Clause3|T]
3534 ;
3535 L = T
3536 ).
3537 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3538 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3539 ( IIndex == 2 ->
3540 identifier_store_initialization(IndexType,L,L1),
3541 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3542 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3543 get_type_indexed_identifier_size(IndexType,ISize),
3544 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3545 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3546 type_indexed_identifier_structure(IndexType,Struct),
3547 Struct =.. [_,Label|Stores],
3548 set_elems(Stores,[]),
3549 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3550 Clause1 =.. [Name1,Label,Struct],
3551 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3552 Goal1 =.. [Name1,Label1b,S1b],
3553 type_indexed_identifier_structure(IndexType,Struct1b),
3554 Struct1b =.. [_,Label1b|Stores1b],
3555 set_elems(Stores1b,[]),
3556 Expansion1 = (S1b = Struct1b),
3557 Clause1b = user:goal_expansion(Goal1,Expansion1),
3558 % writeln(Clause1-Clause1b),
3559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3560 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3561 type_indexed_identifier_structure(IndexType,Struct2),
3562 arg(1,Struct2,Label2),
3563 Clause2 =
3564 ( user:portray(Struct2) :-
3565 write('<id:'),
3566 print(Label2),
3567 write('>')
3568 ),
3569 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3570 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3571 type_indexed_identifier_structure(IndexType,Struct3),
3572 arg(1,Struct3,Label3),
3573 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3574 Clause3 =.. [Name3,Struct3,Label3],
3575 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3576 Goal3b =.. [Name3,S3b,L3b],
3577 type_indexed_identifier_structure(IndexType,Struct3b),
3578 arg(1,Struct3b,L3b),
3579 Expansion3b = (S3 = Struct3b),
3580 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3581 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3582 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3583 identifier_store_name(IndexType,GlobalVariable),
3584 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3585 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3586 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3587 Clause4 =
3588 ( LookupAtom :-
3589 nb_getval(GlobalVariable,HT),
3590 ( lookup_ht(HT,X,[IX]) ->
3591 true
3592 ;
3593 NewIdentifierGoal,
3594 insert_ht(HT,X,IX)
3595 )
3596 ),
3597 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3598 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3599 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3600 ;
3601 L = T
3602 ).
3604 constants_initializers(C,Index,Constants) :-
3605 maplist(constants_store_name(C,Index),Constants,StoreNames),
3606 findall(Initializer,
3607 ( member(StoreName,StoreNames),
3608 Initializer = nb_setval(StoreName,[])
3609 ),
3610 Initializers),
3611 maplist(module_initializer,Initializers).
3613 lookup_identifier_atom(Key,X,IX,Atom) :-
3614 atom_concat('lookup_identifier_',Key,LookupFunctor),
3615 Atom =.. [LookupFunctor,X,IX].
3617 identifier_label_atom(IndexType,IX,X,Atom) :-
3618 type_indexed_identifier_name(IndexType,identifier_label,Name),
3619 Atom =.. [Name,IX,X].
3621 multi_store_generate_attach_code([],_,L,L).
3622 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3623 generate_attach_code(ST,C,L,L1),
3624 multi_store_generate_attach_code(STs,C,L1,T).
3626 multi_inthash_store_initialisations([],_,L,L).
3627 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3628 use_auxiliary_module(chr_integertable_store),
3629 multi_hash_store_name(FA,Index,StoreName),
3630 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3631 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3632 L1 = L,
3633 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3634 multi_hash_store_initialisations([],_,L,L).
3635 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3636 use_auxiliary_module(chr_hashtable_store),
3637 multi_hash_store_name(FA,Index,StoreName),
3638 prolog_global_variable(StoreName),
3639 make_init_store_goal(StoreName,HT,InitStoreGoal),
3640 module_initializer((new_ht(HT),InitStoreGoal)),
3641 L1 = L,
3642 multi_hash_store_initialisations(Indexes,FA,L1,T).
3644 global_list_store_initialisation(C,L,T) :-
3645 ( is_stored(C) ->
3646 global_list_store_name(C,StoreName),
3647 prolog_global_variable(StoreName),
3648 make_init_store_goal(StoreName,[],InitStoreGoal),
3649 module_initializer(InitStoreGoal)
3650 ;
3651 true
3652 ),
3653 L = T.
3654 global_ground_store_initialisation(C,L,T) :-
3655 global_ground_store_name(C,StoreName),
3656 prolog_global_variable(StoreName),
3657 make_init_store_goal(StoreName,[],InitStoreGoal),
3658 module_initializer(InitStoreGoal),
3659 L = T.
3660 global_singleton_store_initialisation(C,L,T) :-
3661 global_singleton_store_name(C,StoreName),
3662 prolog_global_variable(StoreName),
3663 make_init_store_goal(StoreName,[],InitStoreGoal),
3664 module_initializer(InitStoreGoal),
3665 L = T.
3666 identifier_store_initialization(IndexType,L,T) :-
3667 use_auxiliary_module(chr_hashtable_store),
3668 identifier_store_name(IndexType,StoreName),
3669 prolog_global_variable(StoreName),
3670 make_init_store_goal(StoreName,HT,InitStoreGoal),
3671 module_initializer((new_ht(HT),InitStoreGoal)),
3672 L = T.
3675 multi_inthash_via_lookups([],_,L,L).
3676 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3677 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3678 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3679 L = [(Head :- Body)|L1],
3680 multi_inthash_via_lookups(Indexes,C,L1,T).
3681 multi_hash_lookups([],_,L,L).
3682 multi_hash_lookups([Index|Indexes],C,L,T) :-
3683 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3684 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3685 L = [(Head :- Body)|L1],
3686 multi_hash_lookups(Indexes,C,L1,T).
3688 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3689 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3690 Head =.. [Name,Key,SuspsList].
3692 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3693 %
3694 % Returns goal that performs hash table lookup.
3695 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3696 % INLINED:
3697 get_store_type(ConstraintSymbol,multi_store(Stores)),
3698 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3699 ( ground(Key) ->
3700 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3701 Goal = nb_getval(StoreName,SuspsList)
3702 ;
3703 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3704 Lookup =.. [IndexName,Key,StoreName],
3705 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3706 )
3707 ; memberchk(ground_constants(Index,Constants),Stores) ->
3708 ( ground(Key) ->
3709 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3710 Goal = nb_getval(StoreName,SuspsList)
3711 ;
3712 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3713 Lookup =.. [IndexName,Key,StoreName],
3714 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3715 )
3716 ; memberchk(multi_hash([Index]),Stores) ->
3717 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3718 make_get_store_goal(StoreName,HT,GetStoreGoal),
3719 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3720 Goal =
3721 (
3722 GetStoreGoal, % nb_getval(StoreName,HT),
3723 HashCall, % hash_term(Key,Hash),
3724 lookup_ht1(HT,Hash,Key,SuspsList)
3725 )
3726 ;
3727 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3728 Goal =
3729 (
3730 GetStoreGoal, % nb_getval(StoreName,HT),
3731 Lookup
3732 )
3733 )
3734 ; HashType == inthash ->
3735 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3736 make_get_store_goal(StoreName,HT,GetStoreGoal),
3737 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3738 Goal =
3739 (
3740 GetStoreGoal, % nb_getval(StoreName,HT),
3741 Lookup
3742 )
3743 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3744 % find alternative index
3745 % -> SubIndex + RestIndex
3746 % -> SubKey + RestKeys
3747 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3748 % instantiate rest goal?
3749 % Goal = (SubGoal,RestGoal)
3750 ).
3753 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3754 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3756 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3757 ( ground(Key) ->
3758 % This is based on a property of SWI-Prolog's
3759 % hash_term/2 predicate:
3760 % the hash value is stable over repeated invocations
3761 % of SWI-Prolog
3762 hash_term(Key,Hash),
3763 Call = true
3764 ; Index = [IndexPos],
3765 get_constraint_type(Constraint,ArgTypes),
3766 nth1(IndexPos,ArgTypes,Type),
3767 unalias_type(Type,NormalType),
3768 memberchk_eq(NormalType,[int,natural]) ->
3769 ( NormalType == int ->
3770 Hash = abs(Key),
3771 Call = true
3772 ;
3773 Hash = Key,
3774 Call = true
3775 )
3776 ;
3777 nonvar(Key),
3778 specialize_hash_term(Key,NewKey),
3779 NewKey \== Key,
3780 Call = hash_term(NewKey,Hash)
3781 ).
3783 specialize_hash_term(Term,NewTerm) :-
3784 ( ground(Term) ->
3785 hash_term(Term,NewTerm)
3786 ; var(Term) ->
3787 NewTerm = Term
3788 ;
3789 Term =.. [F|Args],
3790 maplist(specialize_hash_term,Args,NewArgs),
3791 NewTerm =.. [F|NewArgs]
3792 ).
3794 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3795 ( /* chr_pp_flag(experiment,off) ->
3796 true
3797 ; */ atomic(Key) ->
3798 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3799 ; ground(Key) ->
3800 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3801 ;
3802 actual_non_atomic_multi_hash_key(ConstraintSymbol,Index)
3803 ),
3804 delay_phase_end(validate_store_type_assumptions,
3805 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3807 :- chr_constraint actual_atomic_multi_hash_keys/3.
3808 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3810 :- chr_constraint actual_ground_multi_hash_keys/3.
3811 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3813 :- chr_constraint actual_non_atomic_multi_hash_key/2.
3814 :- chr_option(mode,actual_non_atomic_multi_hash_key(+,+)).
3816 /*
3817 actual_atomic_multi_hash_keys(C,Index,Keys)
3818 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3820 actual_ground_multi_hash_keys(C,Index,Keys)
3821 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3823 actual_non_atomic_multi_hash_key(C,Index)
3824 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3825 */
3826 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3827 <=> append(Keys1,Keys2,Keys0),
3828 sort(Keys0,Keys),
3829 actual_atomic_multi_hash_keys(C,Index,Keys).
3831 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3832 <=> append(Keys1,Keys2,Keys0),
3833 sort(Keys0,Keys),
3834 actual_ground_multi_hash_keys(C,Index,Keys).
3836 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3837 <=> append(Keys1,Keys2,Keys0),
3838 sort(Keys0,Keys),
3839 actual_ground_multi_hash_keys(C,Index,Keys).
3841 actual_non_atomic_multi_hash_key(C,Index) \ actual_non_atomic_multi_hash_key(C,Index)
3842 <=> true.
3844 actual_non_atomic_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3845 <=> true.
3847 actual_non_atomic_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3848 <=> true.
3850 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3851 %
3852 % Returns predicate name of hash table lookup predicate.
3853 multi_hash_lookup_name(F/A,Index,Name) :-
3854 ( integer(Index) ->
3855 IndexName = Index
3856 ; is_list(Index) ->
3857 atom_concat_list(Index,IndexName)
3858 ),
3859 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3861 multi_hash_store_name(F/A,Index,Name) :-
3862 get_target_module(Mod),
3863 ( integer(Index) ->
3864 IndexName = Index
3865 ; is_list(Index) ->
3866 atom_concat_list(Index,IndexName)
3867 ),
3868 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3870 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3871 ( ( integer(Index) ->
3872 I = Index
3873 ;
3874 Index = [I]
3875 ) ->
3876 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3877 ; is_list(Index) ->
3878 sort(Index,Indexes),
3879 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3880 once(pairup(Bodies,Keys,ArgKeyPairs)),
3881 Key =.. [k|Keys],
3882 list2conj(Bodies,KeyBody)
3883 ).
3885 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3886 ( ( integer(Index) ->
3887 I = Index
3888 ;
3889 Index = [I]
3890 ) ->
3891 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3892 ; is_list(Index) ->
3893 sort(Index,Indexes),
3894 find_with_var_identity(
3895 Goal-KeyI,
3896 [Susp/Head/VarDict],
3897 (
3898 member(I,Indexes),
3899 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3900 ),
3901 ArgKeyPairs
3902 ),
3903 once(pairup(Bodies,Keys,ArgKeyPairs)),
3904 Key =.. [k|Keys],
3905 list2conj(Bodies,KeyBody)
3906 ).
3908 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3909 arg(Index,Head,OriginalArg),
3910 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3911 Goal = true
3912 ;
3913 functor(Head,F,A),
3914 C = F/A,
3915 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3916 ).
3918 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3919 ( ( integer(Index) ->
3920 I = Index
3921 ;
3922 Index = [I]
3923 ) ->
3924 UsedVars = [I-Key]
3925 ; is_list(Index) ->
3926 sort(Index,Indexes),
3927 pairup(Indexes,Keys,UsedVars),
3928 Key =.. [k|Keys]
3929 ).
3931 multi_hash_key_args(Index,Head,KeyArgs) :-
3932 ( integer(Index) ->
3933 arg(Index,Head,Arg),
3934 KeyArgs = [Arg]
3935 ; is_list(Index) ->
3936 sort(Index,Indexes),
3937 term_variables(Head,Vars),
3938 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3939 ).
3942 %-------------------------------------------------------------------------------
3943 atomic_constants_code(C,Index,Constants,L,T) :-
3944 constants_store_index_name(C,Index,IndexName),
3945 findall(Clause,
3946 ( member(Constant,Constants),
3947 constants_store_name(C,Index,Constant,StoreName),
3948 Clause =.. [IndexName,Constant,StoreName]
3949 ),
3950 Clauses),
3951 append(Clauses,T,L).
3953 %-------------------------------------------------------------------------------
3954 ground_constants_code(C,Index,Terms,L,T) :-
3955 constants_store_index_name(C,Index,IndexName),
3956 findall(StoreName,
3957 ( member(Constant,Terms),
3958 constants_store_name(C,Index,Constant,StoreName)
3959 ),
3960 StoreNames),
3961 length(Terms,N),
3962 replicate(N,[],More),
3963 trie_index([Terms|More],StoreNames,IndexName,L,T).
3965 constants_store_name(F/A,Index,Term,Name) :-
3966 get_target_module(Mod),
3967 term_to_atom(Term,Constant),
3968 term_to_atom(Index,IndexAtom),
3969 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3971 constants_store_index_name(F/A,Index,Name) :-
3972 get_target_module(Mod),
3973 term_to_atom(Index,IndexAtom),
3974 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3976 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3977 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3979 trie_step([],_,_,[],[],L,L) :- !.
3980 % length MorePatterns == length Patterns == length Results
3981 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3982 MorePatterns = [List|_],
3983 length(List,N),
3984 findall(F/A,
3985 ( member(Pattern,Patterns),
3986 functor(Pattern,F,A)
3987 ),
3988 FAs0),
3989 sort(FAs0,FAs),
3990 N1 is N + 1,
3991 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3993 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3994 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3995 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3996 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3998 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3999 Clause = (Head :- Body),
4000 N1 is N + 1,
4001 functor(Head,Symbol,N1),
4002 arg(N1,Head,Result),
4003 functor(IndexPattern,F,A),
4004 arg(1,Head,IndexPattern),
4005 Head =.. [_,_|RestArgs],
4006 IndexPattern =.. [_|Args],
4007 append(Args,RestArgs,RecArgs),
4008 ( RecArgs == [Result] ->
4009 List = Tail,
4010 Body = true,
4011 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4012 MoreResults = [Result]
4013 ;
4014 gensym(Prefix,RSymbol),
4015 Body =.. [RSymbol|RecArgs],
4016 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4017 trie_step(Cases,RSymbol,Prefix,MoreCases,MoreResults,List,Tail)
4018 ).
4020 rec_cases([],[],[],_,[],[],[]).
4021 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4022 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4023 Cases = [Case|NCases],
4024 MoreCases = [MoreCase|NMoreCases],
4025 MoreResults = [Result|NMoreResults],
4026 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4027 ;
4028 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4029 ).
4031 %-------------------------------------------------------------------------------
4032 global_list_store_name(F/A,Name) :-
4033 get_target_module(Mod),
4034 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4035 global_ground_store_name(F/A,Name) :-
4036 get_target_module(Mod),
4037 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4038 global_singleton_store_name(F/A,Name) :-
4039 get_target_module(Mod),
4040 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4042 identifier_store_name(TypeName,Name) :-
4043 get_target_module(Mod),
4044 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4046 :- chr_constraint prolog_global_variable/1.
4047 :- chr_option(mode,prolog_global_variable(+)).
4049 :- chr_constraint prolog_global_variables/1.
4050 :- chr_option(mode,prolog_global_variables(-)).
4052 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4054 prolog_global_variables(List), prolog_global_variable(Name) <=>
4055 List = [Name|Tail],
4056 prolog_global_variables(Tail).
4057 prolog_global_variables(List) <=> List = [].
4059 %% SWI begin
4060 prolog_global_variables_code(Code) :-
4061 prolog_global_variables(Names),
4062 ( Names == [] ->
4063 Code = []
4064 ;
4065 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
4066 Code = [(:- dynamic user:exception/3),
4067 (:- multifile user:exception/3),
4068 (user:exception(undefined_global_variable,Name,retry) :-
4069 (
4070 '$chr_prolog_global_variable'(Name),
4071 '$chr_initialization'
4072 )
4073 )
4074 |
4075 NameDeclarations
4076 ]
4077 ).
4078 %% SWI end
4079 %% SICStus begin
4080 % prolog_global_variables_code([]).
4081 %% SICStus end
4082 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4083 %sbag_member_call(S,L,sysh:mem(S,L)).
4084 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4085 %sbag_member_call(S,L,member(S,L)).
4086 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4087 %update_mutable_call(A,B,setarg(1, B, A)).
4088 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4089 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4091 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4092 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4093 % create_get_mutable(Value,Field,Get1).
4094 %
4095 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4096 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4097 % update_mutable_call(NewValue,Field,Set).
4098 %
4099 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4100 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4101 % create_get_mutable_ref(Value,Field,Get1),
4102 % update_mutable_call(NewValue,Field,Set).
4103 %
4104 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4105 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4106 % create_mutable_call(Value,Field,Create).
4107 %
4108 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4109 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4110 % create_get_mutable(Value,Field,Get).
4111 %
4112 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4113 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4114 % create_get_mutable_ref(Value,Field,Get),
4115 % update_mutable_call(NewValue,Field,Set).
4117 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4118 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4120 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4121 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4123 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4124 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4125 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4127 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4128 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4130 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4131 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4133 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4134 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4135 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4137 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4139 enumerate_stores_code(Constraints,Clause) :-
4140 Head = '$enumerate_constraints'(Constraint),
4141 enumerate_store_bodies(Constraints,Constraint,Bodies),
4142 list2disj(Bodies,Body),
4143 Clause = (Head :- Body).
4145 enumerate_store_bodies([],_,[]).
4146 enumerate_store_bodies([C|Cs],Constraint,L) :-
4147 ( is_stored(C) ->
4148 get_store_type(C,StoreType),
4149 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4150 true
4151 ;
4152 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4153 ),
4154 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4155 C = F/_,
4156 Constraint0 =.. [F|Arguments],
4157 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4158 L = [Body|T]
4159 ;
4160 L = T
4161 ),
4162 enumerate_store_bodies(Cs,Constraint,T).
4164 enumerate_store_body(default,C,Susp,Body) :-
4165 global_list_store_name(C,StoreName),
4166 sbag_member_call(Susp,List,Sbag),
4167 make_get_store_goal(StoreName,List,GetStoreGoal),
4168 Body =
4169 (
4170 GetStoreGoal, % nb_getval(StoreName,List),
4171 Sbag
4172 ).
4173 % get_constraint_index(C,Index),
4174 % get_target_module(Mod),
4175 % get_max_constraint_index(MaxIndex),
4176 % Body1 =
4177 % (
4178 % 'chr default_store'(GlobalStore),
4179 % get_attr(GlobalStore,Mod,Attr)
4180 % ),
4181 % ( MaxIndex > 1 ->
4182 % NIndex is Index + 1,
4183 % sbag_member_call(Susp,List,Sbag),
4184 % Body2 =
4185 % (
4186 % arg(NIndex,Attr,List),
4187 % Sbag
4188 % )
4189 % ;
4190 % sbag_member_call(Susp,Attr,Sbag),
4191 % Body2 = Sbag
4192 % ),
4193 % Body = (Body1,Body2).
4194 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4195 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4196 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4197 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4198 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4199 Completeness == complete, % fail if incomplete
4200 find_with_var_identity(nb_getval(StoreName,Susps),[Susps],
4201 ( member(Constant,Constants),
4202 constants_store_name(C,Index,Constant,StoreName) )
4203 , Disjuncts),
4204 list2disj(Disjuncts, Disjunction),
4205 Body = ( Disjunction, member(Susp,Susps) ).
4206 enumerate_store_body(ground_constants(_,_),_,_,_) :- fail.
4207 enumerate_store_body(global_ground,C,Susp,Body) :-
4208 global_ground_store_name(C,StoreName),
4209 sbag_member_call(Susp,List,Sbag),
4210 make_get_store_goal(StoreName,List,GetStoreGoal),
4211 Body =
4212 (
4213 GetStoreGoal, % nb_getval(StoreName,List),
4214 Sbag
4215 ).
4216 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4217 Body = fail.
4218 enumerate_store_body(global_singleton,C,Susp,Body) :-
4219 global_singleton_store_name(C,StoreName),
4220 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4221 Body =
4222 (
4223 GetStoreGoal, % nb_getval(StoreName,Susp),
4224 Susp \== []
4225 ).
4226 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4227 once((
4228 member(ST,STs),
4229 enumerate_store_body(ST,C,Susp,Body)
4230 )).
4231 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4232 Body = fail.
4233 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4234 Body = fail.
4236 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4237 multi_hash_store_name(C,I,StoreName),
4238 B =
4239 (
4240 nb_getval(StoreName,HT),
4241 value_iht(HT,Susp)
4242 ).
4243 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4244 multi_hash_store_name(C,I,StoreName),
4245 make_get_store_goal(StoreName,HT,GetStoreGoal),
4246 B =
4247 (
4248 GetStoreGoal, % nb_getval(StoreName,HT),
4249 value_ht(HT,Susp)
4250 ).
4252 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4255 :- chr_constraint
4256 prev_guard_list/8,
4257 prev_guard_list/6,
4258 simplify_guards/1,
4259 set_all_passive/1.
4261 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4262 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4263 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4264 :- chr_option(mode,simplify_guards(+)).
4265 :- chr_option(mode,set_all_passive(+)).
4267 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4268 % GUARD SIMPLIFICATION
4269 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4270 % If the negation of the guards of earlier rules entails (part of)
4271 % the current guard, the current guard can be simplified. We can only
4272 % use earlier rules with a head that matches if the head of the current
4273 % rule does, and which make it impossible for the current rule to match
4274 % if they fire (i.e. they shouldn't be propagation rules and their
4275 % head constraints must be subsets of those of the current rule).
4276 % At this point, we know for sure that the negation of the guard
4277 % of such a rule has to be true (otherwise the earlier rule would have
4278 % fired, because of the refined operational semantics), so we can use
4279 % that information to simplify the guard by replacing all entailed
4280 % conditions by true/0. As a consequence, the never-stored analysis
4281 % (in a further phase) will detect more cases of never-stored constraints.
4282 %
4283 % e.g. c(X),d(Y) <=> X > 0 | ...
4284 % e(X) <=> X < 0 | ...
4285 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4286 % \____________/
4287 % true
4289 guard_simplification :-
4290 ( chr_pp_flag(guard_simplification,on) ->
4291 precompute_head_matchings,
4292 simplify_guards(1)
4293 ;
4294 true
4295 ).
4297 % for every rule, we create a prev_guard_list where the last argument
4298 % eventually is a list of the negations of earlier guards
4299 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4300 <=>
4301 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4302 append(Head1,Head2,Heads),
4303 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4304 multiple_occ_constraints_checked([]),
4305 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4307 append(IDs1,IDs2,IDs),
4308 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4309 empty_q(EmptyHeap),
4310 insert_list_q(HeapData,EmptyHeap,Heap),
4311 next_prev_rule(Heap,_,Heap1),
4312 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4313 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4314 NextRule is RuleNb+1,
4315 simplify_guards(NextRule).
4317 next_prev_rule(Heap,RuleNb,NHeap) :-
4318 ( find_min_q(Heap,_-Priority) ->
4319 Priority = (-RuleNb),
4320 normalize_heap(Heap,Priority,NHeap)
4321 ;
4322 RuleNb = 0,
4323 NHeap = Heap
4324 ).
4326 normalize_heap(Heap,Priority,NHeap) :-
4327 ( find_min_q(Heap,_-Priority) ->
4328 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4329 ( O > 1 ->
4330 NO is O -1,
4331 get_occurrence(C,NO,RuleNb,_),
4332 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4333 ;
4334 Heap2 = Heap1
4335 ),
4336 normalize_heap(Heap2,Priority,NHeap)
4337 ;
4338 NHeap = Heap
4339 ).
4341 % no more rule
4342 simplify_guards(_)
4343 <=>
4344 true.
4346 % The negation of the guard of a non-propagation rule is added
4347 % if its kept head constraints are a subset of the kept constraints of
4348 % the rule we're working on, and its removed head constraints (at least one)
4349 % are a subset of the removed constraints.
4351 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4352 <=>
4353 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4354 H1 \== [],
4355 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4356 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4357 |
4358 append(H1,H2,Heads),
4359 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4360 append(GuardList,DerivedInfo,GL1),
4361 normalize_conj_list(GL1,GL),
4362 append(GH_New1,GH,GH1),
4363 normalize_conj_list(GH1,GH_New),
4364 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4365 % PrevPrevRuleNb is PrevRuleNb-1,
4366 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4368 % if this isn't the case, we skip this one and try the next rule
4369 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4370 <=>
4371 ( N > 0 ->
4372 next_prev_rule(Heap,N1,NHeap),
4373 % N1 is N-1,
4374 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4375 ;
4376 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4377 ).
4379 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4380 <=>
4381 GH \== []
4382 |
4383 head_types_modes_condition(GH,H,TypeInfo),
4384 conj2list(TypeInfo,TI),
4385 term_variables(H,HeadVars),
4386 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4387 normalize_conj_list(Info,InfoL),
4388 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4390 head_types_modes_condition([],H,true).
4391 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4392 types_modes_condition(H,GH,TI1),
4393 head_types_modes_condition(GHs,H,TI2).
4395 %%
4396 %
4397 % when all earlier guards are added or skipped, we simplify the guard.
4398 % if it's different from the original one, we change the rule
4400 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4401 <=>
4402 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4403 G \== true, % let's not try to simplify this ;)
4404 append(M,GuardList,Info),
4405 simplify_guard(G,B,Info,SimpleGuard,NB),
4406 G \== SimpleGuard
4407 |
4408 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4409 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4411 %% normalize_conj_list(+List,-NormalList) is det.
4412 %
4413 % Removes =true= elements and flattens out conjunctions.
4415 normalize_conj_list(List,NormalList) :-
4416 list2conj(List,Conj),
4417 conj2list(Conj,NormalList).
4419 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4420 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4423 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4424 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4425 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4426 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4427 append(Renaming1,ExtraRenaming,Renaming2),
4428 list2conj(PrevMatchings,Match),
4429 negate_b(Match,HeadsDontMatch),
4430 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4431 list2conj(HeadsMatch,HeadsMatchBut),
4432 term_variables(Renaming2,RenVars),
4433 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4434 new_vars(MGVars,RenVars,ExtraRenaming2),
4435 append(Renaming2,ExtraRenaming2,Renaming),
4436 ( PrevGuard == true -> % true can't fail
4437 Info_ = HeadsDontMatch
4438 ;
4439 negate_b(PrevGuard,TheGuardFailed),
4440 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4441 ),
4442 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4443 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4444 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4445 list2conj(RenamedMatchings_,RenamedMatchings),
4446 apply_guard_wrt_term(H,RenamedG2,GH2),
4447 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4448 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4450 simplify_guard(G,B,Info,SG,NB) :-
4451 conj2list(G,LG),
4452 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4453 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4454 list2conj(SGL,SG).
4457 new_vars([],_,[]).
4458 new_vars([A|As],RV,ER) :-
4459 ( memberchk_eq(A,RV) ->
4460 new_vars(As,RV,ER)
4461 ;
4462 ER = [A-NewA,NewA-A|ER2],
4463 new_vars(As,RV,ER2)
4464 ).
4466 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4467 %
4468 % check if a list of constraints is a subset of another list of constraints
4469 % (multiset-subset), meanwhile computing a variable renaming to convert
4470 % one into the other.
4471 head_subset(H,Head,Renaming) :-
4472 head_subset(H,Head,Renaming,[],_).
4474 head_subset([],Remainder,Renaming,Renaming,Remainder).
4475 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4476 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4477 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4479 % check if A is in the list, remove it from Headleft
4480 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4481 ( variable_replacement(A,X,Acc,Renaming),
4482 Remainder = Xs
4483 ;
4484 Remainder = [X|RRemainder],
4485 head_member(Xs,A,Renaming,Acc,RRemainder)
4486 ).
4487 %-------------------------------------------------------------------------------%
4488 % memoing code to speed up repeated computation
4490 :- chr_constraint precompute_head_matchings/0.
4492 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4493 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4494 append(H1,H2,Heads),
4495 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4496 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4497 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4499 precompute_head_matchings <=> true.
4501 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4502 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4504 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4505 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4507 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4508 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4509 <=>
4510 Q1 = NHeads,
4511 Q2 = Matchings.
4512 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4514 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4515 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4516 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4517 %-------------------------------------------------------------------------------%
4519 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4520 extract_arguments(Heads,Arguments),
4521 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4522 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4524 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4525 extract_arguments(Heads,Arguments),
4526 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4527 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4529 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4530 extract_arguments(Heads,Arguments1),
4531 extract_arguments(MatchingFreeHeads,Arguments2),
4532 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4534 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4535 %
4536 % Returns list of arguments of given list of constraints.
4537 extract_arguments([],[]).
4538 extract_arguments([Constraint|Constraints],AllArguments) :-
4539 Constraint =.. [_|Arguments],
4540 append(Arguments,RestArguments,AllArguments),
4541 extract_arguments(Constraints,RestArguments).
4543 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4544 %
4545 % Substitutes arguments of constraints with those in the given list.
4547 substitute_arguments([],[],[]).
4548 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4549 functor(Constraint,F,N),
4550 split_at(N,Variables,Arguments,RestVariables),
4551 NConstraint =.. [F|Arguments],
4552 substitute_arguments(Constraints,RestVariables,NConstraints).
4554 make_matchings_explicit([],[],_,MC,MC,[]).
4555 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4556 ( var(Arg) ->
4557 ( memberchk_eq(Arg,VarAcc) ->
4558 list2disj(MatchingCondition,MatchingCondition_disj),
4559 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4560 NVarAcc = VarAcc
4561 ;
4562 Matchings = RestMatchings,
4563 NewVar = Arg,
4564 NVarAcc = [Arg|VarAcc]
4565 ),
4566 MatchingCondition2 = MatchingCondition
4567 ;
4568 functor(Arg,F,A),
4569 Arg =.. [F|RecArgs],
4570 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4571 FlatArg =.. [F|RecVars],
4572 ( RecMatchings == [] ->
4573 Matchings = [functor(NewVar,F,A)|RestMatchings]
4574 ;
4575 list2conj(RecMatchings,ArgM_conj),
4576 list2disj(MatchingCondition,MatchingCondition_disj),
4577 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4578 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4579 ),
4580 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4581 term_variables(Args,ArgVars),
4582 append(ArgVars,VarAcc,NVarAcc)
4583 ),
4584 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4587 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4588 %
4589 % Returns list of new variables and list of pairwise unifications between given list and variables.
4591 make_matchings_explicit_not_negated([],[],[]).
4592 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4593 Matchings = [Var = X|RMatchings],
4594 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4596 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4597 %
4598 % (Partially) applies substitutions of =Goal= to given list.
4600 apply_guard_wrt_term([],_Guard,[]).
4601 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4602 ( var(Term) ->
4603 apply_guard_wrt_variable(Guard,Term,NTerm)
4604 ;
4605 Term =.. [F|HArgs],
4606 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4607 NTerm =.. [F|NewHArgs]
4608 ),
4609 apply_guard_wrt_term(RH,Guard,RGH).
4611 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4612 %
4613 % (Partially) applies goal =Guard= wrt variable.
4615 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4616 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4617 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4618 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4619 ( Guard = (X = Y), Variable == X ->
4620 NVariable = Y
4621 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4622 functor(NVariable,Functor,Arity)
4623 ;
4624 NVariable = Variable
4625 ).
4627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4628 % ALWAYS FAILING HEADS
4629 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4631 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4632 <=>
4633 chr_pp_flag(check_impossible_rules,on),
4634 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4635 append(M,GuardList,Info),
4636 guard_entailment:entails_guard(Info,fail)
4637 |
4638 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4639 set_all_passive(RuleNb).
4641 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4642 % HEAD SIMPLIFICATION
4643 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4645 % now we check the head matchings (guard may have been simplified meanwhile)
4646 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4647 <=>
4648 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4649 simplify_heads(M,GuardList,G,B,NewM,NewB),
4650 NewM \== [],
4651 extract_arguments(Head1,VH1),
4652 extract_arguments(Head2,VH2),
4653 extract_arguments(H,VH),
4654 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4655 substitute_arguments(Head1,H1,NewH1),
4656 substitute_arguments(Head2,H2,NewH2),
4657 append(NewB,NewB_,NewBody),
4658 list2conj(NewBody,BodyMatchings),
4659 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4660 (Head1 \== NewH1 ; Head2 \== NewH2 )
4661 |
4662 rule(RuleNb,NewRule).
4664 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4665 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4666 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4668 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4669 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4670 ( NH == M ->
4671 H2_ = M,
4672 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4673 ;
4674 (M = functor(X,F,A), NH == X ->
4675 length(A_args,A),
4676 (var(H2) ->
4677 NewB1 = [],
4678 H2_ =.. [F|A_args]
4679 ;
4680 H2 =.. [F|OrigArgs],
4681 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4682 H2_ =.. [F|A_args_]
4683 ),
4684 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4685 append(NewB1,NewB2,NewB)
4686 ;
4687 H2_ = H2,
4688 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4689 )
4690 ).
4692 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4693 ( NH == M ->
4694 H1_ = M,
4695 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4696 ;
4697 (M = functor(X,F,A), NH == X ->
4698 length(A_args,A),
4699 (var(H1) ->
4700 NewB1 = [],
4701 H1_ =.. [F|A_args]
4702 ;
4703 H1 =.. [F|OrigArgs],
4704 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4705 H1_ =.. [F|A_args_]
4706 ),
4707 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4708 append(NewB1,NewB2,NewB)
4709 ;
4710 H1_ = H1,
4711 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4712 )
4713 ).
4715 use_same_args([],[],[],_,_,[]).
4716 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4717 var(OA),!,
4718 Out = OA,
4719 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4720 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4721 nonvar(OA),!,
4722 ( common_variables(OA,Body) ->
4723 NewB = [NA = OA|NextB]
4724 ;
4725 NewB = NextB
4726 ),
4727 Out = NA,
4728 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4731 simplify_heads([],_GuardList,_G,_Body,[],[]).
4732 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4733 M = (A = B),
4734 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4735 guard_entailment:entails_guard(GuardList,(A=B)) ->
4736 ( common_variables(B,G-RM-GuardList) ->
4737 NewB = NextB,
4738 NewM = NextM
4739 ;
4740 ( common_variables(B,Body) ->
4741 NewB = [A = B|NextB]
4742 ;
4743 NewB = NextB
4744 ),
4745 NewM = [A|NextM]
4746 )
4747 ;
4748 ( nonvar(B), functor(B,BFu,BAr),
4749 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4750 NewB = NextB,
4751 ( common_variables(B,G-RM-GuardList) ->
4752 NewM = NextM
4753 ;
4754 NewM = [functor(A,BFu,BAr)|NextM]
4755 )
4756 ;
4757 NewM = NextM,
4758 NewB = NextB
4759 )
4760 ),
4761 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4763 common_variables(B,G) :-
4764 term_variables(B,BVars),
4765 term_variables(G,GVars),
4766 intersect_eq(BVars,GVars,L),
4767 L \== [].
4770 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4771 % ALWAYS FAILING GUARDS
4772 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4774 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4775 set_all_passive(_) <=> true.
4777 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4778 ==>
4779 chr_pp_flag(check_impossible_rules,on),
4780 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4781 conj2list(G,GL),
4782 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4783 guard_entailment:entails_guard(GL,fail)
4784 |
4785 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4786 set_all_passive(RuleNb).
4790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4791 % OCCURRENCE SUBSUMPTION
4792 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4794 :- chr_constraint
4795 first_occ_in_rule/4,
4796 next_occ_in_rule/6.
4798 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4799 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4801 :- chr_constraint multiple_occ_constraints_checked/1.
4802 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4804 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4805 occurrence(C,O,RuleNb,ID,_),
4806 occurrence(C,O2,RuleNb,ID2,_),
4807 rule(RuleNb,Rule)
4808 \
4809 multiple_occ_constraints_checked(Done)
4810 <=>
4811 O < O2,
4812 chr_pp_flag(occurrence_subsumption,on),
4813 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4814 H1 \== [],
4815 \+ memberchk_eq(C,Done)
4816 |
4817 first_occ_in_rule(RuleNb,C,O,ID),
4818 multiple_occ_constraints_checked([C|Done]).
4820 % Find first occurrence of constraint =C= in rule =RuleNb=
4821 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4822 <=>
4823 O < O2
4824 |
4825 first_occ_in_rule(RuleNb,C,O,ID).
4827 first_occ_in_rule(RuleNb,C,O,ID_o1)
4828 <=>
4829 C = F/A,
4830 functor(FreshHead,F,A),
4831 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4833 % Skip passive occurrences.
4834 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4835 <=>
4836 O2 is O+1
4837 |
4838 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4840 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)
4841 <=>
4842 O2 is O+1,
4843 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4844 |
4845 append(H1,H2,Heads),
4846 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4847 ( ExtraCond == [chr_pp_void_info] ->
4848 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4849 ;
4850 append(ExtraCond,Cond,NewCond),
4851 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4852 copy_term(GuardList,FGuardList),
4853 variable_replacement(GuardList,FGuardList,GLRepl),
4854 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4855 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4856 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4857 append(NewCond,GuardList2,BigCond),
4858 append(BigCond,GuardList3,BigCond2),
4859 copy_with_variable_replacement(M,M2,Repl),
4860 copy_with_variable_replacement(M,M3,Repl2),
4861 append(M3,BigCond2,BigCond3),
4862 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4863 list2conj(CheckCond,OccSubsum),
4864 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4865 ( OccSubsum \= chr_pp_void_info ->
4866 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4867 passive(RuleNb,ID_o2)
4868 ;
4869 true
4870 )
4871 ;
4872 true
4873 ),!,
4874 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4875 ).
4878 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4879 <=>
4880 true.
4882 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4883 <=>
4884 true.
4886 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4887 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4888 append(ID2,ID1,IDs),
4889 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4890 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4891 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4892 copy_with_variable_replacement(G,FG,Repl),
4893 extract_explicit_matchings(FG,FG2),
4894 negate_b(FG2,NotFG),
4895 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4896 ( safely_unifiable(FH,FH2), FH=FH2 ->
4897 FailCond = [(NotFG;FMPCond)]
4898 ;
4899 % in this case, not much can be done
4900 % e.g. c(f(...)), c(g(...)) <=> ...
4901 FailCond = [chr_pp_void_info]
4902 ).
4904 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4905 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4906 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4907 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4908 Cond = (chr_pp_not_in_store(H);Cond1),
4909 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4911 extract_explicit_matchings((A,B),D) :- !,
4912 ( extract_explicit_matchings(A) ->
4913 extract_explicit_matchings(B,D)
4914 ;
4915 D = (A,E),
4916 extract_explicit_matchings(B,E)
4917 ).
4918 extract_explicit_matchings(A,D) :- !,
4919 ( extract_explicit_matchings(A) ->
4920 D = true
4921 ;
4922 D = A
4923 ).
4925 extract_explicit_matchings(A=B) :-
4926 var(A), var(B), !, A=B.
4927 extract_explicit_matchings(A==B) :-
4928 var(A), var(B), !, A=B.
4930 safely_unifiable(H,I) :- var(H), !.
4931 safely_unifiable([],[]) :- !.
4932 safely_unifiable([H|Hs],[I|Is]) :- !,
4933 safely_unifiable(H,I),
4934 safely_unifiable(Hs,Is).
4935 safely_unifiable(H,I) :-
4936 nonvar(H),
4937 nonvar(I),
4938 H =.. [F|HA],
4939 I =.. [F|IA],
4940 safely_unifiable(HA,IA).
4944 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4945 % TYPE INFORMATION
4946 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4948 :- chr_constraint
4949 type_definition/2,
4950 type_alias/2,
4951 constraint_type/2,
4952 get_type_definition/2,
4953 get_constraint_type/2.
4956 :- chr_option(mode,type_definition(?,?)).
4957 :- chr_option(mode,get_type_definition(?,?)).
4958 :- chr_option(mode,type_alias(?,?)).
4959 :- chr_option(mode,constraint_type(+,+)).
4960 :- chr_option(mode,get_constraint_type(+,-)).
4962 assert_constraint_type(Constraint,ArgTypes) :-
4963 ( ground(ArgTypes) ->
4964 constraint_type(Constraint,ArgTypes)
4965 ;
4966 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
4967 ).
4969 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4970 % Consistency checks of type aliases
4972 type_alias(T,T2) <=>
4973 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4974 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4975 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4977 type_alias(T1,A1), type_alias(T2,A2) <=>
4978 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4979 \+ (T1\=T2) |
4980 copy_term_nat(T1,T1_),
4981 copy_term_nat(T2,T2_),
4982 T1_ = T2_,
4983 chr_error(type_error,
4984 '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_]).
4986 type_alias(T,B) \ type_alias(X,T2) <=>
4987 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4988 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4989 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4990 type_alias(X2,D1).
4992 oneway_unification(X,Y) :-
4993 term_variables(X,XVars),
4994 chr_runtime:lockv(XVars),
4995 X=Y,
4996 chr_runtime:unlockv(XVars).
4998 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4999 % Consistency checks of type definitions
5001 type_definition(T1,_), type_definition(T2,_)
5002 <=>
5003 functor(T1,F,A), functor(T2,F,A)
5004 |
5005 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5007 type_definition(T1,_), type_alias(T2,_)
5008 <=>
5009 functor(T1,F,A), functor(T2,F,A)
5010 |
5011 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5013 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5014 %% get_type_definition(+Type,-Definition) is semidet.
5015 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5017 get_type_definition(T,Def)
5018 <=>
5019 \+ ground(T)
5020 |
5021 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5023 type_alias(T,D) \ get_type_definition(T2,Def)
5024 <=>
5025 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5026 copy_term_nat((T,D),(T1,D1)),T1=T2
5027 |
5028 ( get_type_definition(D1,Def) ->
5029 true
5030 ;
5031 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5032 ).
5034 type_definition(T,D) \ get_type_definition(T2,Def)
5035 <=>
5036 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5037 copy_term_nat((T,D),(T1,D1)),T1=T2
5038 |
5039 Def = D1.
5041 get_type_definition(Type,Def)
5042 <=>
5043 atomic_builtin_type(Type,_,_)
5044 |
5045 Def = [Type].
5047 get_type_definition(Type,Def)
5048 <=>
5049 compound_builtin_type(Type,_,_)
5050 |
5051 Def = [Type].
5053 get_type_definition(X,Y) <=> fail.
5055 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5056 %% get_type_definition_det(+Type,-Definition) is det.
5057 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5058 get_type_definition_det(Type,Definition) :-
5059 ( get_type_definition(Type,Definition) ->
5060 true
5061 ;
5062 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5063 ).
5065 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5066 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5067 %
5068 % Return argument types of =ConstraintSymbol=, but fails if none where
5069 % declared.
5070 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5071 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5072 get_constraint_type(_,_) <=> fail.
5074 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5075 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5076 %
5077 % Like =get_constraint_type/2=, but returns list of =any= types when
5078 % no types are declared.
5079 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5080 get_constraint_type_det(ConstraintSymbol,Types) :-
5081 ( get_constraint_type(ConstraintSymbol,Types) ->
5082 true
5083 ;
5084 ConstraintSymbol = _ / N,
5085 replicate(N,any,Types)
5086 ).
5087 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5088 %% unalias_type(+Alias,-Type) is det.
5089 %
5090 % Follows alias chain until base type is reached.
5091 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5092 :- chr_constraint unalias_type/2.
5094 unalias_var @
5095 unalias_type(Alias,BaseType)
5096 <=>
5097 var(Alias)
5098 |
5099 BaseType = Alias.
5101 unalias_alias @
5102 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5103 <=>
5104 nonvar(AliasProtoType),
5105 nonvar(Alias),
5106 functor(AliasProtoType,F,A),
5107 functor(Alias,F,A),
5108 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5109 Alias = AliasInstance
5110 |
5111 unalias_type(Type,BaseType).
5113 unalias_type_definition @
5114 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5115 <=>
5116 nonvar(ProtoType),
5117 nonvar(Alias),
5118 functor(ProtoType,F,A),
5119 functor(Alias,F,A)
5120 |
5121 BaseType = Alias.
5123 unalias_atomic_builtin @
5124 unalias_type(Alias,BaseType)
5125 <=>
5126 atomic_builtin_type(Alias,_,_)
5127 |
5128 BaseType = Alias.
5130 unalias_compound_builtin @
5131 unalias_type(Alias,BaseType)
5132 <=>
5133 compound_builtin_type(Alias,_,_)
5134 |
5135 BaseType = Alias.
5137 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5138 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5139 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5140 :- chr_constraint types_modes_condition/3.
5141 :- chr_option(mode,types_modes_condition(+,+,?)).
5142 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5144 types_modes_condition([],[],T) <=> T=true.
5146 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5147 <=>
5148 functor(Head,F,A)
5149 |
5150 Head =.. [_|Args],
5151 Condition = (ModesCondition, TypesCondition, RestCondition),
5152 modes_condition(Modes,Args,ModesCondition),
5153 get_constraint_type_det(F/A,Types),
5154 UnrollHead =.. [_|RealArgs],
5155 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5156 types_modes_condition(Heads,UnrollHeads,RestCondition).
5158 types_modes_condition([Head|_],_,_)
5159 <=>
5160 functor(Head,F,A),
5161 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5164 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5165 %% modes_condition(+Modes,+Args,-Condition) is det.
5166 %
5167 % Return =Condition= on =Args= that checks =Modes=.
5168 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5169 modes_condition([],[],true).
5170 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5171 ( Mode == (+) ->
5172 Condition = ( ground(Arg) , RCondition )
5173 ; Mode == (-) ->
5174 Condition = ( var(Arg) , RCondition )
5175 ;
5176 Condition = RCondition
5177 ),
5178 modes_condition(Modes,Args,RCondition).
5180 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5181 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5182 %
5183 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5184 % =UnrollArgs= controls the depth of type definition unrolling.
5185 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5186 types_condition([],[],[],[],true).
5187 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5188 ( Mode == (-) ->
5189 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5190 ;
5191 get_type_definition_det(Type,Def),
5192 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5193 ( Mode == (+) ->
5194 TypeConditionList = TypeConditionList1
5195 ;
5196 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5197 )
5198 ),
5199 list2disj(TypeConditionList,DisjTypeConditionList),
5200 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5202 type_condition([],_,_,_,[]).
5203 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5204 ( var(DefCase) ->
5205 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5206 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5207 true
5208 ; compound_builtin_type(DefCase,Arg,Condition) ->
5209 true
5210 ;
5211 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5212 ),
5213 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5215 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5216 :- chr_type atomic_builtin_type ---> any
5217 ; number
5218 ; float
5219 ; int
5220 ; natural
5221 ; dense_int
5222 ; chr_identifier
5223 ; chr_identifier(any).
5224 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5226 atomic_builtin_type(any,_Arg,true).
5227 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5228 atomic_builtin_type(int,Arg,integer(Arg)).
5229 atomic_builtin_type(number,Arg,number(Arg)).
5230 atomic_builtin_type(float,Arg,float(Arg)).
5231 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5232 atomic_builtin_type(chr_identifier,_Arg,true).
5234 compound_builtin_type(chr_identifier(_),_Arg,true).
5236 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5237 ( nonvar(DefCase) ->
5238 functor(DefCase,F,A),
5239 ( A == 0 ->
5240 Condition = (Arg = DefCase)
5241 ; var(UnrollArg) ->
5242 Condition = functor(Arg,F,A)
5243 ; functor(UnrollArg,F,A) ->
5244 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5245 DefCase =.. [_|ArgTypes],
5246 UnrollArg =.. [_|UnrollArgs],
5247 functor(Template,F,A),
5248 Template =.. [_|TemplateArgs],
5249 replicate(A,Mode,ArgModes),
5250 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5251 ;
5252 Condition = functor(Arg,F,A)
5253 )
5254 ;
5255 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5256 ).
5259 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5260 % STATIC TYPE CHECKING
5261 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5262 % Checks head constraints and CHR constraint calls in bodies.
5263 %
5264 % TODO:
5265 % - type clashes involving built-in types
5266 % - Prolog built-ins in guard and body
5267 % - indicate position in terms in error messages
5268 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5269 :- chr_constraint
5270 static_type_check/0.
5273 % 1. Check the declared types
5275 constraint_type(Constraint,ArgTypes), static_type_check
5276 ==>
5277 forall(
5278 ( member(ArgType,ArgTypes), forsubterm(ArgType,Type) ),
5279 ( get_type_definition(Type,_) ->
5280 true
5281 ;
5282 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5283 )
5284 ).
5287 forsubterm(Term,SubTerm) :-
5288 (
5289 SubTerm = Term
5290 ;
5291 Term =.. [_|Args],
5292 member(Arg,Args),
5293 forsubterm(Arg,SubTerm)
5294 ).
5297 % 2. Check the rules
5299 :- chr_type type_error_src ---> head(any) ; body(any).
5301 rule(_,Rule), static_type_check
5302 ==>
5303 copy_term_nat(Rule,RuleCopy),
5304 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5305 (
5306 catch(
5307 ( static_type_check_heads(Head1),
5308 static_type_check_heads(Head2),
5309 conj2list(Body,GoalList),
5310 static_type_check_body(GoalList)
5311 ),
5312 type_error(Error),
5313 ( Error = invalid_functor(Src,Term,Type) ->
5314 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5315 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5316 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5317 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5318 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5319 )
5320 ),
5321 fail % cleanup constraints
5322 ;
5323 true
5324 ).
5327 static_type_check <=> true.
5329 static_type_check_heads([]).
5330 static_type_check_heads([Head|Heads]) :-
5331 static_type_check_head(Head),
5332 static_type_check_heads(Heads).
5334 static_type_check_head(Head) :-
5335 functor(Head,F,A),
5336 get_constraint_type_det(F/A,Types),
5337 Head =..[_|Args],
5338 maplist(static_type_check_term(head(Head)),Args,Types).
5340 static_type_check_body([]).
5341 static_type_check_body([Goal|Goals]) :-
5342 functor(Goal,F,A),
5343 get_constraint_type_det(F/A,Types),
5344 Goal =..[_|Args],
5345 maplist(static_type_check_term(body(Goal)),Args,Types),
5346 static_type_check_body(Goals).
5348 :- chr_constraint static_type_check_term/3.
5349 :- chr_option(mode,static_type_check_term(?,?,?)).
5350 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5352 static_type_check_term(Src,Term,Type)
5353 <=>
5354 var(Term)
5355 |
5356 static_type_check_var(Src,Term,Type).
5357 static_type_check_term(Src,Term,Type)
5358 <=>
5359 atomic_builtin_type(Type,Term,Goal)
5360 |
5361 ( call(Goal) ->
5362 true
5363 ;
5364 throw(type_error(invalid_functor(Src,Term,Type)))
5365 ).
5366 static_type_check_term(Src,Term,Type)
5367 <=>
5368 compound_builtin_type(Type,Term,Goal)
5369 |
5370 ( call(Goal) ->
5371 true
5372 ;
5373 throw(type_error(invalid_functor(Src,Term,Type)))
5374 ).
5375 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5376 <=>
5377 functor(Type,F,A),
5378 functor(AType,F,A)
5379 |
5380 copy_term_nat(AType-ADef,Type-Def),
5381 static_type_check_term(Src,Term,Def).
5383 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5384 <=>
5385 functor(Type,F,A),
5386 functor(AType,F,A)
5387 |
5388 copy_term_nat(AType-ADef,Type-Variants),
5389 functor(Term,TF,TA),
5390 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5391 Term =.. [_|Args],
5392 Variant =.. [_|Types],
5393 maplist(static_type_check_term(Src),Args,Types)
5394 ;
5395 throw(type_error(invalid_functor(Src,Term,Type)))
5396 ).
5398 static_type_check_term(Src,Term,Type)
5399 <=>
5400 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5402 :- chr_constraint static_type_check_var/3.
5403 :- chr_option(mode,static_type_check_var(?,-,?)).
5404 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5406 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5407 <=>
5408 functor(AType,F,A),
5409 functor(Type,F,A)
5410 |
5411 copy_term_nat(AType-ADef,Type-Def),
5412 static_type_check_var(Src,Var,Def).
5414 static_type_check_var(Src,Var,Type)
5415 <=>
5416 atomic_builtin_type(Type,_,_)
5417 |
5418 static_atomic_builtin_type_check_var(Src,Var,Type).
5420 static_type_check_var(Src,Var,Type)
5421 <=>
5422 compound_builtin_type(Type,_,_)
5423 |
5424 true.
5427 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5428 <=>
5429 Type1 \== Type2
5430 |
5431 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5433 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5434 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5435 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5436 :- chr_constraint static_atomic_builtin_type_check_var/3.
5437 :- chr_option(mode,static_type_check_var(?,-,+)).
5438 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5440 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5441 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5442 <=>
5443 true.
5444 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5445 <=>
5446 true.
5447 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5448 <=>
5449 true.
5450 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5451 <=>
5452 true.
5453 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5454 <=>
5455 true.
5456 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5457 <=>
5458 true.
5459 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5460 <=>
5461 true.
5462 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5463 <=>
5464 true.
5465 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5466 <=>
5467 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5469 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5470 %% format_src(+type_error_src) is det.
5471 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5472 format_src(head(Head)) :- format('head ~w',[Head]).
5473 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5475 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5476 % Dynamic type checking
5477 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5479 :- chr_constraint
5480 dynamic_type_check/0,
5481 dynamic_type_check_clauses/1,
5482 get_dynamic_type_check_clauses/1.
5484 generate_dynamic_type_check_clauses(Clauses) :-
5485 ( chr_pp_flag(debugable,on) ->
5486 dynamic_type_check,
5487 get_dynamic_type_check_clauses(Clauses0),
5488 append(Clauses0,
5489 [('$dynamic_type_check'(Type,Term) :-
5490 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5491 )],
5492 Clauses)
5493 ;
5494 Clauses = []
5495 ).
5497 type_definition(T,D), dynamic_type_check
5498 ==>
5499 copy_term_nat(T-D,Type-Definition),
5500 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5501 dynamic_type_check_clauses(DynamicChecks).
5502 type_alias(A,B), dynamic_type_check
5503 ==>
5504 copy_term_nat(A-B,Alias-Body),
5505 dynamic_type_check_alias_clause(Alias,Body,Clause),
5506 dynamic_type_check_clauses([Clause]).
5508 dynamic_type_check <=>
5509 findall(
5510 ('$dynamic_type_check'(Type,Term) :- Goal),
5511 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
5512 BuiltinChecks
5513 ),
5514 dynamic_type_check_clauses(BuiltinChecks).
5516 dynamic_type_check_clause(T,DC,Clause) :-
5517 copy_term(T-DC,Type-DefinitionClause),
5518 functor(DefinitionClause,F,A),
5519 functor(Term,F,A),
5520 DefinitionClause =.. [_|DCArgs],
5521 Term =.. [_|TermArgs],
5522 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5523 list2conj(RecursiveCallList,RecursiveCalls),
5524 Clause = (
5525 '$dynamic_type_check'(Type,Term) :-
5526 RecursiveCalls
5527 ).
5529 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5530 Clause = (
5531 '$dynamic_type_check'(Alias,Term) :-
5532 '$dynamic_type_check'(Body,Term)
5533 ).
5535 dynamic_type_check_call(Type,Term,Call) :-
5536 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5537 % Call = when(nonvar(Term),Goal)
5538 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5539 % Call = when(nonvar(Term),Goal)
5540 % ;
5541 ( Type == any ->
5542 Call = true
5543 ;
5544 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5545 )
5546 % )
5547 .
5549 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5550 <=>
5551 append(C1,C2,C),
5552 dynamic_type_check_clauses(C).
5554 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5555 <=>
5556 Q = C.
5557 get_dynamic_type_check_clauses(Q)
5558 <=>
5559 Q = [].
5561 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5562 % Atomic Types
5563 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5564 % Some optimizations can be applied for atomic types...
5565 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5567 atomic_types_suspended_constraint(C) :-
5568 C = _/N,
5569 get_constraint_type(C,ArgTypes),
5570 get_constraint_mode(C,ArgModes),
5571 findall(I,between(1,N,I),Indexes),
5572 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5574 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5575 ( is_indexed_argument(C,Index) ->
5576 ( Mode == (?) ->
5577 atomic_type(Type)
5578 ;
5579 true
5580 )
5581 ;
5582 true
5583 ).
5585 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5586 %% atomic_type(+Type) is semidet.
5587 %
5588 % Succeeds when all values of =Type= are atomic.
5589 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5590 :- chr_constraint atomic_type/1.
5592 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5594 type_definition(TypePat,Def) \ atomic_type(Type)
5595 <=>
5596 functor(Type,F,A), functor(TypePat,F,A)
5597 |
5598 forall(member(Term,Def),atomic(Term)).
5600 type_alias(TypePat,Alias) \ atomic_type(Type)
5601 <=>
5602 functor(Type,F,A), functor(TypePat,F,A)
5603 |
5604 atomic(Alias),
5605 copy_term_nat(TypePat-Alias,Type-NType),
5606 atomic_type(NType).
5608 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5609 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5610 %
5611 % Succeeds when all values of =Type= are atomic
5612 % and the atom values are finitely enumerable.
5613 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5614 :- chr_constraint enumerated_atomic_type/2.
5616 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5618 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5619 <=>
5620 functor(Type,F,A), functor(TypePat,F,A)
5621 |
5622 forall(member(Term,Def),atomic(Term)),
5623 Atoms = Def.
5625 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5626 <=>
5627 functor(Type,F,A), functor(TypePat,F,A)
5628 |
5629 atomic(Alias),
5630 copy_term_nat(TypePat-Alias,Type-NType),
5631 enumerated_atomic_type(NType,Atoms).
5632 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5634 :- chr_constraint
5635 stored/3, % constraint,occurrence,(yes/no/maybe)
5636 stored_completing/3,
5637 stored_complete/3,
5638 is_stored/1,
5639 is_finally_stored/1,
5640 check_all_passive/2.
5642 :- chr_option(mode,stored(+,+,+)).
5643 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5644 :- chr_type storedinfo ---> yes ; no ; maybe.
5645 :- chr_option(mode,stored_complete(+,+,+)).
5646 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5647 :- chr_option(mode,guard_list(+,+,+,+)).
5648 :- chr_option(mode,check_all_passive(+,+)).
5649 :- chr_option(type_declaration,check_all_passive(any,list)).
5651 % change yes in maybe when yes becomes passive
5652 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5653 stored(C,O,yes), stored_complete(C,RO,Yesses)
5654 <=> O < RO | NYesses is Yesses - 1,
5655 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5656 % change yes in maybe when not observed
5657 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5658 <=> O < RO |
5659 NYesses is Yesses - 1,
5660 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5662 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5663 ==> RO =< MO2 | % C2 is never stored
5664 passive(RuleNb,ID).
5669 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5671 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5672 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5673 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5675 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5676 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5677 check_all_passive(RuleNb,IDs2).
5679 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5680 check_all_passive(RuleNb,IDs).
5682 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5683 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5685 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5687 % collect the storage information
5688 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5689 <=> NO is O + 1, NYesses is Yesses + 1,
5690 stored_completing(C,NO,NYesses).
5691 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5692 <=> NO is O + 1,
5693 stored_completing(C,NO,Yesses).
5695 stored(C,O,no) \ stored_completing(C,O,Yesses)
5696 <=> stored_complete(C,O,Yesses).
5697 stored_completing(C,O,Yesses)
5698 <=> stored_complete(C,O,Yesses).
5700 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5701 O2 > O | passive(RuleNb,Id).
5703 % decide whether a constraint is stored
5704 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5705 <=> RO =< MO | fail.
5706 is_stored(C) <=> true.
5708 % decide whether a constraint is suspends after occurrences
5709 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5710 <=> RO =< MO | fail.
5711 is_finally_stored(C) <=> true.
5713 storage_analysis(Constraints) :-
5714 ( chr_pp_flag(storage_analysis,on) ->
5715 check_constraint_storages(Constraints)
5716 ;
5717 true
5718 ).
5720 check_constraint_storages([]).
5721 check_constraint_storages([C|Cs]) :-
5722 check_constraint_storage(C),
5723 check_constraint_storages(Cs).
5725 check_constraint_storage(C) :-
5726 get_max_occurrence(C,MO),
5727 check_occurrences_storage(C,1,MO).
5729 check_occurrences_storage(C,O,MO) :-
5730 ( O > MO ->
5731 stored_completing(C,1,0)
5732 ;
5733 check_occurrence_storage(C,O),
5734 NO is O + 1,
5735 check_occurrences_storage(C,NO,MO)
5736 ).
5738 check_occurrence_storage(C,O) :-
5739 get_occurrence(C,O,RuleNb,ID),
5740 ( is_passive(RuleNb,ID) ->
5741 stored(C,O,maybe)
5742 ;
5743 get_rule(RuleNb,PragmaRule),
5744 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5745 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5746 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5747 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5748 check_storage_head2(Head2,O,Heads1,Body)
5749 )
5750 ).
5752 check_storage_head1(Head,O,H1,H2,G) :-
5753 functor(Head,F,A),
5754 C = F/A,
5755 ( H1 == [Head],
5756 H2 == [],
5757 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5758 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5759 Head =.. [_|L],
5760 no_matching(L,[]) ->
5761 stored(C,O,no)
5762 ;
5763 stored(C,O,maybe)
5764 ).
5766 no_matching([],_).
5767 no_matching([X|Xs],Prev) :-
5768 var(X),
5769 \+ memberchk_eq(X,Prev),
5770 no_matching(Xs,[X|Prev]).
5772 check_storage_head2(Head,O,H1,B) :-
5773 functor(Head,F,A),
5774 C = F/A,
5775 ( %(
5776 ( H1 \== [], B == true )
5777 %;
5778 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5779 %)
5780 ->
5781 stored(C,O,maybe)
5782 ;
5783 stored(C,O,yes)
5784 ).
5786 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5788 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5789 %% ____ _ ____ _ _ _ _
5790 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5791 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5792 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5793 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5794 %% |_|
5796 constraints_code(Constraints,Clauses) :-
5797 (chr_pp_flag(reduced_indexing,on),
5798 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5799 none_suspended_on_variables
5800 ;
5801 true
5802 ),
5803 constraints_code1(Constraints,Clauses,[]).
5805 %===============================================================================
5806 :- chr_constraint constraints_code1/3.
5807 :- chr_option(mode,constraints_code1(+,+,+)).
5808 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5809 %-------------------------------------------------------------------------------
5810 constraints_code1([],L,T) <=> L = T.
5811 constraints_code1([C|RCs],L,T)
5812 <=>
5813 constraint_code(C,L,T1),
5814 constraints_code1(RCs,T1,T).
5815 %===============================================================================
5816 :- chr_constraint constraint_code/3.
5817 :- chr_option(mode,constraint_code(+,+,+)).
5818 %-------------------------------------------------------------------------------
5819 %% Generate code for a single CHR constraint
5820 constraint_code(Constraint, L, T)
5821 <=> true
5822 | ( (chr_pp_flag(debugable,on) ;
5823 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5824 ( may_trigger(Constraint) ;
5825 get_allocation_occurrence(Constraint,AO),
5826 get_max_occurrence(Constraint,MO), MO >= AO ) )
5827 ->
5828 constraint_prelude(Constraint,Clause),
5829 add_dummy_location(Clause,LocatedClause),
5830 L = [LocatedClause | L1]
5831 ;
5832 L = L1
5833 ),
5834 Id = [0],
5835 occurrences_code(Constraint,1,Id,NId,L1,L2),
5836 gen_cond_attach_clause(Constraint,NId,L2,T).
5838 %===============================================================================
5839 %% Generate prelude predicate for a constraint.
5840 %% f(...) :- f/a_0(...,Susp).
5841 constraint_prelude(F/A, Clause) :-
5842 vars_susp(A,Vars,Susp,VarsSusp),
5843 Head =.. [ F | Vars],
5844 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5845 build_head(F,A,[0],VarsSusp,Delegate),
5846 ( chr_pp_flag(debugable,on) ->
5847 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5848 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5849 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5850 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5852 ( get_constraint_type(F/A,ArgTypeList) ->
5853 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5854 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5855 ;
5856 DynamicTypeChecks = true
5857 ),
5859 Clause =
5860 ( Head :-
5861 DynamicTypeChecks,
5862 InsertGoal,
5863 InsertCall,
5864 AttachCall,
5865 Inactive,
5866 'chr debug_event'(insert(Head#Susp)),
5867 (
5868 'chr debug_event'(call(Susp)),
5869 Delegate
5870 ;
5871 'chr debug_event'(fail(Susp)), !,
5872 fail
5873 ),
5874 (
5875 'chr debug_event'(exit(Susp))
5876 ;
5877 'chr debug_event'(redo(Susp)),
5878 fail
5879 )
5880 )
5881 ; get_allocation_occurrence(F/A,0) ->
5882 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5883 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5884 Clause = ( Head :- Goal, Inactive, Delegate )
5885 ;
5886 Clause = ( Head :- Delegate )
5887 ).
5889 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5890 ( may_trigger(F/A) ->
5891 build_head(F,A,[0],VarsSusp,Delegate),
5892 ( chr_pp_flag(debugable,off) ->
5893 Goal = Delegate
5894 ;
5895 get_target_module(Mod),
5896 Goal = Mod:Delegate
5897 )
5898 ;
5899 Goal = true
5900 ).
5902 %===============================================================================
5903 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5904 :- chr_option(mode,has_active_occurrence(+)).
5905 :- chr_option(mode,has_active_occurrence(+,+)).
5906 %-------------------------------------------------------------------------------
5907 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5909 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5910 O > MO | fail.
5911 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5912 has_active_occurrence(C,O) <=>
5913 NO is O + 1,
5914 has_active_occurrence(C,NO).
5915 has_active_occurrence(C,O) <=> true.
5916 %===============================================================================
5918 gen_cond_attach_clause(F/A,Id,L,T) :-
5919 ( is_finally_stored(F/A) ->
5920 get_allocation_occurrence(F/A,AllocationOccurrence),
5921 get_max_occurrence(F/A,MaxOccurrence),
5922 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5923 ( only_ground_indexed_arguments(F/A) ->
5924 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5925 ;
5926 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5927 )
5928 ; vars_susp(A,Args,Susp,AllArgs),
5929 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5930 ),
5931 build_head(F,A,Id,AllArgs,Head),
5932 Clause = ( Head :- Body ),
5933 add_dummy_location(Clause,LocatedClause),
5934 L = [LocatedClause | T]
5935 ;
5936 L = T
5937 ).
5939 :- chr_constraint use_auxiliary_predicate/1.
5940 :- chr_option(mode,use_auxiliary_predicate(+)).
5942 :- chr_constraint use_auxiliary_predicate/2.
5943 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5945 :- chr_constraint is_used_auxiliary_predicate/1.
5946 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5948 :- chr_constraint is_used_auxiliary_predicate/2.
5949 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5952 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5954 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5956 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5958 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5960 is_used_auxiliary_predicate(P) <=> fail.
5962 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5963 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5965 is_used_auxiliary_predicate(P,C) <=> fail.
5967 %------------------------------------------------------------------------------%
5968 % Only generate import statements for actually used modules.
5969 %------------------------------------------------------------------------------%
5971 :- chr_constraint use_auxiliary_module/1.
5972 :- chr_option(mode,use_auxiliary_module(+)).
5974 :- chr_constraint is_used_auxiliary_module/1.
5975 :- chr_option(mode,is_used_auxiliary_module(+)).
5978 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5980 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5982 is_used_auxiliary_module(P) <=> fail.
5984 % only called for constraints with
5985 % at least one
5986 % non-ground indexed argument
5987 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5988 vars_susp(A,Args,Susp,AllArgs),
5989 make_suspension_continuation_goal(F/A,AllArgs,Closure),
5990 ( get_store_type(F/A,var_assoc_store(_,_)) ->
5991 Attach = true
5992 ;
5993 attach_constraint_atom(F/A,Vars,Susp,Attach)
5994 ),
5995 FTerm =.. [F|Args],
5996 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5997 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5998 ( may_trigger(F/A) ->
5999 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6000 Goal =
6001 (
6002 ( var(Susp) ->
6003 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6004 InsertCall,
6005 Attach
6006 ;
6007 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6008 )
6009 )
6010 ;
6011 Goal =
6012 (
6013 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6014 InsertCall,
6015 Attach
6016 )
6017 ).
6019 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6020 vars_susp(A,Args,Susp,AllArgs),
6021 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6022 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6023 attach_constraint_atom(F/A,Vars,Susp,Attach)
6024 ;
6025 Attach = true
6026 ),
6027 FTerm =.. [F|Args],
6028 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6029 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6030 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6031 Goal =
6032 (
6033 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6034 InsertCall
6035 )
6036 ;
6037 Goal =
6038 (
6039 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6040 InsertCall,
6041 Attach
6042 )
6043 ).
6045 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6046 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6047 attach_constraint_atom(FA,Vars,Susp,Attach)
6048 ;
6049 Attach = true
6050 ),
6051 insert_constraint_goal(FA,Susp,Args,InsertCall),
6052 ( chr_pp_flag(late_allocation,on) ->
6053 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6054 ;
6055 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6056 ).
6058 %-------------------------------------------------------------------------------
6059 :- chr_constraint occurrences_code/6.
6060 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6061 %-------------------------------------------------------------------------------
6062 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6063 <=> O > MO
6064 | NId = Id, L = T.
6065 occurrences_code(C,O,Id,NId,L,T)
6066 <=>
6067 occurrence_code(C,O,Id,Id1,L,L1),
6068 NO is O + 1,
6069 occurrences_code(C,NO,Id1,NId,L1,T).
6070 %-------------------------------------------------------------------------------
6071 :- chr_constraint occurrence_code/6.
6072 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6073 %-------------------------------------------------------------------------------
6074 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6075 <=>
6076 ( named_history(RuleNb,_,_) ->
6077 does_use_history(C,O)
6078 ;
6079 true
6080 ),
6081 NId = Id,
6082 L = T.
6083 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6084 <=> true |
6085 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6086 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6087 NId = Id,
6088 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6089 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6090 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6091 ( should_skip_to_next_id(C,O) ->
6092 inc_id(Id,NId),
6093 ( unconditional_occurrence(C,O) ->
6094 L1 = T
6095 ;
6096 gen_alloc_inc_clause(C,O,Id,L1,T)
6097 )
6098 ;
6099 NId = Id,
6100 L1 = T
6101 )
6102 ).
6104 occurrence_code(C,O,_,_,_,_)
6105 <=>
6106 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6107 %-------------------------------------------------------------------------------
6109 %% Generate code based on one removed head of a CHR rule
6110 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6111 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6112 Rule = rule(_,Head2,_,_),
6113 ( Head2 == [] ->
6114 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6115 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6116 ;
6117 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6118 ).
6120 %% Generate code based on one persistent head of a CHR rule
6121 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6122 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6123 Rule = rule(Head1,_,_,_),
6124 ( Head1 == [] ->
6125 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6126 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6127 ;
6128 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6129 ).
6131 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6132 vars_susp(A,Vars,Susp,VarsSusp),
6133 build_head(F,A,Id,VarsSusp,Head),
6134 inc_id(Id,IncId),
6135 build_head(F,A,IncId,VarsSusp,CallHead),
6136 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6137 Clause =
6138 (
6139 Head :-
6140 ConditionalAlloc,
6141 CallHead
6142 ),
6143 add_dummy_location(Clause,LocatedClause),
6144 L = [LocatedClause|T].
6146 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6147 get_allocation_occurrence(FA,AO),
6148 ( chr_pp_flag(debugable,off), O == AO ->
6149 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6150 ( may_trigger(FA) ->
6151 Goal = (var(Susp) -> Goal0 ; true)
6152 ;
6153 Goal = Goal0
6154 )
6155 ;
6156 Goal = true
6157 ).
6159 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6160 get_allocation_occurrence(FA,AO),
6161 ( chr_pp_flag(debugable,off), O < AO ->
6162 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6163 ( may_trigger(FA) ->
6164 Goal = (var(Susp) -> Goal0 ; true)
6165 ;
6166 Goal = Goal0
6167 )
6168 ;
6169 Goal = true
6170 ).
6172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6174 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6175 %
6176 % Reorders guard goals with respect to partner constraint retrieval goals and
6177 % active constraint. Returns combined partner retrieval + guard goal.
6179 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6180 ( chr_pp_flag(guard_via_reschedule,on) ->
6181 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6182 list2conj(ScheduleSkeleton,GoalSkeleton)
6183 ;
6184 length(Retrievals,RL), length(LookupSkeleton,RL),
6185 length(GuardList,GL), length(GuardListSkeleton,GL),
6186 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6187 list2conj(GoalListSkeleton,GoalSkeleton)
6188 ).
6189 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6190 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6191 initialize_unit_dictionary(ActiveHead,Dict),
6192 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6193 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6194 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6195 dependency_reorder(Units,NUnits),
6196 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6197 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6198 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6200 wrap_in_functor(Functor,X,Term) :-
6201 Term =.. [Functor,X].
6203 wrappedunits2lists([],[],[],[]).
6204 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6205 Ss = [GoalCopy|TSs],
6206 ( WrappedGoal = lookup(Goal) ->
6207 Ls = [GoalCopy|TLs],
6208 Gs = TGs
6209 ; WrappedGoal = guard(Goal) ->
6210 Gs = [N-GoalCopy|TGs],
6211 Ls = TLs
6212 ),
6213 wrappedunits2lists(Units,TGs,TLs,TSs).
6215 guard_splitting(Rule,SplitGuardList) :-
6216 Rule = rule(H1,H2,Guard,_),
6217 append(H1,H2,Heads),
6218 conj2list(Guard,GuardList),
6219 term_variables(Heads,HeadVars),
6220 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6221 append(GuardPrefix,[RestGuard],SplitGuardList),
6222 term_variables(RestGuardList,GuardVars1),
6223 % variables that are declared to be ground don't need to be locked
6224 ground_vars(Heads,GroundVars),
6225 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6226 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6227 ( chr_pp_flag(guard_locks,on),
6228 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6229 once(pairup(Locks,Unlocks,LocksUnlocks))
6230 ;
6231 Locks = [],
6232 Unlocks = []
6233 ),
6234 list2conj(Locks,LockPhase),
6235 list2conj(Unlocks,UnlockPhase),
6236 list2conj(RestGuardList,RestGuard1),
6237 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6239 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6240 Rule = rule(_,_,_,Body),
6241 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6242 my_term_copy(Body,VarDict2,BodyCopy).
6245 split_off_simple_guard_new([],_,[],[]).
6246 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6247 ( simple_guard_new(G,VarDict) ->
6248 S = [G|Ss],
6249 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6250 ;
6251 S = [],
6252 C = [G|Gs]
6253 ).
6255 % simple guard: cheap and benign (does not bind variables)
6256 simple_guard_new(G,Vars) :-
6257 builtin_binds_b(G,BoundVars),
6258 \+ (( member(V,BoundVars),
6259 memberchk_eq(V,Vars)
6260 )).
6262 dependency_reorder(Units,NUnits) :-
6263 dependency_reorder(Units,[],NUnits).
6265 dependency_reorder([],Acc,Result) :-
6266 reverse(Acc,Result).
6268 dependency_reorder([Unit|Units],Acc,Result) :-
6269 Unit = unit(_GID,_Goal,Type,GIDs),
6270 ( Type == fixed ->
6271 NAcc = [Unit|Acc]
6272 ;
6273 dependency_insert(Acc,Unit,GIDs,NAcc)
6274 ),
6275 dependency_reorder(Units,NAcc,Result).
6277 dependency_insert([],Unit,_,[Unit]).
6278 dependency_insert([X|Xs],Unit,GIDs,L) :-
6279 X = unit(GID,_,_,_),
6280 ( memberchk(GID,GIDs) ->
6281 L = [Unit,X|Xs]
6282 ;
6283 L = [X | T],
6284 dependency_insert(Xs,Unit,GIDs,T)
6285 ).
6287 build_units(Retrievals,Guard,InitialDict,Units) :-
6288 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6289 build_guard_units(Guard,N,Dict,Tail).
6291 build_retrieval_units([],N,N,Dict,Dict,L,L).
6292 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6293 term_variables(U,Vs),
6294 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6295 L = [unit(N,U,fixed,GIDs)|L1],
6296 N1 is N + 1,
6297 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6299 initialize_unit_dictionary(Term,Dict) :-
6300 term_variables(Term,Vars),
6301 pair_all_with(Vars,0,Dict).
6303 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6304 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6305 ( lookup_eq(Dict,V,GID) ->
6306 ( (GID == This ; memberchk(GID,GIDs) ) ->
6307 GIDs1 = GIDs
6308 ;
6309 GIDs1 = [GID|GIDs]
6310 ),
6311 Dict1 = Dict
6312 ;
6313 Dict1 = [V - This|Dict],
6314 GIDs1 = GIDs
6315 ),
6316 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6318 build_guard_units(Guard,N,Dict,Units) :-
6319 ( Guard = [Goal] ->
6320 Units = [unit(N,Goal,fixed,[])]
6321 ; Guard = [Goal|Goals] ->
6322 term_variables(Goal,Vs),
6323 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6324 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6325 N1 is N + 1,
6326 build_guard_units(Goals,N1,NDict,RUnits)
6327 ).
6329 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6330 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6331 ( lookup_eq(Dict,V,GID) ->
6332 ( (GID == This ; memberchk(GID,GIDs) ) ->
6333 GIDs1 = GIDs
6334 ;
6335 GIDs1 = [GID|GIDs]
6336 ),
6337 Dict1 = [V - This|Dict]
6338 ;
6339 Dict1 = [V - This|Dict],
6340 GIDs1 = GIDs
6341 ),
6342 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6344 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6346 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6347 %% ____ _ ____ _ _
6348 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6349 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6350 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6351 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6352 %%
6353 %% _ _ _ ___ __
6354 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6355 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6356 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6357 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6358 %% |_|
6359 :- chr_constraint
6360 functional_dependency/4,
6361 get_functional_dependency/4.
6363 :- chr_option(mode,functional_dependency(+,+,?,?)).
6364 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6366 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6367 <=>
6368 RuleNb > 1, AO > O
6369 |
6370 functional_dependency(C,1,Pattern,Key).
6372 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6373 <=>
6374 RuleNb2 >= RuleNb1
6375 |
6376 QPattern = Pattern, QKey = Key.
6377 get_functional_dependency(_,_,_,_)
6378 <=>
6379 fail.
6381 functional_dependency_analysis(Rules) :-
6382 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6383 functional_dependency_analysis_main(Rules)
6384 ;
6385 true
6386 ).
6388 functional_dependency_analysis_main([]).
6389 functional_dependency_analysis_main([PRule|PRules]) :-
6390 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6391 functional_dependency(C,RuleNb,Pattern,Key)
6392 ;
6393 true
6394 ),
6395 functional_dependency_analysis_main(PRules).
6397 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6398 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6399 Rule = rule(H1,H2,Guard,_),
6400 ( H1 = [C1],
6401 H2 = [C2] ->
6402 true
6403 ; H1 = [C1,C2],
6404 H2 == [] ->
6405 true
6406 ),
6407 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6408 term_variables(C1,Vs),
6409 \+ (
6410 member(V1,Vs),
6411 lookup_eq(List,V1,V2),
6412 memberchk_eq(V2,Vs)
6413 ),
6414 select_pragma_unique_variables(Vs,List,Key1),
6415 copy_term_nat(C1-Key1,Pattern-Key),
6416 functor(C1,F,A).
6418 select_pragma_unique_variables([],_,[]).
6419 select_pragma_unique_variables([V|Vs],List,L) :-
6420 ( lookup_eq(List,V,_) ->
6421 L = T
6422 ;
6423 L = [V|T]
6424 ),
6425 select_pragma_unique_variables(Vs,List,T).
6427 % depends on functional dependency analysis
6428 % and shape of rule: C1 \ C2 <=> true.
6429 set_semantics_rules(Rules) :-
6430 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6431 set_semantics_rules_main(Rules)
6432 ;
6433 true
6434 ).
6436 set_semantics_rules_main([]).
6437 set_semantics_rules_main([R|Rs]) :-
6438 set_semantics_rule_main(R),
6439 set_semantics_rules_main(Rs).
6441 set_semantics_rule_main(PragmaRule) :-
6442 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6443 ( Rule = rule([C1],[C2],true,_),
6444 IDs = ids([ID1],[ID2]),
6445 \+ is_passive(RuleNb,ID1),
6446 functor(C1,F,A),
6447 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6448 copy_term_nat(Pattern-Key,C1-Key1),
6449 copy_term_nat(Pattern-Key,C2-Key2),
6450 Key1 == Key2 ->
6451 passive(RuleNb,ID2)
6452 ;
6453 true
6454 ).
6456 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6457 \+ any_passive_head(RuleNb),
6458 variable_replacement(C1-C2,C2-C1,List),
6459 copy_with_variable_replacement(G,OtherG,List),
6460 negate_b(G,NotG),
6461 once(entails_b(NotG,OtherG)).
6463 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6464 % where C1 and C2 are symmteric constraints
6465 symmetry_analysis(Rules) :-
6466 ( chr_pp_flag(check_unnecessary_active,off) ->
6467 true
6468 ;
6469 symmetry_analysis_main(Rules)
6470 ).
6472 symmetry_analysis_main([]).
6473 symmetry_analysis_main([R|Rs]) :-
6474 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6475 Rule = rule(H1,H2,_,_),
6476 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6477 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6478 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6479 ;
6480 true
6481 ),
6482 symmetry_analysis_main(Rs).
6484 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6485 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6486 ( \+ is_passive(RuleNb,ID),
6487 member2(PreHs,PreIDs,PreH-PreID),
6488 \+ is_passive(RuleNb,PreID),
6489 variable_replacement(PreH,H,List),
6490 copy_with_variable_replacement(Rule,Rule2,List),
6491 identical_guarded_rules(Rule,Rule2) ->
6492 passive(RuleNb,ID)
6493 ;
6494 true
6495 ),
6496 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6498 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6499 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6500 ( \+ is_passive(RuleNb,ID),
6501 member2(PreHs,PreIDs,PreH-PreID),
6502 \+ is_passive(RuleNb,PreID),
6503 variable_replacement(PreH,H,List),
6504 copy_with_variable_replacement(Rule,Rule2,List),
6505 identical_rules(Rule,Rule2) ->
6506 passive(RuleNb,ID)
6507 ;
6508 true
6509 ),
6510 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6512 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6514 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6515 %% ____ _ _ _ __ _ _ _
6516 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6517 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6518 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6519 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6520 %% |_|
6522 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6523 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6524 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6525 build_head(F,A,Id,HeadVars,ClauseHead),
6526 get_constraint_mode(F/A,Mode),
6527 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6530 guard_splitting(Rule,GuardList0),
6531 ( is_stored_in_guard(F/A, RuleNb) ->
6532 GuardList = [Hole1|GuardList0]
6533 ;
6534 GuardList = GuardList0
6535 ),
6536 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6538 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6540 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6542 ( is_stored_in_guard(F/A, RuleNb) ->
6543 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6544 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6545 GuardCopyList = [Hole1Copy|_],
6546 Hole1Copy = (Allocation, Attachment)
6547 ;
6548 true
6549 ),
6552 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6553 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6555 ( chr_pp_flag(debugable,on) ->
6556 Rule = rule(_,_,Guard,Body),
6557 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6558 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6559 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6560 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6561 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6562 ;
6563 Cut = ActualCut
6564 ),
6565 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6566 Clause = ( ClauseHead :-
6567 FirstMatching,
6568 RescheduledTest,
6569 Cut,
6570 SuspsDetachments,
6571 SuspDetachment,
6572 BodyCopy
6573 ),
6574 add_location(Clause,RuleNb,LocatedClause),
6575 L = [LocatedClause | T].
6577 add_location(Clause,RuleNb,NClause) :-
6578 ( chr_pp_flag(line_numbers,on) ->
6579 get_chr_source_file(File),
6580 get_line_number(RuleNb,LineNb),
6581 NClause = '$source_location'(File,LineNb):Clause
6582 ;
6583 NClause = Clause
6584 ).
6586 add_dummy_location(Clause,NClause) :-
6587 ( chr_pp_flag(line_numbers,on) ->
6588 get_chr_source_file(File),
6589 NClause = '$source_location'(File,1):Clause
6590 ;
6591 NClause = Clause
6592 ).
6593 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6594 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6595 %
6596 % Return goal matching newly introduced variables with variables in
6597 % previously looked-up heads.
6598 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6599 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6600 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6602 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6603 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6604 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6605 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6606 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6607 list2conj(GoalList,Goal).
6609 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6610 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6611 ( var(Arg) ->
6612 ( lookup_eq(VarDict,Arg,OtherVar) ->
6613 ( Mode = (+) ->
6614 ( memberchk_eq(Arg,GroundVars) ->
6615 GoalList = [Var = OtherVar | RestGoalList],
6616 GroundVars1 = GroundVars
6617 ;
6618 GoalList = [Var == OtherVar | RestGoalList],
6619 GroundVars1 = [Arg|GroundVars]
6620 )
6621 ;
6622 GoalList = [Var == OtherVar | RestGoalList],
6623 GroundVars1 = GroundVars
6624 ),
6625 VarDict1 = VarDict
6626 ;
6627 VarDict1 = [Arg-Var | VarDict],
6628 GoalList = RestGoalList,
6629 ( Mode = (+) ->
6630 GroundVars1 = [Arg|GroundVars]
6631 ;
6632 GroundVars1 = GroundVars
6633 )
6634 ),
6635 Pairs = Rest,
6636 RestModes = Modes
6637 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6638 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6639 GoalList = [Goal|RestGoalList],
6640 VarDict = VarDict1,
6641 GroundVars1 = GroundVars,
6642 Pairs = Rest,
6643 RestModes = Modes
6644 ; atomic(Arg) ->
6645 ( Mode = (+) ->
6646 GoalList = [ Var = Arg | RestGoalList]
6647 ;
6648 GoalList = [ Var == Arg | RestGoalList]
6649 ),
6650 VarDict = VarDict1,
6651 GroundVars1 = GroundVars,
6652 Pairs = Rest,
6653 RestModes = Modes
6654 ; Mode == (+), is_ground(GroundVars,Arg) ->
6655 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6656 GoalList = [ Var = ArgCopy | RestGoalList],
6657 VarDict = VarDict1,
6658 GroundVars1 = GroundVars,
6659 Pairs = Rest,
6660 RestModes = Modes
6661 ; Arg =.. [_|Args],
6662 functor(Arg,Fct,N),
6663 functor(Term,Fct,N),
6664 Term =.. [_|Vars],
6665 ( Mode = (+) ->
6666 GoalList = [ Var = Term | RestGoalList ]
6667 ;
6668 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6669 ),
6670 pairup(Args,Vars,NewPairs),
6671 append(NewPairs,Rest,Pairs),
6672 replicate(N,Mode,NewModes),
6673 append(NewModes,Modes,RestModes),
6674 VarDict1 = VarDict,
6675 GroundVars1 = GroundVars
6676 ),
6677 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6679 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6680 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6681 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6682 add_heads_types([],VarTypes,VarTypes).
6683 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6684 add_head_types(Head,VarTypes,VarTypes1),
6685 add_heads_types(Heads,VarTypes1,NVarTypes).
6687 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6688 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6689 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6690 add_head_types(Head,VarTypes,NVarTypes) :-
6691 functor(Head,F,A),
6692 get_constraint_type_det(F/A,ArgTypes),
6693 Head =.. [_|Args],
6694 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6696 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6697 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6698 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6699 add_args_types([],[],VarTypes,VarTypes).
6700 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6701 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6702 add_args_types(Args,Types,VarTypes1,NVarTypes).
6704 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6705 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6706 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6707 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6708 ( var(Term) ->
6709 ( lookup_eq(VarTypes,Term,_) ->
6710 NVarTypes = VarTypes
6711 ;
6712 NVarTypes = [Term-Type|VarTypes]
6713 )
6714 ; ground(Term) ->
6715 NVarTypes = VarTypes
6716 ; % TODO improve approximation!
6717 term_variables(Term,Vars),
6718 length(Vars,VarNb),
6719 replicate(VarNb,any,Types),
6720 add_args_types(Vars,Types,VarTypes,NVarTypes)
6721 ).
6725 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6726 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6727 %
6728 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6729 add_heads_ground_variables([],GroundVars,GroundVars).
6730 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6731 add_head_ground_variables(Head,GroundVars,GroundVars1),
6732 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6734 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6735 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6736 %
6737 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6738 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6739 functor(Head,F,A),
6740 get_constraint_mode(F/A,ArgModes),
6741 Head =.. [_|Args],
6742 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6745 add_arg_ground_variables([],[],GroundVars,GroundVars).
6746 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6747 ( Mode == (+) ->
6748 term_variables(Arg,Vars),
6749 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6750 ;
6751 GroundVars = GroundVars1
6752 ),
6753 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6755 add_var_ground_variables([],GroundVars,GroundVars).
6756 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6757 ( memberchk_eq(Var,GroundVars) ->
6758 GroundVars1 = GroundVars
6759 ;
6760 GroundVars1 = [Var|GroundVars]
6761 ),
6762 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6763 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6764 %% is_ground(+GroundVars,+Term) is semidet.
6765 %
6766 % Determine whether =Term= is always ground.
6767 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6768 is_ground(GroundVars,Term) :-
6769 ( ground(Term) ->
6770 true
6771 ; compound(Term) ->
6772 Term =.. [_|Args],
6773 maplist(is_ground(GroundVars),Args)
6774 ;
6775 memberchk_eq(Term,GroundVars)
6776 ).
6778 %% check_ground(+GroundVars,+Term,-Goal) is det.
6779 %
6780 % Return runtime check to see whether =Term= is ground.
6781 check_ground(GroundVars,Term,Goal) :-
6782 term_variables(Term,Variables),
6783 check_ground_variables(Variables,GroundVars,Goal).
6785 check_ground_variables([],_,true).
6786 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6787 ( memberchk_eq(Var,GroundVars) ->
6788 check_ground_variables(Vars,GroundVars,Goal)
6789 ;
6790 Goal = (ground(Var), RGoal),
6791 check_ground_variables(Vars,GroundVars,RGoal)
6792 ).
6794 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6795 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6797 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6798 ( Heads = [_|_] ->
6799 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6800 ;
6801 GoalList = [],
6802 Susps = [],
6803 VarDict = NVarDict,
6804 GroundVars = NGroundVars
6805 ).
6807 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6808 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6809 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6810 functor(H,F,A),
6811 head_info(H,A,Vars,_,_,Pairs),
6812 get_store_type(F/A,StoreType),
6813 ( StoreType == default ->
6814 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6815 delay_phase_end(validate_store_type_assumptions,
6816 ( static_suspension_term(F/A,Suspension),
6817 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6818 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6819 )
6820 ),
6821 % create_get_mutable_ref(active,State,GetMutable),
6822 get_constraint_mode(F/A,Mode),
6823 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6824 NPairs = Pairs,
6825 sbag_member_call(Susp,VarSusps,Sbag),
6826 ExistentialLookup = (
6827 ViaGoal,
6828 Sbag,
6829 Susp = Suspension, % not inlined
6830 GetState
6831 )
6832 ;
6833 delay_phase_end(validate_store_type_assumptions,
6834 ( static_suspension_term(F/A,Suspension),
6835 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6836 )
6837 ),
6838 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6839 get_constraint_mode(F/A,Mode),
6840 filter_mode(NPairs,Pairs,Mode,NMode),
6841 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6842 ),
6843 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6844 append(NPairs,VarDict1,DA_), % order important here
6845 translate(GroundVars1,DA_,GroundVarsA),
6846 translate(GroundVars1,VarDict1,GroundVarsB),
6847 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6848 Goal =
6849 (
6850 ExistentialLookup,
6851 DiffSuspGoals,
6852 MatchingGoal2
6853 ),
6854 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6856 inline_matching_goal(A==B,true,GVA,GVB) :-
6857 memberchk_eq(A,GVA),
6858 memberchk_eq(B,GVB),
6859 A=B, !.
6861 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6862 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6863 inline_matching_goal(A,A2,GVA,GVB),
6864 inline_matching_goal(B,B2,GVA,GVB).
6865 inline_matching_goal(X,X,_,_).
6868 filter_mode([],_,_,[]).
6869 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6870 ( Var == V ->
6871 Modes = [M|MT],
6872 filter_mode(Rest,R,Ms,MT)
6873 ;
6874 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6875 ).
6877 check_unique_keys([],_).
6878 check_unique_keys([V|Vs],Dict) :-
6879 lookup_eq(Dict,V,_),
6880 check_unique_keys(Vs,Dict).
6882 % Generates tests to ensure the found constraint differs from previously found constraints
6883 % TODO: detect more cases where constraints need be different
6884 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6885 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6886 list2conj(DiffSuspGoalList,DiffSuspGoals).
6888 different_from_other_susps_(_,[],_,_,[]) :- !.
6889 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6890 ( functor(Head,F,A), functor(PreHead,F,A),
6891 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6892 \+ \+ PreHeadCopy = HeadCopy ->
6894 List = [Susp \== PreSusp | Tail]
6895 ;
6896 List = Tail
6897 ),
6898 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6900 % passive_head_via(in,in,in,in,out,out,out) :-
6901 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6902 functor(Head,F,A),
6903 get_constraint_index(F/A,Pos),
6904 common_variables(Head,PrevHeads,CommonVars),
6905 global_list_store_name(F/A,Name),
6906 GlobalGoal = nb_getval(Name,AllSusps),
6907 get_constraint_mode(F/A,ArgModes),
6908 ( Vars == [] ->
6909 Goal = GlobalGoal
6910 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6911 translate([CommonVar],VarDict,[Var]),
6912 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6913 Goal = AttrGoal
6914 ;
6915 translate(CommonVars,VarDict,Vars),
6916 add_heads_types(PrevHeads,[],TypeDict),
6917 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6918 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6919 Goal =
6920 ( ViaGoal ->
6921 AttrGoal
6922 ;
6923 GlobalGoal
6924 )
6925 ).
6927 common_variables(T,Ts,Vs) :-
6928 term_variables(T,V1),
6929 term_variables(Ts,V2),
6930 intersect_eq(V1,V2,Vs).
6932 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6933 get_target_module(Mod),
6934 ( Vars = [A] ->
6935 lookup_eq(TypeDict,A,Type),
6936 ( atomic_type(Type) ->
6937 ViaGoal = var(A),
6938 A = V
6939 ;
6940 ViaGoal = 'chr newvia_1'(A,V)
6941 )
6942 ; Vars = [A,B] ->
6943 ViaGoal = 'chr newvia_2'(A,B,V)
6944 ;
6945 ViaGoal = 'chr newvia'(Vars,V)
6946 ),
6947 AttrGoal =
6948 ( get_attr(V,Mod,TSusps),
6949 TSuspsEqSusps % TSusps = Susps
6950 ),
6951 get_max_constraint_index(N),
6952 ( N == 1 ->
6953 TSuspsEqSusps = true, % TSusps = Susps
6954 AllSusps = TSusps
6955 ;
6956 get_constraint_index(FA,Pos),
6957 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6958 ).
6959 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6960 get_target_module(Mod),
6961 AttrGoal =
6962 ( get_attr(Var,Mod,TSusps),
6963 TSuspsEqSusps % TSusps = Susps
6964 ),
6965 get_max_constraint_index(N),
6966 ( N == 1 ->
6967 TSuspsEqSusps = true, % TSusps = Susps
6968 AllSusps = TSusps
6969 ;
6970 get_constraint_index(FA,Pos),
6971 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6972 ).
6974 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6975 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6976 list2conj(GuardCopyList,GuardCopy).
6978 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6979 Rule = rule(_,H,Guard,Body),
6980 conj2list(Guard,GuardList),
6981 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6982 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6984 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6985 term_variables(RestGuardList,GuardVars),
6986 term_variables(RestGuardListCopyCore,GuardCopyVars),
6987 % variables that are declared to be ground don't need to be locked
6988 ground_vars(H,GroundVars),
6989 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
6990 ( chr_pp_flag(guard_locks,on),
6991 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6992 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
6993 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
6994 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
6995 ),
6996 LocksUnlocks) ->
6997 once(pairup(Locks,Unlocks,LocksUnlocks))
6998 ;
6999 Locks = [],
7000 Unlocks = []
7001 ),
7002 list2conj(Locks,LockPhase),
7003 list2conj(Unlocks,UnlockPhase),
7004 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7005 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7006 my_term_copy(Body,VarDict2,BodyCopy).
7009 split_off_simple_guard([],_,[],[]).
7010 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7011 ( simple_guard(G,VarDict) ->
7012 S = [G|Ss],
7013 split_off_simple_guard(Gs,VarDict,Ss,C)
7014 ;
7015 S = [],
7016 C = [G|Gs]
7017 ).
7019 % simple guard: cheap and benign (does not bind variables)
7020 simple_guard(G,VarDict) :-
7021 binds_b(G,Vars),
7022 \+ (( member(V,Vars),
7023 lookup_eq(VarDict,V,_)
7024 )).
7026 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7027 functor(Head,F,A),
7028 C = F/A,
7029 ( is_stored(C) ->
7030 (
7031 (
7032 Id == [0], chr_pp_flag(store_in_guards, off)
7033 ;
7034 ( get_allocation_occurrence(C,AO),
7035 get_max_occurrence(C,MO),
7036 MO < AO )
7037 ),
7038 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7039 SuspDetachment = true
7040 ;
7041 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7042 ( chr_pp_flag(late_allocation,on) ->
7043 SuspDetachment =
7044 ( var(Susp) ->
7045 true
7046 ;
7047 UnCondSuspDetachment
7048 )
7049 ;
7050 SuspDetachment = UnCondSuspDetachment
7051 )
7052 )
7053 ;
7054 SuspDetachment = true
7055 ).
7057 partner_constraint_detachments([],[],_,true).
7058 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7059 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7060 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7062 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7063 functor(Head,F,A),
7064 C = F/A,
7065 ( is_stored(C) ->
7066 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7067 ( chr_pp_flag(debugable,on) ->
7068 DebugEvent = 'chr debug_event'(remove(Susp))
7069 ;
7070 DebugEvent = true
7071 ),
7072 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7073 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7074 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7075 detach_constraint_atom(C,Vars,Susp,Detach)
7076 ;
7077 Detach = true
7078 )
7079 ;
7080 SuspDetachment = true
7081 ).
7083 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7085 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7086 %% ____ _ _ _ _
7087 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7088 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7089 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7090 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7091 %% |_| |___/
7093 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7094 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7095 Rule = rule(_Heads,Heads2,Guard,Body),
7097 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7098 get_constraint_mode(F/A,Mode),
7099 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7101 build_head(F,A,Id,HeadVars,ClauseHead),
7103 append(RestHeads,Heads2,Heads),
7104 append(OtherIDs,Heads2IDs,IDs),
7105 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7107 guard_splitting(Rule,GuardList0),
7108 ( is_stored_in_guard(F/A, RuleNb) ->
7109 GuardList = [Hole1|GuardList0]
7110 ;
7111 GuardList = GuardList0
7112 ),
7113 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7115 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7116 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7118 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7120 ( is_stored_in_guard(F/A, RuleNb) ->
7121 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7122 GuardCopyList = [Hole1Copy|_],
7123 Hole1Copy = Attachment
7124 ;
7125 true
7126 ),
7128 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7129 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7130 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7132 ( chr_pp_flag(debugable,on) ->
7133 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7134 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7135 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7136 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7137 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7138 instrument_goal((!),DebugTry,DebugApply,Cut)
7139 ;
7140 Cut = (!)
7141 ),
7143 Clause = ( ClauseHead :-
7144 FirstMatching,
7145 RescheduledTest,
7146 Cut,
7147 SuspsDetachments,
7148 SuspDetachment,
7149 BodyCopy
7150 ),
7151 add_location(Clause,RuleNb,LocatedClause),
7152 L = [LocatedClause | T].
7154 split_by_ids([],[],_,[],[]).
7155 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7156 ( memberchk_eq(I,I1s) ->
7157 S1s = [S | R1s],
7158 S2s = R2s
7159 ;
7160 S1s = R1s,
7161 S2s = [S | R2s]
7162 ),
7163 split_by_ids(Is,Ss,I1s,R1s,R2s).
7165 split_by_ids([],[],_,[],[],[],[]).
7166 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7167 ( memberchk_eq(I,I1s) ->
7168 S1s = [S | R1s],
7169 SI1s = [I|RSI1s],
7170 S2s = R2s,
7171 SI2s = RSI2s
7172 ;
7173 S1s = R1s,
7174 SI1s = RSI1s,
7175 S2s = [S | R2s],
7176 SI2s = [I|RSI2s]
7177 ),
7178 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7179 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7182 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7183 %% ____ _ _ _ ____
7184 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7185 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7186 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7187 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7188 %% |_| |___/
7190 %% Genereate prelude + worker predicate
7191 %% prelude calls worker
7192 %% worker iterates over one type of removed constraints
7193 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7194 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7195 Rule = rule(Heads1,_,Guard,Body),
7196 append(Heads1,RestHeads2,Heads),
7197 append(IDs1,RestIDs,IDs),
7198 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7199 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7200 extend_id(Id,Id1),
7201 ( memberchk_eq(NID,IDs2) ->
7202 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7203 ;
7204 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7205 ),
7206 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7207 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7209 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7210 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7211 Heads = [Head|RHeads],
7212 inc_id(Id,Id1),
7213 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7214 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7215 ( memberchk_eq(ID,IDs2) ->
7216 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7217 ;
7218 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7219 ).
7221 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7222 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7223 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7224 build_head(F,A,Id1,VarsSusp,ClauseHead),
7225 get_constraint_mode(F/A,Mode),
7226 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7228 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7230 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7232 extend_id(Id1,DelegateId),
7233 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7234 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7235 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7237 PreludeClause =
7238 ( ClauseHead :-
7239 FirstMatching,
7240 ModConstraintsGoal,
7241 !,
7242 ConstraintAllocationGoal,
7243 Delegate
7244 ),
7245 add_dummy_location(PreludeClause,LocatedPreludeClause),
7246 L = [LocatedPreludeClause|T].
7248 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7249 Term =.. [_|Args],
7250 delegate_variables(Term,Terms,VarDict,Args,Vars).
7252 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7253 term_variables(PrevTerms,PrevVars),
7254 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7256 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7257 term_variables(Term,V1),
7258 term_variables(Terms,V2),
7259 intersect_eq(V1,V2,V3),
7260 list_difference_eq(V3,PrevVars,V4),
7261 translate(V4,VarDict,Vars).
7264 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7265 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7266 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7267 Rule = rule(_,_,Guard,Body),
7268 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7270 gen_var(OtherSusp),
7271 gen_var(OtherSusps),
7273 functor(CurrentHead,OtherF,OtherA),
7274 gen_vars(OtherA,OtherVars),
7275 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7276 get_constraint_mode(OtherF/OtherA,Mode),
7277 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7279 delay_phase_end(validate_store_type_assumptions,
7280 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7281 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7282 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7283 )
7284 ),
7285 % create_get_mutable_ref(active,State,GetMutable),
7286 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7287 CurrentSuspTest = (
7288 OtherSusp = OtherSuspension,
7289 GetState,
7290 DiffSuspGoals,
7291 FirstMatching
7292 ),
7294 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7295 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7297 guard_splitting(Rule,GuardList0),
7298 ( is_stored_in_guard(F/A, RuleNb) ->
7299 GuardList = [Hole1|GuardList0]
7300 ;
7301 GuardList = GuardList0
7302 ),
7303 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7305 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7306 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7307 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7309 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7311 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7312 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7313 RecursiveVars2 = [[]|PreVarsAndSusps],
7314 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7316 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7317 ( is_stored_in_guard(F/A, RuleNb) ->
7318 GuardCopyList = [GuardAttachment|_] % once( ) ??
7319 ;
7320 true
7321 ),
7323 ( is_observed(F/A,O) ->
7324 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7325 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7326 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7327 ;
7328 Attachment = true,
7329 ConditionalRecursiveCall = RecursiveCall,
7330 ConditionalRecursiveCall2 = RecursiveCall2
7331 ),
7333 ( chr_pp_flag(debugable,on) ->
7334 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7335 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7336 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7337 ;
7338 DebugTry = true,
7339 DebugApply = true
7340 ),
7342 ( is_stored_in_guard(F/A, RuleNb) ->
7343 GuardAttachment = Attachment,
7344 BodyAttachment = true
7345 ;
7346 GuardAttachment = true,
7347 BodyAttachment = Attachment % will be true if not observed at all
7348 ),
7350 ( member(unique(ID1,UniqueKeys), Pragmas),
7351 check_unique_keys(UniqueKeys,VarDict) ->
7352 Clause =
7353 ( ClauseHead :-
7354 ( CurrentSuspTest ->
7355 ( RescheduledTest,
7356 DebugTry ->
7357 DebugApply,
7358 Susps1Detachments,
7359 BodyAttachment,
7360 BodyCopy,
7361 ConditionalRecursiveCall2
7362 ;
7363 RecursiveCall2
7364 )
7365 ;
7366 RecursiveCall
7367 )
7368 )
7369 ;
7370 Clause =
7371 ( ClauseHead :-
7372 ( CurrentSuspTest,
7373 RescheduledTest,
7374 DebugTry ->
7375 DebugApply,
7376 Susps1Detachments,
7377 BodyAttachment,
7378 BodyCopy,
7379 ConditionalRecursiveCall
7380 ;
7381 RecursiveCall
7382 )
7383 )
7384 ),
7385 add_location(Clause,RuleNb,LocatedClause),
7386 L = [LocatedClause | T].
7388 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7389 ( may_trigger(FA) ->
7390 does_use_field(FA,generation),
7391 delay_phase_end(validate_store_type_assumptions,
7392 ( static_suspension_term(FA,Suspension),
7393 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7394 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7395 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7396 )
7397 )
7398 ;
7399 delay_phase_end(validate_store_type_assumptions,
7400 ( static_suspension_term(FA,Suspension),
7401 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7402 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7403 )
7404 ),
7405 GetGeneration = true
7406 ),
7407 ConditionalCall =
7408 ( Susp = Suspension,
7409 GetState,
7410 GetGeneration ->
7411 UpdateState,
7412 Call
7413 ;
7414 true
7415 ).
7417 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7420 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7421 %% ____ _ _
7422 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7423 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7424 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7425 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7426 %% |_| |___/
7428 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7429 ( RestHeads == [] ->
7430 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7431 ;
7432 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7433 ).
7434 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7435 %% Single headed propagation
7436 %% everything in a single clause
7437 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7438 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7439 build_head(F,A,Id,VarsSusp,ClauseHead),
7441 inc_id(Id,NextId),
7442 build_head(F,A,NextId,VarsSusp,NextHead),
7444 get_constraint_mode(F/A,Mode),
7445 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7446 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7448 % - recursive call -
7449 RecursiveCall = NextHead,
7451 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7452 ActualCut = true
7453 ;
7454 ActualCut = !
7455 ),
7457 Rule = rule(_,_,Guard,Body),
7458 ( chr_pp_flag(debugable,on) ->
7459 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7460 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7461 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7462 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7463 ;
7464 Cut = ActualCut
7465 ),
7466 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7467 use_auxiliary_predicate(novel_production),
7468 use_auxiliary_predicate(extend_history),
7469 does_use_history(F/A,O),
7470 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7472 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7473 ( HistoryIDs == [] ->
7474 empty_named_history_novel_production(HistoryName,NovelProduction),
7475 empty_named_history_extend_history(HistoryName,ExtendHistory)
7476 ;
7477 Tuple = HistoryName
7478 )
7479 ;
7480 Tuple = RuleNb
7481 ),
7483 ( var(NovelProduction) ->
7484 NovelProduction = '$novel_production'(Susp,Tuple),
7485 ExtendHistory = '$extend_history'(Susp,Tuple)
7486 ;
7487 true
7488 ),
7490 ( is_observed(F/A,O) ->
7491 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7492 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7493 ;
7494 Attachment = true,
7495 ConditionalRecursiveCall = RecursiveCall
7496 )
7497 ;
7498 Allocation = true,
7499 NovelProduction = true,
7500 ExtendHistory = true,
7502 ( is_observed(F/A,O) ->
7503 get_allocation_occurrence(F/A,AllocO),
7504 ( O == AllocO ->
7505 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7506 Generation = 0
7507 ; % more room for improvement?
7508 Attachment = (Attachment1, Attachment2),
7509 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7510 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7511 ),
7512 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7513 ;
7514 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7515 ConditionalRecursiveCall = RecursiveCall
7516 )
7517 ),
7519 ( is_stored_in_guard(F/A, RuleNb) ->
7520 GuardAttachment = Attachment,
7521 BodyAttachment = true
7522 ;
7523 GuardAttachment = true,
7524 BodyAttachment = Attachment % will be true if not observed at all
7525 ),
7527 Clause = (
7528 ClauseHead :-
7529 HeadMatching,
7530 Allocation,
7531 NovelProduction,
7532 GuardAttachment,
7533 GuardCopy,
7534 Cut,
7535 ExtendHistory,
7536 BodyAttachment,
7537 BodyCopy,
7538 ConditionalRecursiveCall
7539 ),
7540 add_location(Clause,RuleNb,LocatedClause),
7541 ProgramList = [LocatedClause | ProgramTail].
7543 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7544 %% multi headed propagation
7545 %% prelude + predicates to accumulate the necessary combinations of suspended
7546 %% constraints + predicate to execute the body
7547 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7548 RestHeads = [First|Rest],
7549 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7550 extend_id(Id,ExtendedId),
7551 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7553 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7554 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7555 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7556 build_head(F,A,Id,VarsSusp,PreludeHead),
7557 get_constraint_mode(F/A,Mode),
7558 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7559 Rule = rule(_,_,Guard,Body),
7560 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7562 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7564 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7566 extend_id(Id,NestedId),
7567 append([Susps|VarsSusp],ExtraVars,NestedVars),
7568 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7569 NestedCall = NestedHead,
7571 Prelude = (
7572 PreludeHead :-
7573 FirstMatching,
7574 FirstSuspGoal,
7575 !,
7576 CondAllocation,
7577 NestedCall
7578 ),
7579 add_dummy_location(Prelude,LocatedPrelude),
7580 L = [LocatedPrelude|T].
7582 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7583 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7584 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7585 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7587 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7588 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7589 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7590 inc_id(Id,IncId),
7591 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7593 %check_fd_lookup_condition(_,_,_,_) :- fail.
7594 check_fd_lookup_condition(F,A,_,_) :-
7595 get_store_type(F/A,global_singleton), !.
7596 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7597 \+ may_trigger(F/A),
7598 get_functional_dependency(F/A,1,P,K),
7599 copy_term(P-K,CurrentHead-Key),
7600 term_variables(PreHeads,PreVars),
7601 intersect_eq(Key,PreVars,Key),!.
7603 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7604 Rule = rule(_,H2,Guard,Body),
7605 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7606 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7607 init(AllSusps,RestSusps),
7608 last(AllSusps,Susp),
7609 gen_var(OtherSusp),
7610 gen_var(OtherSusps),
7611 functor(CurrentHead,OtherF,OtherA),
7612 gen_vars(OtherA,OtherVars),
7613 delay_phase_end(validate_store_type_assumptions,
7614 ( static_suspension_term(OtherF/OtherA,Suspension),
7615 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7616 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7617 )
7618 ),
7619 % create_get_mutable_ref(active,State,GetMutable),
7620 CurrentSuspTest = (
7621 OtherSusp = Suspension,
7622 GetState
7623 ),
7624 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7625 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7626 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7627 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7628 RecursiveVars = PreVarsAndSusps1
7629 ;
7630 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7631 PrevId0 = Id
7632 ),
7633 ( PrevId0 = [_] ->
7634 PrevId = PrevId0
7635 ;
7636 PrevId = [O|PrevId0]
7637 ),
7638 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7639 RecursiveCall = RecursiveHead,
7640 CurrentHead =.. [_|OtherArgs],
7641 pairup(OtherArgs,OtherVars,OtherPairs),
7642 get_constraint_mode(OtherF/OtherA,Mode),
7643 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7645 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7646 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7647 get_occurrence(F/A,O,_,ID),
7649 ( is_observed(F/A,O) ->
7650 init(FirstVarsSusp,FirstVars),
7651 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7652 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7653 ;
7654 Attachment = true,
7655 ConditionalRecursiveCall = RecursiveCall
7656 ),
7657 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7658 NovelProduction = true,
7659 ExtendHistory = true
7660 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7661 NovelProduction = true,
7662 ExtendHistory = true
7663 ;
7664 get_occurrence(F/A,O,_,ID),
7665 use_auxiliary_predicate(novel_production),
7666 use_auxiliary_predicate(extend_history),
7667 does_use_history(F/A,O),
7668 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7669 ( HistoryIDs == [] ->
7670 empty_named_history_novel_production(HistoryName,NovelProduction),
7671 empty_named_history_extend_history(HistoryName,ExtendHistory)
7672 ;
7673 reverse([OtherSusp|RestSusps],NamedSusps),
7674 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7675 HistorySusps = [HistorySusp|_],
7677 ( length(HistoryIDs, 1) ->
7678 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7679 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7680 ;
7681 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7682 Tuple =.. [t,HistoryName|HistorySusps]
7683 )
7684 )
7685 ;
7686 HistorySusp = Susp,
7687 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7688 sort([ID|RestIDs],HistoryIDs),
7689 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7690 Tuple =.. [t,RuleNb|HistorySusps]
7691 ),
7693 ( var(NovelProduction) ->
7694 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7695 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7696 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7697 ;
7698 true
7699 )
7700 ),
7703 ( chr_pp_flag(debugable,on) ->
7704 Rule = rule(_,_,Guard,Body),
7705 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7706 get_occurrence(F/A,O,_,ID),
7707 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7708 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7709 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7710 ;
7711 DebugTry = true,
7712 DebugApply = true
7713 ),
7715 ( is_stored_in_guard(F/A, RuleNb) ->
7716 GuardAttachment = Attachment,
7717 BodyAttachment = true
7718 ;
7719 GuardAttachment = true,
7720 BodyAttachment = Attachment % will be true if not observed at all
7721 ),
7723 Clause = (
7724 ClauseHead :-
7725 ( CurrentSuspTest,
7726 DiffSuspGoals,
7727 Matching,
7728 NovelProduction,
7729 GuardAttachment,
7730 GuardCopy,
7731 DebugTry ->
7732 DebugApply,
7733 ExtendHistory,
7734 BodyAttachment,
7735 BodyCopy,
7736 ConditionalRecursiveCall
7737 ; RecursiveCall
7738 )
7739 ),
7740 add_location(Clause,RuleNb,LocatedClause),
7741 L = [LocatedClause|T].
7743 novel_production_calls([],[],[],_,_,true).
7744 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7745 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7746 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7747 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7749 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7750 reverse(ReversedRestSusps,RestSusps),
7751 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7753 named_history_susps([],_,_,[]).
7754 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7755 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7756 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7760 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7761 !,
7762 functor(Head,F,A),
7763 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7764 get_constraint_mode(F/A,Mode),
7765 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7766 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7767 append(VarsSusp,ExtraVars,HeadVars).
7768 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7769 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7770 functor(Head,F,A),
7771 gen_var(Susps),
7772 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7773 get_constraint_mode(F/A,Mode),
7774 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7775 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7776 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7778 % returns
7779 % VarDict for the copies of variables in the original heads
7780 % VarsSuspsList list of lists of arguments for the successive heads
7781 % FirstVarsSusp top level arguments
7782 % SuspList list of all suspensions
7783 % Iterators list of all iterators
7784 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7785 !,
7786 functor(Head,F,A),
7787 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7788 get_constraint_mode(F/A,Mode),
7789 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7790 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7791 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7792 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7793 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7794 functor(Head,F,A),
7795 gen_var(Susps),
7796 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7797 get_constraint_mode(F/A,Mode),
7798 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7799 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7800 append(HeadVars,[Susp,Susps],Vars).
7802 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7803 !,
7804 functor(Head,F,A),
7805 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7806 get_constraint_mode(F/A,Mode),
7807 head_arg_matches(Pairs,Mode,[],_,VarDict),
7808 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7809 append(VarsSusp,ExtraVars,HeadVars).
7810 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7811 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7812 functor(Head,F,A),
7813 gen_var(Susps),
7814 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7815 get_constraint_mode(F/A,Mode),
7816 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7817 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7818 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7820 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7822 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7823 %% ____ _ _ _ _
7824 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7825 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7826 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7827 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7828 %%
7829 %% ____ _ _ _
7830 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7831 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7832 %% | _ < __/ |_| | | | __/\ V / (_| | |
7833 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7834 %%
7835 %% ____ _ _
7836 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7837 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7838 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7839 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7840 %% |___/
7842 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7843 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7844 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7845 ;
7846 NRestHeads = RestHeads,
7847 NRestIDs = RestIDs
7848 ).
7850 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7851 term_variables(Head,Vars),
7852 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7853 copy_term_nat(InitialData,InitialDataCopy),
7854 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7855 InitialDataCopy = InitialData,
7856 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7857 reverse(RNRestHeads,NRestHeads),
7858 reverse(RNRestIDs,NRestIDs).
7860 final_data(Entry) :-
7861 Entry = entry(_,_,_,_,[],_).
7863 expand_data(Entry,NEntry,Cost) :-
7864 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7865 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7866 term_variables([Head1|Vars],Vars1),
7867 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7868 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7870 % Assigns score to head based on known variables and heads to lookup
7871 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7872 functor(Head,F,A),
7873 get_store_type(F/A,StoreType),
7874 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7876 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7877 term_variables(Head,HeadVars),
7878 term_variables(RestHeads,RestVars),
7879 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7880 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7881 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7882 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7883 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7884 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7885 term_variables(Head,HeadVars),
7886 term_variables(RestHeads,RestVars),
7887 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7888 Score is Score_ * 2.
7889 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7890 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7891 Score = 1. % guaranteed O(1)
7893 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7894 find_with_var_identity(
7895 S,
7896 t(Head,KnownVars,RestHeads),
7897 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7898 Scores
7899 ),
7900 min_list(Scores,Score).
7901 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7902 Score = 10.
7903 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7904 Score = 10.
7906 order_score_indexes([],_,_,Score,NScore) :-
7907 Score > 0, NScore = 100.
7908 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7909 multi_hash_key_args(I,Head,Args),
7910 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7911 Score1 is Score + 1
7912 ;
7913 Score1 = Score
7914 ),
7915 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7917 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7918 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7919 ( K-R-O == 0-0-0 ->
7920 Score = 0
7921 ; K > 0 ->
7922 Score is max(10 - K,0)
7923 ; R > 0 ->
7924 Score is max(10 - R,1) * 10
7925 ;
7926 Score is max(10-O,1) * 100
7927 ).
7928 order_score_count_vars([],_,_,0-0-0).
7929 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7930 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7931 ( memberchk_eq(V,KnownVars) ->
7932 NK is K + 1,
7933 NR = R, NO = O
7934 ; memberchk_eq(V,RestVars) ->
7935 NR is R + 1,
7936 NK = K, NO = O
7937 ;
7938 NO is O + 1,
7939 NK = K, NR = R
7940 ).
7942 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7943 %% ___ _ _ _
7944 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
7945 %% | || '_ \| | | '_ \| | '_ \ / _` |
7946 %% | || | | | | | | | | | | | | (_| |
7947 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7948 %% |___/
7950 %% SWI begin
7951 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7952 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7953 %% SWI end
7955 %% SICStus begin
7956 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7957 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7958 %% SICStus end
7960 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7962 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7963 %% _ _ _ _ _ _ _
7964 %% | | | | |_(_) (_) |_ _ _
7965 %% | | | | __| | | | __| | | |
7966 %% | |_| | |_| | | | |_| |_| |
7967 %% \___/ \__|_|_|_|\__|\__, |
7968 %% |___/
7970 % Create a fresh variable.
7971 gen_var(_).
7973 % Create =N= fresh variables.
7974 gen_vars(N,Xs) :-
7975 length(Xs,N).
7977 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7978 vars_susp(A,Vars,Susp,VarsSusp),
7979 Head =.. [_|Args],
7980 pairup(Args,Vars,HeadPairs).
7982 inc_id([N|Ns],[O|Ns]) :-
7983 O is N + 1.
7984 dec_id([N|Ns],[M|Ns]) :-
7985 M is N - 1.
7987 extend_id(Id,[0|Id]).
7989 next_id([_,N|Ns],[O|Ns]) :-
7990 O is N + 1.
7992 % return clause Head
7993 % for F/A constraint symbol, predicate identifier Id and arguments Head
7994 build_head(F,A,Id,Args,Head) :-
7995 buildName(F,A,Id,Name),
7996 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
7997 ( may_trigger(F/A) ;
7998 get_allocation_occurrence(F/A,AO),
7999 get_max_occurrence(F/A,MO),
8000 MO >= AO ) ) ->
8001 Head =.. [Name|Args]
8002 ;
8003 init(Args,ArgsWOSusp), % XXX not entirely correct!
8004 Head =.. [Name|ArgsWOSusp]
8005 ).
8007 % return predicate name Result
8008 % for Fct/Aty constraint symbol and predicate identifier List
8009 buildName(Fct,Aty,List,Result) :-
8010 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8011 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8012 MO >= AO ) ; List \= [0])) ) ) ->
8013 atom_concat(Fct, '___' ,FctSlash),
8014 atomic_concat(FctSlash,Aty,FctSlashAty),
8015 buildName_(List,FctSlashAty,Result)
8016 ;
8017 Result = Fct
8018 ).
8020 buildName_([],Name,Name).
8021 buildName_([N|Ns],Name,Result) :-
8022 buildName_(Ns,Name,Name1),
8023 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8024 atomic_concat(NameDash,N,Result).
8026 vars_susp(A,Vars,Susp,VarsSusp) :-
8027 length(Vars,A),
8028 append(Vars,[Susp],VarsSusp).
8030 or_pattern(Pos,Pat) :-
8031 Pow is Pos - 1,
8032 Pat is 1 << Pow. % was 2 ** X
8034 and_pattern(Pos,Pat) :-
8035 X is Pos - 1,
8036 Y is 1 << X, % was 2 ** X
8037 Pat is (-1)*(Y + 1).
8039 make_name(Prefix,F/A,Name) :-
8040 atom_concat_list([Prefix,F,'___',A],Name).
8042 %===============================================================================
8043 % Attribute for attributed variables
8045 make_attr(N,Mask,SuspsList,Attr) :-
8046 length(SuspsList,N),
8047 Attr =.. [v,Mask|SuspsList].
8049 get_all_suspensions2(N,Attr,SuspensionsList) :-
8050 chr_pp_flag(dynattr,off), !,
8051 make_attr(N,_,SuspensionsList,Attr).
8053 % NEW
8054 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8055 % writeln(get_all_suspensions2),
8056 length(SuspensionsList,N),
8057 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8060 % NEW
8061 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8062 % writeln(normalize_attr),
8063 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8065 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8066 chr_pp_flag(dynattr,off), !,
8067 make_attr(N,_,SuspsList,Attr),
8068 nth1(Position,SuspsList,Suspensions).
8070 % NEW
8071 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8072 % writeln(get_suspensions),
8073 Goal =
8074 ( memberchk(Position-Suspensions,TAttr) ->
8075 true
8076 ;
8077 Suspensions = []
8078 ).
8080 %-------------------------------------------------------------------------------
8081 % +N: number of constraint symbols
8082 % +Suspension: source-level variable, for suspension
8083 % +Position: constraint symbol number
8084 % -Attr: source-level term, for new attribute
8085 singleton_attr(N,Suspension,Position,Attr) :-
8086 chr_pp_flag(dynattr,off), !,
8087 or_pattern(Position,Pattern),
8088 make_attr(N,Pattern,SuspsList,Attr),
8089 nth1(Position,SuspsList,[Suspension]),
8090 chr_delete(SuspsList,[Suspension],RestSuspsList),
8091 set_elems(RestSuspsList,[]).
8093 % NEW
8094 singleton_attr(N,Suspension,Position,Attr) :-
8095 % writeln(singleton_attr),
8096 Attr = [Position-[Suspension]].
8098 %-------------------------------------------------------------------------------
8099 % +N: number of constraint symbols
8100 % +Suspension: source-level variable, for suspension
8101 % +Position: constraint symbol number
8102 % +TAttr: source-level variable, for old attribute
8103 % -Goal: goal for creating new attribute
8104 % -NTAttr: source-level variable, for new attribute
8105 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8106 chr_pp_flag(dynattr,off), !,
8107 make_attr(N,Mask,SuspsList,Attr),
8108 or_pattern(Position,Pattern),
8109 nth1(Position,SuspsList,Susps),
8110 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8111 make_attr(N,Mask,SuspsList1,NewAttr1),
8112 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8113 make_attr(N,NewMask,SuspsList2,NewAttr2),
8114 Goal = (
8115 TAttr = Attr,
8116 ( Mask /\ Pattern =:= Pattern ->
8117 NTAttr = NewAttr1
8118 ;
8119 NewMask is Mask \/ Pattern,
8120 NTAttr = NewAttr2
8121 )
8122 ), !.
8124 % NEW
8125 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8126 % writeln(add_attr),
8127 Goal =
8128 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8129 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8130 ;
8131 NTAttr = [Position-[Suspension]|TAttr]
8132 ).
8134 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8135 chr_pp_flag(dynattr,off), !,
8136 or_pattern(Position,Pattern),
8137 and_pattern(Position,DelPattern),
8138 make_attr(N,Mask,SuspsList,Attr),
8139 nth1(Position,SuspsList,Susps),
8140 substitute_eq(Susps,SuspsList,[],SuspsList1),
8141 make_attr(N,NewMask,SuspsList1,Attr1),
8142 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8143 make_attr(N,Mask,SuspsList2,Attr2),
8144 get_target_module(Mod),
8145 Goal = (
8146 TAttr = Attr,
8147 ( Mask /\ Pattern =:= Pattern ->
8148 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8149 ( NewSusps == [] ->
8150 NewMask is Mask /\ DelPattern,
8151 ( NewMask == 0 ->
8152 del_attr(Var,Mod)
8153 ;
8154 put_attr(Var,Mod,Attr1)
8155 )
8156 ;
8157 put_attr(Var,Mod,Attr2)
8158 )
8159 ;
8160 true
8161 )
8162 ), !.
8164 % NEW
8165 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8166 % writeln(rem_attr),
8167 get_target_module(Mod),
8168 Goal =
8169 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8170 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8171 ( NSuspensions == [] ->
8172 ( RAttr == [] ->
8173 del_attr(Var,Mod)
8174 ;
8175 put_attr(Var,Mod,RAttr)
8176 )
8177 ;
8178 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8179 )
8180 ;
8181 true
8182 ).
8184 %-------------------------------------------------------------------------------
8185 % +N: number of constraint symbols
8186 % +TAttr1: source-level variable, for attribute
8187 % +TAttr2: source-level variable, for other attribute
8188 % -Goal: goal for merging the two attributes
8189 % -Attr: source-level term, for merged attribute
8190 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8191 chr_pp_flag(dynattr,off), !,
8192 make_attr(N,Mask1,SuspsList1,Attr1),
8193 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8194 Goal = (
8195 TAttr1 = Attr1,
8196 Goal2
8197 ).
8199 % NEW
8200 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8201 % writeln(merge_attributes),
8202 Goal = (
8203 sort(TAttr1,Sorted1),
8204 sort(TAttr2,Sorted2),
8205 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8206 ).
8209 %-------------------------------------------------------------------------------
8210 % +N: number of constraint symbols
8211 % +Mask1: ...
8212 % +SuspsList1: static term, for suspensions list
8213 % +TAttr2: source-level variable, for other attribute
8214 % -Goal: goal for merging the two attributes
8215 % -Attr: source-level term, for merged attribute
8216 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8217 make_attr(N,Mask2,SuspsList2,Attr2),
8218 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8219 list2conj(Gs,SortGoals),
8220 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8221 make_attr(N,Mask,SuspsList,Attr),
8222 Goal = (
8223 TAttr2 = Attr2,
8224 SortGoals,
8225 Mask is Mask1 \/ Mask2
8226 ).
8229 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8230 % Storetype dependent lookup
8232 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8233 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8234 %% -Goal,-SuspensionList) is det.
8235 %
8236 % Create a universal lookup goal for given head.
8237 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8238 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8239 functor(Head,F,A),
8240 get_store_type(F/A,StoreType),
8241 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8243 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8244 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8245 %% -Goal,-SuspensionList) is det.
8246 %
8247 % Create a universal lookup goal for given head.
8248 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8249 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8250 functor(Head,F,A),
8251 get_store_type(F/A,StoreType),
8252 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8254 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8255 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8256 %% +GroundVars,-Goal,-SuspensionList) is det.
8257 %
8258 % Create a universal lookup goal for given head.
8259 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8260 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8261 functor(Head,F,A),
8262 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8263 update_store_type(F/A,default).
8264 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8265 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8266 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8267 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8268 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8269 functor(Head,F,A),
8270 global_ground_store_name(F/A,StoreName),
8271 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8272 update_store_type(F/A,global_ground).
8273 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8274 arg(VarIndex,Head,OVar),
8275 arg(KeyIndex,Head,OKey),
8276 translate([OVar,OKey],VarDict,[Var,Key]),
8277 get_target_module(Module),
8278 Goal = (
8279 get_attr(Var,Module,AssocStore),
8280 lookup_assoc_store(AssocStore,Key,AllSusps)
8281 ).
8282 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8283 functor(Head,F,A),
8284 global_singleton_store_name(F/A,StoreName),
8285 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8286 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8287 update_store_type(F/A,global_singleton).
8288 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8289 once((
8290 member(ST,StoreTypes),
8291 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8292 )).
8293 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8294 functor(Head,F,A),
8295 arg(Index,Head,Var),
8296 translate([Var],VarDict,[KeyVar]),
8297 delay_phase_end(validate_store_type_assumptions,
8298 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8299 ),
8300 update_store_type(F/A,identifier_store(Index)),
8301 get_identifier_index(F/A,Index,_).
8302 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8303 functor(Head,F,A),
8304 arg(Index,Head,Var),
8305 ( var(Var) ->
8306 translate([Var],VarDict,[KeyVar]),
8307 Goal = StructGoal
8308 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8309 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8310 Goal = (LookupGoal,StructGoal)
8311 ),
8312 delay_phase_end(validate_store_type_assumptions,
8313 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8314 ),
8315 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8316 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8318 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8319 get_identifier_size(ISize),
8320 functor(Struct,struct,ISize),
8321 get_identifier_index(C,Index,IIndex),
8322 arg(IIndex,Struct,AllSusps),
8323 Goal = (KeyVar = Struct).
8325 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8326 type_indexed_identifier_structure(IndexType,Struct),
8327 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8328 arg(IIndex,Struct,AllSusps),
8329 Goal = (KeyVar = Struct).
8331 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8332 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8333 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8334 %
8335 % Create a universal hash lookup goal for given head.
8336 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8337 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8338 once((
8339 member(Index,Indexes),
8340 multi_hash_key_args(Index,Head,KeyArgs),
8341 (
8342 translate(KeyArgs,VarDict,KeyArgCopies)
8343 ;
8344 ground(KeyArgs), KeyArgCopies = KeyArgs
8345 )
8346 )),
8347 ( KeyArgCopies = [KeyCopy] ->
8348 true
8349 ;
8350 KeyCopy =.. [k|KeyArgCopies]
8351 ),
8352 functor(Head,F,A),
8353 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8355 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8356 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8358 Goal = (GroundCheck,LookupGoal),
8360 ( HashType == inthash ->
8361 update_store_type(F/A,multi_inthash([Index]))
8362 ;
8363 update_store_type(F/A,multi_hash([Index]))
8364 ).
8366 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8367 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8368 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8369 %% +VarArgDict,-NewVarArgDict) is det.
8370 %
8371 % Create existential lookup goal for given head.
8372 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8373 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8374 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8375 sbag_member_call(Susp,AllSusps,Sbag),
8376 functor(Head,F,A),
8377 delay_phase_end(validate_store_type_assumptions,
8378 ( static_suspension_term(F/A,SuspTerm),
8379 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8380 )
8381 ),
8382 Goal = (
8383 UniversalGoal,
8384 Sbag,
8385 Susp = SuspTerm,
8386 GetState
8387 ).
8388 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8389 functor(Head,F,A),
8390 global_singleton_store_name(F/A,StoreName),
8391 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8392 Goal = (
8393 GetStoreGoal, % nb_getval(StoreName,Susp),
8394 Susp \== [],
8395 Susp = SuspTerm
8396 ),
8397 update_store_type(F/A,global_singleton).
8398 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8399 once((
8400 member(ST,StoreTypes),
8401 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8402 )).
8403 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8404 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8405 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8406 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8407 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8408 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8409 hash_index_filter(Pairs,Index,NPairs),
8411 functor(Head,F,A),
8412 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8413 Sbag = (AllSusps = [Susp])
8414 ;
8415 sbag_member_call(Susp,AllSusps,Sbag)
8416 ),
8417 delay_phase_end(validate_store_type_assumptions,
8418 ( static_suspension_term(F/A,SuspTerm),
8419 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8420 )
8421 ),
8422 Goal = (
8423 LookupGoal,
8424 Sbag,
8425 Susp = SuspTerm, % not inlined
8426 GetState
8427 ).
8428 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8429 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8430 hash_index_filter(Pairs,Index,NPairs),
8432 functor(Head,F,A),
8433 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8434 Sbag = (AllSusps = [Susp])
8435 ;
8436 sbag_member_call(Susp,AllSusps,Sbag)
8437 ),
8438 delay_phase_end(validate_store_type_assumptions,
8439 ( static_suspension_term(F/A,SuspTerm),
8440 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8441 )
8442 ),
8443 Goal = (
8444 LookupGoal,
8445 Sbag,
8446 Susp = SuspTerm, % not inlined
8447 GetState
8448 ).
8449 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8450 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8451 sbag_member_call(Susp,Susps,Sbag),
8452 functor(Head,F,A),
8453 delay_phase_end(validate_store_type_assumptions,
8454 ( static_suspension_term(F/A,SuspTerm),
8455 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8456 )
8457 ),
8458 Goal = (
8459 UGoal,
8460 Sbag,
8461 Susp = SuspTerm, % not inlined
8462 GetState
8463 ).
8465 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8466 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8467 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8468 %% +VarArgDict,-NewVarArgDict) is det.
8469 %
8470 % Create existential hash lookup goal for given head.
8471 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8472 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8473 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8475 hash_index_filter(Pairs,Index,NPairs),
8477 functor(Head,F,A),
8478 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8479 Sbag = (AllSusps = [Susp])
8480 ;
8481 sbag_member_call(Susp,AllSusps,Sbag)
8482 ),
8483 delay_phase_end(validate_store_type_assumptions,
8484 ( static_suspension_term(F/A,SuspTerm),
8485 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8486 )
8487 ),
8488 Goal = (
8489 LookupGoal,
8490 Sbag,
8491 Susp = SuspTerm, % not inlined
8492 GetState
8493 ).
8495 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8496 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8497 %
8498 % Filter out pairs already covered by given hash index.
8499 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8500 hash_index_filter(Pairs,Index,NPairs) :-
8501 ( integer(Index) ->
8502 NIndex = [Index]
8503 ;
8504 NIndex = Index
8505 ),
8506 hash_index_filter(Pairs,NIndex,1,NPairs).
8508 hash_index_filter([],_,_,[]).
8509 hash_index_filter([P|Ps],Index,N,NPairs) :-
8510 ( Index = [I|Is] ->
8511 NN is N + 1,
8512 ( I > N ->
8513 NPairs = [P|NPs],
8514 hash_index_filter(Ps,[I|Is],NN,NPs)
8515 ; I == N ->
8516 hash_index_filter(Ps,Is,NN,NPairs)
8517 )
8518 ;
8519 NPairs = [P|Ps]
8520 ).
8522 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8523 %------------------------------------------------------------------------------%
8524 %% assume_constraint_stores(+ConstraintSymbols) is det.
8525 %
8526 % Compute all constraint store types that are possible for the given
8527 % =ConstraintSymbols=.
8528 %------------------------------------------------------------------------------%
8529 assume_constraint_stores([]).
8530 assume_constraint_stores([C|Cs]) :-
8531 ( chr_pp_flag(debugable,off),
8532 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8533 is_stored(C),
8534 get_store_type(C,default) ->
8535 get_indexed_arguments(C,AllIndexedArgs),
8536 get_constraint_mode(C,Modes),
8537 findall(Index,(member(Index,AllIndexedArgs),
8538 nth(Index,Modes,+)),IndexedArgs),
8539 length(IndexedArgs,NbIndexedArgs),
8540 % Construct Index Combinations
8541 ( NbIndexedArgs > 10 ->
8542 findall([Index],member(Index,IndexedArgs),Indexes)
8543 ;
8544 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8545 predsort(longer_list,UnsortedIndexes,Indexes)
8546 ),
8547 % EXPERIMENTAL HEURISTIC
8548 % findall(Index, (
8549 % member(Arg1,IndexedArgs),
8550 % member(Arg2,IndexedArgs),
8551 % Arg1 =< Arg2,
8552 % sort([Arg1,Arg2], Index)
8553 % ), UnsortedIndexes),
8554 % predsort(longer_list,UnsortedIndexes,Indexes),
8555 % Choose Index Type
8556 ( get_functional_dependency(C,1,Pattern,Key),
8557 all_distinct_var_args(Pattern), Key == [] ->
8558 assumed_store_type(C,global_singleton)
8559 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8560 get_constraint_type_det(C,ArgTypes),
8561 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8563 ( IntHashIndexes = [] ->
8564 Stores = Stores1
8565 ;
8566 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8567 ),
8568 ( HashIndexes = [] ->
8569 Stores1 = Stores2
8570 ;
8571 Stores1 = [multi_hash(HashIndexes)|Stores2]
8572 ),
8573 ( IdentifierIndexes = [] ->
8574 Stores2 = Stores3
8575 ;
8576 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8577 append(WrappedIdentifierIndexes,Stores3,Stores2)
8578 ),
8579 append(CompoundIdentifierIndexes,Stores4,Stores3),
8580 ( only_ground_indexed_arguments(C)
8581 -> Stores4 = [global_ground]
8582 ; Stores4 = [default]
8583 ),
8584 assumed_store_type(C,multi_store(Stores))
8585 ; true
8586 )
8587 ;
8588 true
8589 ),
8590 assume_constraint_stores(Cs).
8592 %------------------------------------------------------------------------------%
8593 %% partition_indexes(+Indexes,+Types,
8594 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8595 %------------------------------------------------------------------------------%
8596 partition_indexes([],_,[],[],[],[]).
8597 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8598 ( Index = [I],
8599 nth(I,Types,Type),
8600 unalias_type(Type,UnAliasedType),
8601 UnAliasedType == chr_identifier ->
8602 IdentifierIndexes = [I|RIdentifierIndexes],
8603 IntHashIndexes = RIntHashIndexes,
8604 HashIndexes = RHashIndexes,
8605 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8606 ; Index = [I],
8607 nth(I,Types,Type),
8608 unalias_type(Type,UnAliasedType),
8609 nonvar(UnAliasedType),
8610 UnAliasedType = chr_identifier(IndexType) ->
8611 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8612 IdentifierIndexes = RIdentifierIndexes,
8613 IntHashIndexes = RIntHashIndexes,
8614 HashIndexes = RHashIndexes
8615 ; Index = [I],
8616 nth(I,Types,Type),
8617 unalias_type(Type,UnAliasedType),
8618 UnAliasedType == dense_int ->
8619 IntHashIndexes = [Index|RIntHashIndexes],
8620 HashIndexes = RHashIndexes,
8621 IdentifierIndexes = RIdentifierIndexes,
8622 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8623 ; member(I,Index),
8624 nth(I,Types,Type),
8625 unalias_type(Type,UnAliasedType),
8626 nonvar(UnAliasedType),
8627 UnAliasedType = chr_identifier(_) ->
8628 % don't use chr_identifiers in hash indexes
8629 IntHashIndexes = RIntHashIndexes,
8630 HashIndexes = RHashIndexes,
8631 IdentifierIndexes = RIdentifierIndexes,
8632 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8633 ;
8634 IntHashIndexes = RIntHashIndexes,
8635 HashIndexes = [Index|RHashIndexes],
8636 IdentifierIndexes = RIdentifierIndexes,
8637 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8638 ),
8639 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8641 longer_list(R,L1,L2) :-
8642 length(L1,N1),
8643 length(L2,N2),
8644 compare(Rt,N2,N1),
8645 ( Rt == (=) ->
8646 compare(R,L1,L2)
8647 ;
8648 R = Rt
8649 ).
8651 all_distinct_var_args(Term) :-
8652 Term =.. [_|Args],
8653 copy_term_nat(Args,NArgs),
8654 all_distinct_var_args_(NArgs).
8656 all_distinct_var_args_([]).
8657 all_distinct_var_args_([X|Xs]) :-
8658 var(X),
8659 X = t,
8660 all_distinct_var_args_(Xs).
8662 get_indexed_arguments(C,IndexedArgs) :-
8663 C = F/A,
8664 get_indexed_arguments(1,A,C,IndexedArgs).
8666 get_indexed_arguments(I,N,C,L) :-
8667 ( I > N ->
8668 L = []
8669 ; ( is_indexed_argument(C,I) ->
8670 L = [I|T]
8671 ;
8672 L = T
8673 ),
8674 J is I + 1,
8675 get_indexed_arguments(J,N,C,T)
8676 ).
8678 validate_store_type_assumptions([]).
8679 validate_store_type_assumptions([C|Cs]) :-
8680 validate_store_type_assumption(C),
8681 validate_store_type_assumptions(Cs).
8683 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8684 % new code generation
8685 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8686 Rule = rule(H1,_,Guard,Body),
8687 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8688 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8689 flatten(VarsAndSuspsList,VarsAndSusps),
8690 Vars = [ [] | VarsAndSusps],
8691 build_head(F,A,[O|Id],Vars,Head),
8692 ( PrevId0 = [_] ->
8693 PrevId = PrevId0
8694 ;
8695 PrevId = [O|PrevId0]
8696 ),
8697 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8698 Clause = ( Head :- PredecessorCall),
8699 add_dummy_location(Clause,LocatedClause),
8700 L = [LocatedClause | T].
8701 % ( H1 == [],
8702 % functor(CurrentHead,CF,CA),
8703 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8704 % L = T
8705 % ;
8706 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8707 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8708 % flatten(VarsAndSuspsList,VarsAndSusps),
8709 % Vars = [ [] | VarsAndSusps],
8710 % build_head(F,A,Id,Vars,Head),
8711 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8712 % Clause = ( Head :- PredecessorCall),
8713 % L = [Clause | T]
8714 % ).
8716 % skips back intelligently over global_singleton lookups
8717 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8718 ( Id = [0|_] ->
8719 % TOM: add partial success continuation optimization here!
8720 next_id(Id,PrevId),
8721 PrevVarsAndSusps = BaseCallArgs
8722 ;
8723 VarsAndSuspsList = [_|AllButFirstList],
8724 dec_id(Id,PrevId1),
8725 ( PrevHeads = [PrevHead|PrevHeads1],
8726 functor(PrevHead,F,A),
8727 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8728 PrevIterators = [_|PrevIterators1],
8729 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8730 ;
8731 PrevId = PrevId1,
8732 flatten(AllButFirstList,AllButFirst),
8733 PrevIterators = [PrevIterator|_],
8734 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8735 )
8736 ).
8738 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8739 Rule = rule(_,_,Guard,Body),
8740 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8741 init(AllSusps,PreSusps),
8742 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8743 gen_var(OtherSusps),
8744 functor(CurrentHead,OtherF,OtherA),
8745 gen_vars(OtherA,OtherVars),
8746 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8747 get_constraint_mode(OtherF/OtherA,Mode),
8748 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8750 delay_phase_end(validate_store_type_assumptions,
8751 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8752 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8753 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8754 )
8755 ),
8757 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8758 % create_get_mutable_ref(active,State,GetMutable),
8759 CurrentSuspTest = (
8760 OtherSusp = OtherSuspension,
8761 GetState,
8762 DiffSuspGoals,
8763 FirstMatching
8764 ),
8765 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8766 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8767 inc_id(Id,NestedId),
8768 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8769 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8770 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8771 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8772 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
8774 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8775 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8776 RecursiveVars = PreVarsAndSusps1
8777 ;
8778 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8779 PrevId0 = Id
8780 ),
8781 ( PrevId0 = [_] ->
8782 PrevId = PrevId0
8783 ;
8784 PrevId = [O|PrevId0]
8785 ),
8786 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8788 Clause = (
8789 ClauseHead :-
8790 ( CurrentSuspTest,
8791 NextSuspGoal
8792 ->
8793 NestedHead
8794 ; RecursiveHead
8795 )
8796 ),
8797 add_dummy_location(Clause,LocatedClause),
8798 L = [LocatedClause|T].
8800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8802 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8803 % Observation Analysis
8804 %
8805 % CLASSIFICATION
8806 % Enabled
8807 %
8808 % Analysis based on Abstract Interpretation paper.
8809 %
8810 % TODO:
8811 % stronger analysis domain [research]
8813 :- chr_constraint
8814 initial_call_pattern/1,
8815 call_pattern/1,
8816 call_pattern_worker/1,
8817 final_answer_pattern/2,
8818 abstract_constraints/1,
8819 depends_on/2,
8820 depends_on_ap/4,
8821 depends_on_goal/2,
8822 ai_observed_internal/2,
8823 % ai_observed/2,
8824 ai_not_observed_internal/2,
8825 ai_not_observed/2,
8826 ai_is_observed/2,
8827 depends_on_as/3,
8828 ai_observation_gather_results/0.
8830 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8831 :- chr_type program_point == any.
8833 :- chr_option(mode,initial_call_pattern(+)).
8834 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8836 :- chr_option(mode,call_pattern(+)).
8837 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8839 :- chr_option(mode,call_pattern_worker(+)).
8840 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8842 :- chr_option(mode,final_answer_pattern(+,+)).
8843 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8845 :- chr_option(mode,abstract_constraints(+)).
8846 :- chr_option(type_declaration,abstract_constraints(list)).
8848 :- chr_option(mode,depends_on(+,+)).
8849 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8851 :- chr_option(mode,depends_on_as(+,+,+)).
8852 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8853 :- chr_option(mode,depends_on_goal(+,+)).
8854 :- chr_option(mode,ai_is_observed(+,+)).
8855 :- chr_option(mode,ai_not_observed(+,+)).
8856 % :- chr_option(mode,ai_observed(+,+)).
8857 :- chr_option(mode,ai_not_observed_internal(+,+)).
8858 :- chr_option(mode,ai_observed_internal(+,+)).
8861 abstract_constraints_fd @
8862 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8864 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8865 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8866 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8868 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8869 ai_is_observed(_,_) <=> true.
8871 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8872 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8873 ai_observation_gather_results <=> true.
8875 %------------------------------------------------------------------------------%
8876 % Main Analysis Entry
8877 %------------------------------------------------------------------------------%
8878 ai_observation_analysis(ACs) :-
8879 ( chr_pp_flag(ai_observation_analysis,on),
8880 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8881 list_to_ord_set(ACs,ACSet),
8882 abstract_constraints(ACSet),
8883 ai_observation_schedule_initial_calls(ACSet,ACSet),
8884 ai_observation_gather_results
8885 ;
8886 true
8887 ).
8889 ai_observation_schedule_initial_calls([],_).
8890 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8891 ai_observation_schedule_initial_call(AC,ACs),
8892 ai_observation_schedule_initial_calls(RACs,ACs).
8894 ai_observation_schedule_initial_call(AC,ACs) :-
8895 ai_observation_top(AC,CallPattern),
8896 % ai_observation_bot(AC,ACs,CallPattern),
8897 initial_call_pattern(CallPattern).
8899 ai_observation_schedule_new_calls([],AP).
8900 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8901 AP = odom(_,Set),
8902 initial_call_pattern(odom(AC,Set)),
8903 ai_observation_schedule_new_calls(ACs,AP).
8905 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8906 <=>
8907 ai_observation_leq(AP2,AP1)
8908 |
8909 true.
8911 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
8913 initial_call_pattern(CP) ==> call_pattern(CP).
8915 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
8916 ==>
8917 ai_observation_schedule_new_calls(ACs,AP)
8918 pragma
8919 passive(ID3).
8921 call_pattern(CP) \ call_pattern(CP) <=> true.
8923 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
8924 final_answer_pattern(CP1,AP).
8926 %call_pattern(CP) ==> writeln(call_pattern(CP)).
8928 call_pattern(CP) ==> call_pattern_worker(CP).
8930 %------------------------------------------------------------------------------%
8931 % Abstract Goal
8932 %------------------------------------------------------------------------------%
8934 % AbstractGoala
8935 %call_pattern(odom([],Set)) ==>
8936 % final_answer_pattern(odom([],Set),odom([],Set)).
8938 call_pattern_worker(odom([],Set)) <=>
8939 % writeln(' - AbstractGoal'(odom([],Set))),
8940 final_answer_pattern(odom([],Set),odom([],Set)).
8942 % AbstractGoalb
8943 call_pattern_worker(odom([G|Gs],Set)) <=>
8944 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
8945 CP1 = odom(G,Set),
8946 depends_on_goal(odom([G|Gs],Set),CP1),
8947 call_pattern(CP1).
8949 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
8950 <=> true pragma passive(ID).
8951 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
8952 ==>
8953 CP1 = odom([_|Gs],_),
8954 AP2 = odom([],Set),
8955 CCP = odom(Gs,Set),
8956 call_pattern(CCP),
8957 depends_on(CP1,CCP).
8959 %------------------------------------------------------------------------------%
8960 % Abstract Disjunction
8961 %------------------------------------------------------------------------------%
8963 call_pattern_worker(odom((AG1;AG2),Set)) <=>
8964 CP = odom((AG1;AG2),Set),
8965 InitialAnswerApproximation = odom([],Set),
8966 final_answer_pattern(CP,InitialAnswerApproximation),
8967 CP1 = odom(AG1,Set),
8968 CP2 = odom(AG2,Set),
8969 call_pattern(CP1),
8970 call_pattern(CP2),
8971 depends_on_as(CP,CP1,CP2).
8973 %------------------------------------------------------------------------------%
8974 % Abstract Solve
8975 %------------------------------------------------------------------------------%
8976 call_pattern_worker(odom(builtin,Set)) <=>
8977 % writeln(' - AbstractSolve'(odom(builtin,Set))),
8978 ord_empty(EmptySet),
8979 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
8981 %------------------------------------------------------------------------------%
8982 % Abstract Drop
8983 %------------------------------------------------------------------------------%
8984 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8985 <=>
8986 O > MO
8987 |
8988 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
8989 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8990 pragma
8991 passive(ID2).
8993 %------------------------------------------------------------------------------%
8994 % Abstract Activate
8995 %------------------------------------------------------------------------------%
8996 call_pattern_worker(odom(AC,Set))
8997 <=>
8998 AC = _ / _
8999 |
9000 % writeln(' - AbstractActivate'(odom(AC,Set))),
9001 CP = odom(occ(AC,1),Set),
9002 call_pattern(CP),
9003 depends_on(odom(AC,Set),CP).
9005 %------------------------------------------------------------------------------%
9006 % Abstract Passive
9007 %------------------------------------------------------------------------------%
9008 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9009 <=>
9010 is_passive(RuleNb,ID)
9011 |
9012 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9013 % DEFAULT
9014 NO is O + 1,
9015 DCP = odom(occ(C,NO),Set),
9016 call_pattern(DCP),
9017 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9018 depends_on(odom(occ(C,O),Set),DCP)
9019 pragma
9020 passive(ID2).
9021 %------------------------------------------------------------------------------%
9022 % Abstract Simplify
9023 %------------------------------------------------------------------------------%
9025 % AbstractSimplify
9026 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9027 <=>
9028 \+ is_passive(RuleNb,ID)
9029 |
9030 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9031 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9032 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9033 ai_observation_memo_abstract_goal(RuleNb,AG),
9034 call_pattern(odom(AG,Set2)),
9035 % DEFAULT
9036 NO is O + 1,
9037 DCP = odom(occ(C,NO),Set),
9038 call_pattern(DCP),
9039 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9040 % DEADLOCK AVOIDANCE
9041 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9042 pragma
9043 passive(ID2).
9045 depends_on_as(CP,CPS,CPD),
9046 final_answer_pattern(CPS,APS),
9047 final_answer_pattern(CPD,APD) ==>
9048 ai_observation_lub(APS,APD,AP),
9049 final_answer_pattern(CP,AP).
9052 :- chr_constraint
9053 ai_observation_memo_simplification_rest_heads/3,
9054 ai_observation_memoed_simplification_rest_heads/3.
9056 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9057 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9059 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9060 <=>
9061 QRH = RH.
9062 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9063 <=>
9064 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9065 once(select2(ID,_,IDs1,H1,_,RestH1)),
9066 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9067 ai_observation_abstract_constraints(H2,ACs,AH2),
9068 append(ARestHeads,AH2,AbstractHeads),
9069 sort(AbstractHeads,QRH),
9070 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9071 pragma
9072 passive(ID1),
9073 passive(ID2),
9074 passive(ID3).
9076 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9078 %------------------------------------------------------------------------------%
9079 % Abstract Propagate
9080 %------------------------------------------------------------------------------%
9083 % AbstractPropagate
9084 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9085 <=>
9086 \+ is_passive(RuleNb,ID)
9087 |
9088 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9089 % observe partners
9090 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9091 ai_observation_observe_set(Set,AHs,Set2),
9092 ord_add_element(Set2,C,Set3),
9093 ai_observation_memo_abstract_goal(RuleNb,AG),
9094 call_pattern(odom(AG,Set3)),
9095 ( ord_memberchk(C,Set2) ->
9096 Delete = no
9097 ;
9098 Delete = yes
9099 ),
9100 % DEFAULT
9101 NO is O + 1,
9102 DCP = odom(occ(C,NO),Set),
9103 call_pattern(DCP),
9104 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9105 pragma
9106 passive(ID2).
9108 :- chr_constraint
9109 ai_observation_memo_propagation_rest_heads/3,
9110 ai_observation_memoed_propagation_rest_heads/3.
9112 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9113 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9115 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9116 <=>
9117 QRH = RH.
9118 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9119 <=>
9120 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9121 once(select2(ID,_,IDs2,H2,_,RestH2)),
9122 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9123 ai_observation_abstract_constraints(H1,ACs,AH1),
9124 append(ARestHeads,AH1,AbstractHeads),
9125 sort(AbstractHeads,QRH),
9126 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9127 pragma
9128 passive(ID1),
9129 passive(ID2),
9130 passive(ID3).
9132 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9134 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9135 final_answer_pattern(CP,APD).
9136 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9137 final_answer_pattern(CPD,APD) ==>
9138 true |
9139 CP = odom(occ(C,O),_),
9140 ( ai_observation_is_observed(APP,C) ->
9141 ai_observed_internal(C,O)
9142 ;
9143 ai_not_observed_internal(C,O)
9144 ),
9145 ( Delete == yes ->
9146 APP = odom([],Set0),
9147 ord_del_element(Set0,C,Set),
9148 NAPP = odom([],Set)
9149 ;
9150 NAPP = APP
9151 ),
9152 ai_observation_lub(NAPP,APD,AP),
9153 final_answer_pattern(CP,AP).
9155 %------------------------------------------------------------------------------%
9156 % Catch All
9157 %------------------------------------------------------------------------------%
9159 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9161 %------------------------------------------------------------------------------%
9162 % Auxiliary Predicates
9163 %------------------------------------------------------------------------------%
9165 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9166 ord_intersection(S1,S2,S3).
9168 ai_observation_bot(AG,AS,odom(AG,AS)).
9170 ai_observation_top(AG,odom(AG,EmptyS)) :-
9171 ord_empty(EmptyS).
9173 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9174 ord_subset(S2,S1).
9176 ai_observation_observe_set(S,ACSet,NS) :-
9177 ord_subtract(S,ACSet,NS).
9179 ai_observation_abstract_constraint(C,ACs,AC) :-
9180 functor(C,F,A),
9181 AC = F/A,
9182 memberchk(AC,ACs).
9184 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9185 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9187 %------------------------------------------------------------------------------%
9188 % Abstraction of Rule Bodies
9189 %------------------------------------------------------------------------------%
9191 :- chr_constraint
9192 ai_observation_memoed_abstract_goal/2,
9193 ai_observation_memo_abstract_goal/2.
9195 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9196 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9198 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9199 <=>
9200 QAG = AG
9201 pragma
9202 passive(ID1).
9204 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9205 <=>
9206 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9207 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9208 QAG = AG,
9209 ai_observation_memoed_abstract_goal(RuleNb,AG)
9210 pragma
9211 passive(ID1),
9212 passive(ID2).
9214 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9215 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9216 term_variables((H1,H2,Guard),HVars),
9217 append(H1,H2,Heads),
9218 % variables that are declared to be ground are safe,
9219 ground_vars(Heads,GroundVars),
9220 % so we remove them from the list of 'dangerous' head variables
9221 list_difference_eq(HVars,GroundVars,HV),
9222 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9223 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9224 % HV are 'dangerous' variables, all others are fresh and safe
9226 ground_vars([],[]).
9227 ground_vars([H|Hs],GroundVars) :-
9228 functor(H,F,A),
9229 get_constraint_mode(F/A,Mode),
9230 % TOM: fix this code!
9231 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9232 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9233 ground_vars(Hs,GroundVars2),
9234 append(GroundVars1,GroundVars2,GroundVars).
9236 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9237 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9238 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9239 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9240 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9241 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9242 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9243 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9244 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9245 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9246 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9247 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9248 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9249 % non-CHR constraint is safe if it only binds fresh variables
9250 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9251 builtin_binds_b(G,Vars),
9252 intersect_eq(Vars,HV,[]),
9253 !.
9254 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9255 AG = builtin. % default case if goal is not recognized/safe
9257 ai_observation_is_observed(odom(_,ACSet),AC) :-
9258 \+ ord_memberchk(AC,ACSet).
9260 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9261 unconditional_occurrence(C,O) :-
9262 get_occurrence(C,O,RuleNb,ID),
9263 get_rule(RuleNb,PRule),
9264 PRule = pragma(ORule,_,_,_,_),
9265 copy_term_nat(ORule,Rule),
9266 Rule = rule(H1,H2,Guard,_),
9267 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9268 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9269 once((
9270 H1 = [Head], H2 == []
9271 ;
9272 H2 = [Head], H1 == [], \+ may_trigger(C)
9273 )),
9274 functor(Head,F,A),
9275 Head =.. [_|Args],
9276 unconditional_occurrence_args(Args).
9278 unconditional_occurrence_args([]).
9279 unconditional_occurrence_args([X|Xs]) :-
9280 var(X),
9281 X = x,
9282 unconditional_occurrence_args(Xs).
9284 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9286 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9287 % Partial wake analysis
9288 %
9289 % In a Var = Var unification do not wake up constraints of both variables,
9290 % but rather only those of one variable.
9291 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9293 :- chr_constraint partial_wake_analysis/0.
9294 :- chr_constraint no_partial_wake/1.
9295 :- chr_option(mode,no_partial_wake(+)).
9296 :- chr_constraint wakes_partially/1.
9297 :- chr_option(mode,wakes_partially(+)).
9299 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9300 ==>
9301 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9302 ( is_passive(RuleNb,ID) ->
9303 true
9304 ; Type == simplification ->
9305 select(H,H1,RestH1),
9306 H =.. [_|Args],
9307 term_variables(Guard,Vars),
9308 partial_wake_args(Args,ArgModes,Vars,FA)
9309 ; % Type == propagation ->
9310 select(H,H2,RestH2),
9311 H =.. [_|Args],
9312 term_variables(Guard,Vars),
9313 partial_wake_args(Args,ArgModes,Vars,FA)
9314 ).
9316 partial_wake_args([],_,_,_).
9317 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9318 ( Mode \== (+) ->
9319 ( nonvar(Arg) ->
9320 no_partial_wake(C)
9321 ; memberchk_eq(Arg,Vars) ->
9322 no_partial_wake(C)
9323 ;
9324 true
9325 )
9326 ;
9327 true
9328 ),
9329 partial_wake_args(Args,Modes,Vars,C).
9331 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9333 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9335 wakes_partially(C) <=> true.
9338 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9339 % Generate rules that implement chr_show_store/1 functionality.
9340 %
9341 % CLASSIFICATION
9342 % Experimental
9343 % Unused
9344 %
9345 % Generates additional rules:
9346 %
9347 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9348 % ...
9349 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9350 % $show <=> true.
9352 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9353 ( chr_pp_flag(show,on) ->
9354 Constraints = ['$show'/0|Constraints0],
9355 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9356 inc_rule_count(RuleNb),
9357 Rule = pragma(
9358 rule(['$show'],[],true,true),
9359 ids([0],[]),
9360 [],
9361 no,
9362 RuleNb
9363 )
9364 ;
9365 Constraints = Constraints0,
9366 Rules = Rules0
9367 ).
9369 generate_show_rules([],Rules,Rules).
9370 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9371 functor(C,F,A),
9372 inc_rule_count(RuleNb),
9373 Rule = pragma(
9374 rule([],['$show',C],true,writeln(C)),
9375 ids([],[0,1]),
9376 [passive(1)],
9377 no,
9378 RuleNb
9379 ),
9380 generate_show_rules(Rest,Tail,Rules).
9382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9383 % Custom supension term layout
9385 static_suspension_term(F/A,Suspension) :-
9386 suspension_term_base(F/A,Base),
9387 Arity is Base + A,
9388 functor(Suspension,suspension,Arity).
9390 has_suspension_field(FA,Field) :-
9391 suspension_term_base_fields(FA,Fields),
9392 memberchk(Field,Fields).
9394 suspension_term_base(FA,Base) :-
9395 suspension_term_base_fields(FA,Fields),
9396 length(Fields,Base).
9398 suspension_term_base_fields(FA,Fields) :-
9399 ( chr_pp_flag(debugable,on) ->
9400 % 1. ID
9401 % 2. State
9402 % 3. Propagation History
9403 % 4. Generation Number
9404 % 5. Continuation Goal
9405 % 6. Functor
9406 Fields = [id,state,history,generation,continuation,functor]
9407 ;
9408 ( uses_history(FA) ->
9409 Fields = [id,state,history|Fields2]
9410 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9411 Fields = [state|Fields2]
9412 ;
9413 Fields = [id,state|Fields2]
9414 ),
9415 ( only_ground_indexed_arguments(FA) ->
9416 get_store_type(FA,StoreType),
9417 basic_store_types(StoreType,BasicStoreTypes),
9418 ( memberchk(global_ground,BasicStoreTypes) ->
9419 % 1. ID
9420 % 2. State
9421 % 3. Propagation History
9422 % 4. Global List Prev
9423 Fields2 = [global_list_prev|Fields3]
9424 ;
9425 % 1. ID
9426 % 2. State
9427 % 3. Propagation History
9428 Fields2 = Fields3
9429 ),
9430 ( chr_pp_flag(ht_removal,on)
9431 -> ht_prev_fields(BasicStoreTypes,Fields3)
9432 ; Fields3 = []
9433 )
9434 ; may_trigger(FA) ->
9435 % 1. ID
9436 % 2. State
9437 % 3. Propagation History
9438 ( uses_field(FA,generation) ->
9439 % 4. Generation Number
9440 % 5. Global List Prev
9441 Fields2 = [generation,global_list_prev|Fields3]
9442 ;
9443 Fields2 = [global_list_prev|Fields3]
9444 ),
9445 ( chr_pp_flag(mixed_stores,on),
9446 chr_pp_flag(ht_removal,on)
9447 -> get_store_type(FA,StoreType),
9448 basic_store_types(StoreType,BasicStoreTypes),
9449 ht_prev_fields(BasicStoreTypes,Fields3)
9450 ; Fields3 = []
9451 )
9452 ;
9453 % 1. ID
9454 % 2. State
9455 % 3. Propagation History
9456 % 4. Global List Prev
9457 Fields2 = [global_list_prev|Fields3],
9458 ( chr_pp_flag(mixed_stores,on),
9459 chr_pp_flag(ht_removal,on)
9460 -> get_store_type(FA,StoreType),
9461 basic_store_types(StoreType,BasicStoreTypes),
9462 ht_prev_fields(BasicStoreTypes,Fields3)
9463 ; Fields3 = []
9464 )
9465 )
9466 ).
9468 ht_prev_fields(Stores,Prevs) :-
9469 ht_prev_fields_int(Stores,PrevsList),
9470 append(PrevsList,Prevs).
9471 ht_prev_fields_int([],[]).
9472 ht_prev_fields_int([H|T],Fields) :-
9473 ( H = multi_hash(Indexes)
9474 -> maplist(ht_prev_field,Indexes,FH),
9475 Fields = [FH|FT]
9476 ; Fields = FT
9477 ),
9478 ht_prev_fields_int(T,FT).
9480 ht_prev_field(Index,Field) :-
9481 ( integer(Index)
9482 -> atom_concat('multi_hash_prev-',Index,Field)
9483 ; Index = [_|_]
9484 -> concat_atom(['multi_hash_prev-'|Index],Field)
9485 ).
9487 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9488 suspension_term_base_fields(FA,Fields),
9489 nth(Index,Fields,FieldName), !,
9490 arg(Index,StaticSuspension,Field).
9491 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9492 suspension_term_base(FA,Base),
9493 StaticSuspension =.. [_|Args],
9494 drop(Base,Args,Field).
9495 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9496 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9499 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9500 suspension_term_base_fields(FA,Fields),
9501 nth(Index,Fields,FieldName), !,
9502 Goal = arg(Index,DynamicSuspension,Field).
9503 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9504 static_suspension_term(FA,StaticSuspension),
9505 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9506 Goal = (DynamicSuspension = StaticSuspension).
9507 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9508 suspension_term_base(FA,Base),
9509 Index is I + Base,
9510 Goal = arg(Index,DynamicSuspension,Field).
9511 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9512 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9515 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9516 suspension_term_base_fields(FA,Fields),
9517 nth(Index,Fields,FieldName), !,
9518 Goal = setarg(Index,DynamicSuspension,Field).
9519 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9520 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9522 basic_store_types(multi_store(Types),Types) :- !.
9523 basic_store_types(Type,[Type]).
9525 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9526 %
9528 :- chr_constraint
9529 phase_end/1,
9530 delay_phase_end/2.
9532 :- chr_option(mode,phase_end(+)).
9533 :- chr_option(mode,delay_phase_end(+,?)).
9535 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9536 % phase_end(Phase) <=> true.
9539 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9540 :- chr_constraint
9541 does_use_history/2,
9542 uses_history/1,
9543 novel_production_call/4.
9545 :- chr_option(mode,uses_history(+)).
9546 :- chr_option(mode,does_use_history(+,+)).
9547 :- chr_option(mode,novel_production_call(+,+,?,?)).
9549 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9550 does_use_history(FA,_) \ uses_history(FA) <=> true.
9551 uses_history(_FA) <=> fail.
9553 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9554 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9556 :- chr_constraint
9557 does_use_field/2,
9558 uses_field/2.
9560 :- chr_option(mode,uses_field(+,+)).
9561 :- chr_option(mode,does_use_field(+,+)).
9563 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9564 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9565 uses_field(_FA,_Field) <=> fail.
9567 :- chr_constraint
9568 uses_state/2,
9569 if_used_state/5,
9570 used_states_known/0.
9572 :- chr_option(mode,uses_state(+,+)).
9573 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9576 % states ::= not_stored_yet | passive | active | triggered | removed
9577 %
9578 % allocate CREATES not_stored_yet
9579 % remove CHECKS not_stored_yet
9580 % activate CHECKS not_stored_yet
9581 %
9582 % ==> no allocate THEN no not_stored_yet
9584 % recurs CREATES inactive
9585 % lookup CHECKS inactive
9587 % insert CREATES active
9588 % activate CREATES active
9589 % lookup CHECKS active
9590 % recurs CHECKS active
9592 % runsusp CREATES triggered
9593 % lookup CHECKS triggered
9594 %
9595 % ==> no runsusp THEN no triggered
9597 % remove CREATES removed
9598 % runsusp CHECKS removed
9599 % lookup CHECKS removed
9600 % recurs CHECKS removed
9601 %
9602 % ==> no remove THEN no removed
9604 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9606 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9608 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9609 <=> ResultGoal = Used.
9610 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9611 <=> ResultGoal = NotUsed.
9613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9614 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9615 % (Feature for SSS)
9616 %
9617 % 1. Checking
9618 % ~~~~~~~~~~~
9619 %
9620 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9621 %
9622 % :- chr_option(declare_stored_constraints,on).
9623 %
9624 % the compiler will check for the storedness of constraints.
9625 %
9626 % By default, the compiler assumes that the programmer wants his constraints to
9627 % be never-stored. Hence, a warning will be issues when a constraint is actually
9628 % stored.
9629 %
9630 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9631 % to a constraint declaration, i.e. writes
9632 %
9633 % :- chr_constraint c(...) # stored.
9634 %
9635 % In that case a warning is issued when the constraint is never-stored.
9636 %
9637 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9638 % constraints are stored anyway.
9639 %
9640 %
9641 % 2. Rule Generation
9642 % ~~~~~~~~~~~~~~~~~~
9643 %
9644 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9645 %
9646 % :- chr_option(declare_stored_constraints,on).
9647 %
9648 % the compiler will generate default simplification rules for constraints.
9649 %
9650 % By default, no default rule is generated for a constraint. However, if the
9651 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9652 %
9653 % :- chr_constraint c(...) # default(Goal).
9654 %
9655 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9656 % the compiler generates a rule:
9657 %
9658 % c(_,...,_) <=> Goal.
9659 %
9660 % at the end of the program. If multiple default rules are generated, for several constraints,
9661 % then the order of the default rules is not specified.
9664 :- chr_constraint stored_assertion/1.
9665 :- chr_option(mode,stored_assertion(+)).
9666 :- chr_option(type_declaration,stored_assertion(constraint)).
9668 :- chr_constraint never_stored_default/2.
9669 :- chr_option(mode,never_stored_default(+,?)).
9670 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9672 % Rule Generation
9673 % ~~~~~~~~~~~~~~~
9675 generate_never_stored_rules(Constraints,Rules) :-
9676 ( chr_pp_flag(declare_stored_constraints,on) ->
9677 never_stored_rules(Constraints,Rules)
9678 ;
9679 Rules = []
9680 ).
9682 :- chr_constraint never_stored_rules/2.
9683 :- chr_option(mode,never_stored_rules(+,?)).
9684 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9686 never_stored_rules([],Rules) <=> Rules = [].
9687 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9688 Constraint = F/A,
9689 functor(Head,F,A),
9690 inc_rule_count(RuleNb),
9691 Rule = pragma(
9692 rule([Head],[],true,Goal),
9693 ids([0],[]),
9694 [],
9695 no,
9696 RuleNb
9697 ),
9698 Rules = [Rule|Tail],
9699 never_stored_rules(Constraints,Tail).
9700 never_stored_rules([_|Constraints],Rules) <=>
9701 never_stored_rules(Constraints,Rules).
9703 % Checking
9704 % ~~~~~~~~
9706 check_storedness_assertions(Constraints) :-
9707 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9708 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9709 ;
9710 true
9711 ).
9714 :- chr_constraint check_storedness_assertion/1.
9715 :- chr_option(mode,check_storedness_assertion(+)).
9716 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9718 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9719 <=> ( is_stored(Constraint) ->
9720 true
9721 ;
9722 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9723 ).
9724 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9725 <=> ( is_finally_stored(Constraint) ->
9726 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9727 ; is_stored(Constraint) ->
9728 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9729 ;
9730 true
9731 ).
9732 % never-stored, no default goal
9733 check_storedness_assertion(Constraint)
9734 <=> ( is_finally_stored(Constraint) ->
9735 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9736 ; is_stored(Constraint) ->
9737 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9738 ;
9739 true
9740 ).
9742 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9743 % success continuation analysis
9745 % TODO
9746 % take passive occurrences into account for correctness!
9747 % also use for forward jumping improvement!
9749 success_continuation_analysis([]).
9750 success_continuation_analysis([C|Cs]) :-
9751 success_continuation_analysis(C,1),
9752 get_max_occurrence(C,MO),
9753 LO is MO + 1,
9754 bulk_propagation(C,1,LO),
9755 success_continuation_analysis(Cs).
9757 success_continuation_analysis(C,O) :-
9758 get_max_occurrence(C,MO),
9759 ( O >= MO ->
9760 true
9761 ;
9762 constraint_success_continuation(C,O,MO,NextO),
9763 success_continuation_occurrence(C,O,NextO),
9764 NO is O + 1,
9765 success_continuation_analysis(C,NO)
9766 ).
9768 constraint_success_continuation(C,O,MO,NextO) :-
9769 get_occurrence_head(C,O,Head),
9770 NO is O + 1,
9771 ( between(NO,MO,NextO),
9772 get_occurrence_head(C,NextO,NextHead),
9773 unifiable(Head,NextHead,_) ->
9774 true
9775 ;
9776 NextO is MO + 1
9777 ).
9779 get_occurrence_head(C,O,Head) :-
9780 get_occurrence(C,O,RuleNb,Id),
9781 get_rule(RuleNb,Rule),
9782 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
9783 ( select2(Id,Head,Ids1,H1,_,_) -> true
9784 ; select2(Id,Head,Ids2,H2,_,_)
9785 ).
9787 :- chr_constraint success_continuation_occurrence/3.
9788 :- chr_option(mode,success_continuation_occurrence(+,+,+)).
9790 :- chr_constraint bulk_propagation/3.
9791 :- chr_option(mode,bulk_propagation(+,+,+)).
9793 :- chr_constraint skip_to_next_id/2.
9794 :- chr_option(mode,skip_to_next_id(+,+)).
9796 :- chr_constraint should_skip_to_next_id/2.
9797 :- chr_option(mode,should_skip_to_next_id(+,+)).
9799 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
9800 <=>
9801 true.
9803 should_skip_to_next_id(_,_)
9804 <=>
9805 fail.
9807 % don't go beyond the last occurrence
9808 % we have to go to next id for storage here
9809 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
9810 <=>
9811 O >= MO
9812 |
9813 skip_to_next_id(C,O).
9814 % we have to go to the next id here because
9815 % a predecessor needs it
9816 bulk_propagation(C,O,LO)
9817 <=>
9818 LO =:= O + 1
9819 |
9820 skip_to_next_id(C,O),
9821 get_max_occurrence(C,MO),
9822 NLO is MO + 1,
9823 bulk_propagation(C,LO,NLO).
9824 % we have to go to the next id here because
9825 % we're running into a simplification rule
9826 % IMPROVE: propagate back to propagation predecessor (IF ANY)
9827 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
9828 <=>
9829 NO is O + 1
9830 |
9831 skip_to_next_id(C,O),
9832 get_max_occurrence(C,MO),
9833 NLO is MO + 1,
9834 bulk_propagation(C,NO,NLO).
9835 % we skip the next id here
9836 % and go to the next occurrence
9837 success_continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
9838 <=>
9839 NextO > O + 1
9840 |
9841 NLO is min(LO,NextO),
9842 NO is O + 1,
9843 bulk_propagation(C,NO,NLO).
9844 % default case
9845 % err on the safe side
9846 bulk_propagation(C,O,LO)
9847 <=>
9848 skip_to_next_id(C,O),
9849 get_max_occurrence(C,MO),
9850 NLO is MO + 1,
9851 NO is O + 1,
9852 bulk_propagation(C,NO,NLO).
9854 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
9856 % if this occurrence is passive, but has to skip,
9857 % then the previous one must skip instead...
9858 % IMPROVE reasoning is conservative
9859 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
9860 ==>
9861 O > 1
9862 |
9863 PO is O - 1,
9864 skip_to_next_id(C,PO).