| blob | 0c4a0fe4f69e57548c6e1dad659144b114463915 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% OPEN BUGS
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * success continuation optimization
64 %% * analyze history usage to determine whether/when
65 %% cheaper suspension is possible:
66 %% don't use history when all partners are passive and self never triggers
67 %% * store constraint unconditionally for unconditional propagation rule,
68 %% if first, i.e. without checking history and set trigger cont to next occ
69 %% * get rid of suspension passing for never triggered constraints,
70 %% up to allocation occurrence
71 %% * get rid of call indirection for never triggered constraints
72 %% up to first allocation occurrence.
73 %% * get rid of unnecessary indirection if last active occurrence
74 %% before unconditional removal is head2, e.g.
75 %% a \ b <=> true.
76 %% a <=> true.
77 %% * Eliminate last clause of never stored constraint, if its body
78 %% is fail, e.g.
79 %% a ...
80 %% a <=> fail.
81 %% * Specialize lookup operations and indexes for functional dependencies.
82 %%
83 %% MORE TODO
84 %%
85 %% * generate code to empty all constraint stores of a module (Bart Demoen)
86 %% * map A \ B <=> true | true rules
87 %% onto efficient code that empties the constraint stores of B
88 %% in O(1) time for ground constraints where A and B do not share
89 %% any variables
90 %% * ground matching seems to be not optimized for compound terms
91 %% in case of simpagation_head2 and propagation occurrences
92 %% * analysis for storage delaying (see primes for case)
93 %% * internal constraints declaration + analyses?
94 %% * Do not store in global variable store if not necessary
95 %% NOTE: affects show_store/1
96 %% * var_assoc multi-level store: variable - ground
97 %% * Do not maintain/check unnecessary propagation history
98 %% for reasons of anti-monotony
99 %% * Strengthen storage analysis for propagation rules
100 %% reason about bodies of rules only containing constraints
101 %% -> fixpoint with observation analysis
102 %% * instantiation declarations
103 %% COMPOUND (bound to nonvar)
104 %% avoid nonvar tests
105 %%
106 %% * make difference between cheap guards for reordering
107 %% and non-binding guards for lock removal
108 %% * fd -> once/[] transformation for propagation
109 %% * cheap guards interleaved with head retrieval + faster
110 %% via-retrieval + non-empty checking for propagation rules
111 %% redo for simpagation_head2 prelude
112 %% * intelligent backtracking for simplification/simpagation rule
113 %% generator_1(X),'_$savecp'(CP_1),
114 %% ...
115 %% if( (
116 %% generator_n(Y),
117 %% test(X,Y)
118 %% ),
119 %% true,
120 %% ('_$cutto'(CP_1), fail)
121 %% ),
122 %% ...
123 %%
124 %% or recently developped cascading-supported approach
125 %% * intelligent backtracking for propagation rule
126 %% use additional boolean argument for each possible smart backtracking
127 %% when boolean at end of list true -> no smart backtracking
128 %% false -> smart backtracking
129 %% only works for rules with at least 3 constraints in the head
130 %% * (set semantics + functional dependency) declaration + resolution
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %% merged
133 %%
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
137 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
138 ]).
139 %% SWI begin
140 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
141 :- use_module(library(ordsets)).
142 %% SWI end
144 :- use_module(hprolog).
145 :- use_module(pairlist).
146 :- use_module(a_star).
147 :- use_module(listmap).
148 :- use_module(clean_code).
149 :- use_module(builtins).
150 :- use_module(find).
151 :- use_module(binomialheap).
152 :- use_module(guard_entailment).
153 :- use_module(chr_compiler_options).
154 :- use_module(chr_compiler_utility).
155 :- use_module(chr_compiler_errors).
156 :- include(chr_op).
157 :- op(1150, fx, chr_type).
158 :- op(1130, xfx, --->).
159 :- op(980, fx, (+)).
160 :- op(980, fx, (-)).
161 :- op(980, fx, (?)).
162 :- op(1150, fx, constraints).
163 :- op(1150, fx, chr_constraint).
165 :- chr_option(debug,off).
166 :- chr_option(optimize,full).
167 :- chr_option(check_guard_bindings,off).
169 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
171 :- chr_type list(T) ---> [] ; [T|list(T)].
172 :- chr_type list == list(any).
174 :- chr_type maybe(T) ---> yes(T) ; no.
176 :- chr_type constraint ---> any / any.
178 :- chr_type module_name == any.
180 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
181 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
182 :- chr_type idspair ---> ids(list(id),list(id)).
184 :- chr_type pragma_type ---> passive(id)
185 ; mpassive(list(id))
186 ; already_in_heads
187 ; already_in_heads(id)
188 ; no_history
189 ; history(history_name,list(id)).
190 :- chr_type history_name== any.
192 :- chr_type rule_name == any.
193 :- chr_type rule_nb == natural.
194 :- chr_type id == natural.
196 :- chr_type goal == any.
198 :- chr_type store_type ---> default
199 ; multi_store(list(store_type))
200 ; multi_hash(list(list(int)))
201 ; multi_inthash(list(list(int)))
202 ; global_singleton
203 ; global_ground
204 % EXPERIMENTAL STORES
205 ; atomic_constants(list(int),list(any))
206 ; ground_constants(list(int),list(any))
207 ; var_assoc_store(int,list(int))
208 ; identifier_store(int)
209 ; type_indexed_identifier_store(int,any).
211 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
213 %------------------------------------------------------------------------------%
214 :- chr_constraint chr_source_file/1.
215 :- chr_option(mode,chr_source_file(+)).
216 :- chr_option(type_declaration,chr_source_file(module_name)).
217 %------------------------------------------------------------------------------%
218 chr_source_file(_) \ chr_source_file(_) <=> true.
220 %------------------------------------------------------------------------------%
221 :- chr_constraint get_chr_source_file/1.
222 :- chr_option(mode,get_chr_source_file(-)).
223 :- chr_option(type_declaration,get_chr_source_file(module_name)).
224 %------------------------------------------------------------------------------%
225 chr_source_file(Mod) \ get_chr_source_file(Query)
226 <=> Query = Mod .
227 get_chr_source_file(Query)
228 <=> Query = user.
231 %------------------------------------------------------------------------------%
232 :- chr_constraint target_module/1.
233 :- chr_option(mode,target_module(+)).
234 :- chr_option(type_declaration,target_module(module_name)).
235 %------------------------------------------------------------------------------%
236 target_module(_) \ target_module(_) <=> true.
238 %------------------------------------------------------------------------------%
239 :- chr_constraint get_target_module/1.
240 :- chr_option(mode,get_target_module(-)).
241 :- chr_option(type_declaration,get_target_module(module_name)).
242 %------------------------------------------------------------------------------%
243 target_module(Mod) \ get_target_module(Query)
244 <=> Query = Mod .
245 get_target_module(Query)
246 <=> Query = user.
248 %------------------------------------------------------------------------------%
249 :- chr_constraint line_number/2.
250 :- chr_option(mode,line_number(+,+)).
251 %------------------------------------------------------------------------------%
252 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
254 %------------------------------------------------------------------------------%
255 :- chr_constraint get_line_number/2.
256 :- chr_option(mode,get_line_number(+,-)).
257 %------------------------------------------------------------------------------%
258 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
259 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
261 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
262 :- chr_option(mode,indexed_argument(+,+)).
263 :- chr_option(type_declaration,indexed_argument(constraint,int)).
265 :- chr_constraint is_indexed_argument/2.
266 :- chr_option(mode,is_indexed_argument(+,+)).
267 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
269 :- chr_constraint constraint_mode/2.
270 :- chr_option(mode,constraint_mode(+,+)).
271 :- chr_option(type_declaration,constraint_mode(constraint,list)).
273 :- chr_constraint get_constraint_mode/2.
274 :- chr_option(mode,get_constraint_mode(+,-)).
275 :- chr_option(type_declaration,get_constraint_mode(constraint,list)).
277 :- chr_constraint may_trigger/1.
278 :- chr_option(mode,may_trigger(+)).
279 :- chr_option(type_declaration,may_trigger(constraint)).
281 :- chr_constraint only_ground_indexed_arguments/1.
282 :- chr_option(mode,only_ground_indexed_arguments(+)).
283 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
285 :- chr_constraint none_suspended_on_variables/0.
287 :- chr_constraint are_none_suspended_on_variables/0.
289 :- chr_constraint store_type/2.
290 :- chr_option(mode,store_type(+,+)).
291 :- chr_option(type_declaration,store_type(constraint,store_type)).
293 :- chr_constraint get_store_type/2.
294 :- chr_option(mode,get_store_type(+,?)).
295 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
297 :- chr_constraint update_store_type/2.
298 :- chr_option(mode,update_store_type(+,+)).
299 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
301 :- chr_constraint actual_store_types/2.
302 :- chr_option(mode,actual_store_types(+,+)).
303 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
305 :- chr_constraint assumed_store_type/2.
306 :- chr_option(mode,assumed_store_type(+,+)).
307 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
309 :- chr_constraint validate_store_type_assumption/1.
310 :- chr_option(mode,validate_store_type_assumption(+)).
311 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
313 :- chr_constraint rule_count/1.
314 :- chr_option(mode,rule_count(+)).
315 :- chr_option(type_declaration,rule_count(natural)).
317 :- chr_constraint inc_rule_count/1.
318 :- chr_option(mode,inc_rule_count(-)).
319 :- chr_option(type_declaration,inc_rule_count(natural)).
321 rule_count(_) \ rule_count(_)
322 <=> true.
323 rule_count(C), inc_rule_count(NC)
324 <=> NC is C + 1, rule_count(NC).
325 inc_rule_count(NC)
326 <=> NC = 1, rule_count(NC).
328 :- chr_constraint passive/2.
329 :- chr_option(mode,passive(+,+)).
331 :- chr_constraint is_passive/2.
332 :- chr_option(mode,is_passive(+,+)).
334 :- chr_constraint any_passive_head/1.
335 :- chr_option(mode,any_passive_head(+)).
337 :- chr_constraint new_occurrence/4.
338 :- chr_option(mode,new_occurrence(+,+,+,+)).
340 :- chr_constraint occurrence/5.
341 :- chr_option(mode,occurrence(+,+,+,+,+)).
342 :- chr_type occurrence_type ---> simplification ; propagation.
343 :- chr_option(type_declaration,occurrence(any,any,any,any,occurrence_type)).
345 :- chr_constraint get_occurrence/4.
346 :- chr_option(mode,get_occurrence(+,+,-,-)).
348 :- chr_constraint get_occurrence_from_id/4.
349 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
351 :- chr_constraint max_occurrence/2.
352 :- chr_option(mode,max_occurrence(+,+)).
354 :- chr_constraint get_max_occurrence/2.
355 :- chr_option(mode,get_max_occurrence(+,-)).
357 :- chr_constraint allocation_occurrence/2.
358 :- chr_option(mode,allocation_occurrence(+,+)).
360 :- chr_constraint get_allocation_occurrence/2.
361 :- chr_option(mode,get_allocation_occurrence(+,-)).
363 :- chr_constraint rule/2.
364 :- chr_option(mode,rule(+,+)).
365 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
367 :- chr_constraint get_rule/2.
368 :- chr_option(mode,get_rule(+,-)).
369 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
371 :- chr_constraint least_occurrence/2.
372 :- chr_option(mode,least_occurrence(+,+)).
373 :- chr_option(type_declaration,least_occurrence(any,list)).
375 :- chr_constraint is_least_occurrence/1.
376 :- chr_option(mode,is_least_occurrence(+)).
379 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
380 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
381 is_indexed_argument(_,_) <=> fail.
383 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
385 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
386 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
387 Q = Mode.
388 get_constraint_mode(FA,Q) <=>
389 FA = _ / N,
390 replicate(N,(?),Q).
392 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
394 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
395 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
396 nth1(I,Mode,M),
397 M \== (+) |
398 is_stored(FA).
399 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
401 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
402 <=>
403 nth1(I,Mode,M),
404 M \== (+)
405 |
406 fail.
407 only_ground_indexed_arguments(_) <=>
408 true.
410 none_suspended_on_variables \ none_suspended_on_variables <=> true.
411 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
412 are_none_suspended_on_variables <=> fail.
413 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
415 store_type(FA,Store) \ get_store_type(FA,Query)
416 <=> Query = Store.
418 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
419 <=> Query = Store.
420 get_store_type(_,Query)
421 <=> Query = default.
423 actual_store_types(C,STs) \ update_store_type(C,ST)
424 <=> member(ST,STs) | true.
425 update_store_type(C,ST), actual_store_types(C,STs)
426 <=>
427 actual_store_types(C,[ST|STs]).
428 update_store_type(C,ST)
429 <=>
430 actual_store_types(C,[ST]).
432 % refine store type assumption
433 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
434 <=>
435 delete(STs,multi_hash([Index]),STs0),
436 /* writeln(actual_store_types(C,[atomic_constants(Index,Keys)|STs0])), */
437 actual_store_types(C,[atomic_constants(Index,Keys)|STs0]).
438 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Keys)
439 <=>
440 delete(STs,multi_hash([Index]),STs0),
441 /* writeln(actual_store_types(C,[ground_constants(Index,Keys)|STs0])), */
442 actual_store_types(C,[ground_constants(Index,Keys)|STs0]).
443 validate_store_type_assumption(C) \ actual_store_types(C,STs)
444 <=>
445 memberchk(multi_hash([[Index]]),STs),
446 get_constraint_type(C,Types),
447 nth1(Index,Types,Type),
448 enumerated_atomic_type(Type,Atoms)
449 |
450 delete(STs,multi_hash([[Index]]),STs0),
451 writeln(actual_store_types(C,[atomic_constants([Index],Atoms)|STs0])),
452 actual_store_types(C,[atomic_constants([Index],Atoms)|STs0]).
453 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
454 <=>
455 ( STs = [ground_constants(_,_)] ->
456 store_type(C,multi_store([global_ground|STs]))
457 ;
458 store_type(C,multi_store(STs))
459 ).
460 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
461 <=>
462 store_type(C,multi_store(STs)).
463 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
464 <=>
465 chr_pp_flag(debugable,on)
466 |
467 store_type(C,default).
468 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
469 <=> store_type(C,global_ground).
470 validate_store_type_assumption(C)
471 <=> true.
473 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
474 passive(R,ID) \ passive(R,ID) <=> true.
476 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
477 is_passive(_,_) <=> fail.
479 passive(RuleNb,_) \ any_passive_head(RuleNb)
480 <=> true.
481 any_passive_head(_)
482 <=> fail.
483 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
485 max_occurrence(C,N) \ max_occurrence(C,M)
486 <=> N >= M | true.
488 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
489 NO is MO + 1,
490 occurrence(C,NO,RuleNb,ID,Type),
491 max_occurrence(C,NO).
492 new_occurrence(C,RuleNb,ID,_) <=>
493 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
495 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
496 <=> Q = MON.
497 get_max_occurrence(C,Q)
498 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
500 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
501 <=> Rule = QRule, ID = QID.
502 get_occurrence(C,O,_,_)
503 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
505 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
506 <=> QC = C, QON = ON.
507 get_occurrence_from_id(C,O,_,_)
508 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
511 % Late allocation
513 late_allocation_analysis(Cs) :-
514 ( chr_pp_flag(late_allocation,on) ->
515 maplist(late_allocation, Cs)
516 ;
517 true
518 ).
520 late_allocation(C) :- late_allocation(C,0).
521 late_allocation(C,O) :- allocation_occurrence(C,O), !.
522 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
524 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
526 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
528 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
529 \+ is_passive(RuleNb,Id),
530 Type == propagation,
531 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
532 true
533 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
534 is_observed(C,O)
535 ; is_least_occurrence(RuleNb) -> % propagation rule
536 is_observed(C,O)
537 ;
538 true
539 ).
541 stored_in_guard_before_next_kept_occurrence(C,O) :-
542 chr_pp_flag(store_in_guards, on),
543 NO is O + 1,
544 stored_in_guard_lookahead(C,NO).
546 :- chr_constraint stored_in_guard_lookahead/2.
547 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
549 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
550 NO is O + 1, stored_in_guard_lookahead(C,NO).
551 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
552 Type == simplification,
553 ( is_stored_in_guard(C,RuleNb) ->
554 true
555 ;
556 NO is O + 1, stored_in_guard_lookahead(C,NO)
557 ).
558 stored_in_guard_lookahead(_,_) <=> fail.
561 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
562 \ least_occurrence(RuleNb,[ID|IDs])
563 <=> AO >= O, \+ may_trigger(C) |
564 least_occurrence(RuleNb,IDs).
565 rule(RuleNb,Rule), passive(RuleNb,ID)
566 \ least_occurrence(RuleNb,[ID|IDs])
567 <=> least_occurrence(RuleNb,IDs).
569 rule(RuleNb,Rule)
570 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
571 least_occurrence(RuleNb,IDs).
573 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
574 <=> true.
575 is_least_occurrence(_)
576 <=> fail.
578 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
579 <=> Q = O.
580 get_allocation_occurrence(_,Q)
581 <=> chr_pp_flag(late_allocation,off), Q=0.
582 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
584 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
585 <=> Q = Rule.
586 get_rule(_,_)
587 <=> fail.
589 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
591 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
592 %
593 % Default store constraint index assignment.
595 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
596 :- chr_option(mode,constraint_index(+,+)).
597 :- chr_option(type_declaration,constraint_index(constraint,int)).
599 :- chr_constraint get_constraint_index/2.
600 :- chr_option(mode,get_constraint_index(+,-)).
601 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
603 :- chr_constraint get_indexed_constraint/2.
604 :- chr_option(mode,get_indexed_constraint(+,-)).
605 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
607 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
608 :- chr_option(mode,max_constraint_index(+)).
609 :- chr_option(type_declaration,max_constraint_index(int)).
611 :- chr_constraint get_max_constraint_index/1.
612 :- chr_option(mode,get_max_constraint_index(-)).
613 :- chr_option(type_declaration,get_max_constraint_index(int)).
615 constraint_index(C,Index) \ get_constraint_index(C,Query)
616 <=> Query = Index.
617 get_constraint_index(C,Query)
618 <=> fail.
620 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
621 <=> Q = C.
622 get_indexed_constraint(Index,Q)
623 <=> fail.
625 max_constraint_index(Index) \ get_max_constraint_index(Query)
626 <=> Query = Index.
627 get_max_constraint_index(Query)
628 <=> Query = 0.
630 set_constraint_indices(Constraints) :-
631 set_constraint_indices(Constraints,1).
632 set_constraint_indices([],M) :-
633 N is M - 1,
634 max_constraint_index(N).
635 set_constraint_indices([C|Cs],N) :-
636 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
637 ; get_store_type(C,var_assoc_store(_,_))) ->
638 constraint_index(C,N),
639 M is N + 1,
640 set_constraint_indices(Cs,M)
641 ;
642 set_constraint_indices(Cs,N)
643 ).
645 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
646 % Identifier Indexes
648 :- chr_constraint identifier_size/1.
649 :- chr_option(mode,identifier_size(+)).
650 :- chr_option(type_declaration,identifier_size(natural)).
652 identifier_size(_) \ identifier_size(_)
653 <=>
654 true.
656 :- chr_constraint get_identifier_size/1.
657 :- chr_option(mode,get_identifier_size(-)).
658 :- chr_option(type_declaration,get_identifier_size(natural)).
660 identifier_size(Size) \ get_identifier_size(Q)
661 <=>
662 Q = Size.
664 get_identifier_size(Q)
665 <=>
666 Q = 1.
668 :- chr_constraint identifier_index/3.
669 :- chr_option(mode,identifier_index(+,+,+)).
670 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
672 identifier_index(C,I,_) \ identifier_index(C,I,_)
673 <=>
674 true.
676 :- chr_constraint get_identifier_index/3.
677 :- chr_option(mode,get_identifier_index(+,+,-)).
678 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
680 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
681 <=>
682 Q = II.
683 identifier_size(Size), get_identifier_index(C,I,Q)
684 <=>
685 NSize is Size + 1,
686 identifier_index(C,I,NSize),
687 identifier_size(NSize),
688 Q = NSize.
689 get_identifier_index(C,I,Q)
690 <=>
691 identifier_index(C,I,2),
692 identifier_size(2),
693 Q = 2.
695 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
696 % Type Indexed Identifier Indexes
698 :- chr_constraint type_indexed_identifier_size/2.
699 :- chr_option(mode,type_indexed_identifier_size(+,+)).
700 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
702 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
703 <=>
704 true.
706 :- chr_constraint get_type_indexed_identifier_size/2.
707 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
708 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
710 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
711 <=>
712 Q = Size.
714 get_type_indexed_identifier_size(IndexType,Q)
715 <=>
716 Q = 1.
718 :- chr_constraint type_indexed_identifier_index/4.
719 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
720 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
722 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
723 <=>
724 true.
726 :- chr_constraint get_type_indexed_identifier_index/4.
727 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
728 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
730 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
731 <=>
732 Q = II.
733 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
734 <=>
735 NSize is Size + 1,
736 type_indexed_identifier_index(IndexType,C,I,NSize),
737 type_indexed_identifier_size(IndexType,NSize),
738 Q = NSize.
739 get_type_indexed_identifier_index(IndexType,C,I,Q)
740 <=>
741 type_indexed_identifier_index(IndexType,C,I,2),
742 type_indexed_identifier_size(IndexType,2),
743 Q = 2.
745 type_indexed_identifier_structure(IndexType,Structure) :-
746 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
747 get_type_indexed_identifier_size(IndexType,Arity),
748 functor(Structure,Functor,Arity).
749 type_indexed_identifier_name(IndexType,Prefix,Name) :-
750 ( atom(IndexType) ->
751 IndexTypeName = IndexType
752 ;
753 term_to_atom(IndexType,IndexTypeName)
754 ),
755 atom_concat_list([Prefix,'_',IndexTypeName],Name).
757 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
762 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
763 %%
764 %% Translation
766 chr_translate(Declarations,NewDeclarations) :-
767 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
769 chr_translate_line_info(Declarations,File,NewDeclarations) :-
770 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',[]),
771 init_chr_pp_flags,
772 chr_source_file(File),
773 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
774 chr_compiler_options:sanity_check,
775 check_declared_constraints(Constraints0),
776 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
777 add_constraints(Constraints),
778 add_rules(Rules1),
779 generate_never_stored_rules(Constraints,NewRules),
780 add_rules(NewRules),
781 append(Rules1,NewRules,Rules),
782 % start analysis
783 check_rules(Rules,Constraints),
784 time('type checking',chr_translate:static_type_check),
785 add_occurrences(Rules),
786 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
787 time('set semantics',chr_translate:set_semantics_rules(Rules)),
788 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
789 time('guard simplification',chr_translate:guard_simplification),
790 time('late storage',chr_translate:storage_analysis(Constraints)),
791 time('observation',chr_translate:observation_analysis(Constraints)),
792 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
793 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
794 partial_wake_analysis,
795 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
796 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
797 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
798 % end analysis
799 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
800 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
801 phase_end(validate_store_type_assumptions),
802 used_states_known,
803 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
804 insert_declarations(OtherClauses, Clauses0),
805 chr_module_declaration(CHRModuleDeclaration),
806 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
807 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
808 append([Clauses0,GeneratedClauses], NewDeclarations).
810 store_management_preds(Constraints,Clauses) :-
811 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
812 generate_attr_unify_hook(AttrUnifyHookClauses),
813 generate_attach_increment(AttachIncrementClauses),
814 generate_extra_clauses(Constraints,ExtraClauses),
815 generate_insert_delete_constraints(Constraints,DeleteClauses),
816 generate_attach_code(Constraints,StoreClauses),
817 generate_counter_code(CounterClauses),
818 generate_dynamic_type_check_clauses(TypeCheckClauses),
819 append([AttachAConstraintClauses
820 ,AttachIncrementClauses
821 ,AttrUnifyHookClauses
822 ,ExtraClauses
823 ,DeleteClauses
824 ,StoreClauses
825 ,CounterClauses
826 ,TypeCheckClauses
827 ]
828 ,Clauses).
831 insert_declarations(Clauses0, Clauses) :-
832 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
833 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
835 auxiliary_module(chr_hashtable_store).
836 auxiliary_module(chr_integertable_store).
837 auxiliary_module(chr_assoc_store).
839 generate_counter_code(Clauses) :-
840 ( chr_pp_flag(store_counter,on) ->
841 Clauses = [
842 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
843 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
844 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
845 (:- '$counter_init'('$insert_counter')),
846 (:- '$counter_init'('$delete_counter')),
847 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
848 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
849 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
850 ]
851 ;
852 Clauses = []
853 ).
855 % for systems with multifile declaration
856 chr_module_declaration(CHRModuleDeclaration) :-
857 get_target_module(Mod),
858 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
859 CHRModuleDeclaration = [
860 (:- multifile chr:'$chr_module'/1),
861 chr:'$chr_module'(Mod)
862 ]
863 ;
864 CHRModuleDeclaration = []
865 ).
868 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
869 %%
870 %% Partitioning of clauses into constraint declarations, chr rules and other
871 %% clauses
873 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
874 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
875 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
876 partition_clauses([],[],[],[]).
877 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
878 ( parse_rule(Clause,Rule) ->
879 ConstraintDeclarations = RestConstraintDeclarations,
880 Rules = [Rule|RestRules],
881 OtherClauses = RestOtherClauses
882 ; is_declaration(Clause,ConstraintDeclaration) ->
883 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
884 Rules = RestRules,
885 OtherClauses = RestOtherClauses
886 ; is_module_declaration(Clause,Mod) ->
887 target_module(Mod),
888 ConstraintDeclarations = RestConstraintDeclarations,
889 Rules = RestRules,
890 OtherClauses = [Clause|RestOtherClauses]
891 ; is_type_definition(Clause) ->
892 ConstraintDeclarations = RestConstraintDeclarations,
893 Rules = RestRules,
894 OtherClauses = RestOtherClauses
895 ; Clause = (handler _) ->
896 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
897 ConstraintDeclarations = RestConstraintDeclarations,
898 Rules = RestRules,
899 OtherClauses = RestOtherClauses
900 ; Clause = (rules _) ->
901 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
902 ConstraintDeclarations = RestConstraintDeclarations,
903 Rules = RestRules,
904 OtherClauses = RestOtherClauses
905 ; Clause = option(OptionName,OptionValue) ->
906 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
907 handle_option(OptionName,OptionValue),
908 ConstraintDeclarations = RestConstraintDeclarations,
909 Rules = RestRules,
910 OtherClauses = RestOtherClauses
911 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
912 handle_option(OptionName,OptionValue),
913 ConstraintDeclarations = RestConstraintDeclarations,
914 Rules = RestRules,
915 OtherClauses = RestOtherClauses
916 ; Clause = ('$chr_compiled_with_version'(_)) ->
917 ConstraintDeclarations = RestConstraintDeclarations,
918 Rules = RestRules,
919 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
920 ; ConstraintDeclarations = RestConstraintDeclarations,
921 Rules = RestRules,
922 OtherClauses = [Clause|RestOtherClauses]
923 ),
924 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
926 '$chr_compiled_with_version'(2).
928 is_declaration(D, Constraints) :- %% constraint declaration
929 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
930 conj2list(Cs,Constraints0)
931 ;
932 ( D = (:- Decl) ->
933 Decl =.. [constraints,Cs]
934 ;
935 D =.. [constraints,Cs]
936 ),
937 conj2list(Cs,Constraints0),
938 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
939 ),
940 extract_type_mode(Constraints0,Constraints).
942 extract_type_mode([],[]).
943 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
944 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
945 ( C0 = C # Annotation ->
946 functor(C,F,A),
947 extract_annotation(Annotation,F/A)
948 ;
949 C0 = C,
950 functor(C,F,A)
951 ),
952 ConstraintSymbol = F/A,
953 C =.. [_|Args],
954 extract_types_and_modes(Args,ArgTypes,ArgModes),
955 constraint_type(ConstraintSymbol,ArgTypes),
956 constraint_mode(ConstraintSymbol,ArgModes),
957 extract_type_mode(R,R2).
959 extract_annotation(stored,Symbol) :-
960 stored_assertion(Symbol).
961 extract_annotation(default(Goal),Symbol) :-
962 never_stored_default(Symbol,Goal).
964 extract_types_and_modes([],[],[]).
965 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
966 extract_type_and_mode(X,T,M),
967 extract_types_and_modes(R,R2,R3).
969 extract_type_and_mode(+(T),T,(+)) :- !.
970 extract_type_and_mode(?(T),T,(?)) :- !.
971 extract_type_and_mode(-(T),T,(-)) :- !.
972 extract_type_and_mode((+),any,(+)) :- !.
973 extract_type_and_mode((?),any,(?)) :- !.
974 extract_type_and_mode((-),any,(-)) :- !.
975 extract_type_and_mode(Illegal,_,_) :-
976 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
978 is_type_definition(Declaration) :-
979 ( Declaration = (:- TDef) ->
980 true
981 ;
982 Declaration = TDef
983 ),
984 TDef =.. [chr_type,TypeDef],
985 ( TypeDef = (Name ---> Def) ->
986 tdisj2list(Def,DefList),
987 type_definition(Name,DefList)
988 ; TypeDef = (Alias == Name) ->
989 type_alias(Alias,Name)
990 ;
991 type_definition(TypeDef,[]),
992 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
993 ).
995 %% tdisj2list(+Goal,-ListOfGoals) is det.
996 %
997 % no removal of fails, e.g. :- type bool ---> true ; fail.
998 tdisj2list(Conj,L) :-
999 tdisj2list(Conj,L,[]).
1001 tdisj2list(Conj,L,T) :-
1002 Conj = (G1;G2), !,
1003 tdisj2list(G1,L,T1),
1004 tdisj2list(G2,T1,T).
1005 tdisj2list(G,[G | T],T).
1008 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1009 %% parse_rule(+term,-pragma_rule) is semidet.
1010 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1011 parse_rule(RI,R) :- %% name @ rule
1012 RI = (Name @ RI2), !,
1013 rule(RI2,yes(Name),R).
1014 parse_rule(RI,R) :-
1015 rule(RI,no,R).
1017 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1018 %% parse_rule(+term,-pragma_rule) is semidet.
1019 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1020 rule(RI,Name,R) :-
1021 RI = (RI2 pragma P), !, %% pragmas
1022 ( var(P) ->
1023 Ps = [_] % intercept variable
1024 ;
1025 conj2list(P,Ps)
1026 ),
1027 inc_rule_count(RuleCount),
1028 R = pragma(R1,IDs,Ps,Name,RuleCount),
1029 is_rule(RI2,R1,IDs,R).
1030 rule(RI,Name,R) :-
1031 inc_rule_count(RuleCount),
1032 R = pragma(R1,IDs,[],Name,RuleCount),
1033 is_rule(RI,R1,IDs,R).
1035 is_rule(RI,R,IDs,RC) :- %% propagation rule
1036 RI = (H ==> B), !,
1037 conj2list(H,Head2i),
1038 get_ids(Head2i,IDs2,Head2,RC),
1039 IDs = ids([],IDs2),
1040 ( B = (G | RB) ->
1041 R = rule([],Head2,G,RB)
1042 ;
1043 R = rule([],Head2,true,B)
1044 ).
1045 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1046 RI = (H <=> B), !,
1047 ( B = (G | RB) ->
1048 Guard = G,
1049 Body = RB
1050 ; Guard = true,
1051 Body = B
1052 ),
1053 ( H = (H1 \ H2) ->
1054 conj2list(H1,Head2i),
1055 conj2list(H2,Head1i),
1056 get_ids(Head2i,IDs2,Head2,0,N,RC),
1057 get_ids(Head1i,IDs1,Head1,N,_,RC),
1058 IDs = ids(IDs1,IDs2)
1059 ; conj2list(H,Head1i),
1060 Head2 = [],
1061 get_ids(Head1i,IDs1,Head1,RC),
1062 IDs = ids(IDs1,[])
1063 ),
1064 R = rule(Head1,Head2,Guard,Body).
1066 get_ids(Cs,IDs,NCs,RC) :-
1067 get_ids(Cs,IDs,NCs,0,_,RC).
1069 get_ids([],[],[],N,N,_).
1070 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1071 ( C = (NC # N1) ->
1072 ( var(N1) ->
1073 N1 = N
1074 ;
1075 check_direct_pragma(N1,N,RC)
1076 )
1077 ;
1078 NC = C
1079 ),
1080 M is N + 1,
1081 get_ids(Cs,IDs,NCs, M,NN,RC).
1083 check_direct_pragma(passive,Id,PragmaRule) :- !,
1084 PragmaRule = pragma(_,_,_,_,RuleNb),
1085 passive(RuleNb,Id).
1086 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1087 ( direct_pragma(FullPragma),
1088 atom_concat(Abbrev,Remainder,FullPragma) ->
1089 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1090 ;
1091 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1092 ).
1094 direct_pragma(passive).
1096 is_module_declaration((:- module(Mod)),Mod).
1097 is_module_declaration((:- module(Mod,_)),Mod).
1099 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1101 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1102 % Add constraints
1103 add_constraints([]).
1104 add_constraints([C|Cs]) :-
1105 max_occurrence(C,0),
1106 C = _/A,
1107 length(Mode,A),
1108 set_elems(Mode,?),
1109 constraint_mode(C,Mode),
1110 add_constraints(Cs).
1112 % Add rules
1113 add_rules([]).
1114 add_rules([Rule|Rules]) :-
1115 Rule = pragma(_,_,_,_,RuleNb),
1116 rule(RuleNb,Rule),
1117 add_rules(Rules).
1119 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1121 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1122 %% Some input verification:
1124 check_declared_constraints(Constraints) :-
1125 check_declared_constraints(Constraints,[]).
1127 check_declared_constraints([],_).
1128 check_declared_constraints([C|Cs],Acc) :-
1129 ( memberchk_eq(C,Acc) ->
1130 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1131 ;
1132 true
1133 ),
1134 check_declared_constraints(Cs,[C|Acc]).
1136 %% - all constraints in heads are declared constraints
1137 %% - all passive pragmas refer to actual head constraints
1139 check_rules([],_).
1140 check_rules([PragmaRule|Rest],Decls) :-
1141 check_rule(PragmaRule,Decls),
1142 check_rules(Rest,Decls).
1144 check_rule(PragmaRule,Decls) :-
1145 check_rule_indexing(PragmaRule),
1146 check_trivial_propagation_rule(PragmaRule),
1147 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1148 Rule = rule(H1,H2,_,_),
1149 append(H1,H2,HeadConstraints),
1150 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1151 check_pragmas(Pragmas,PragmaRule).
1153 % Make all heads passive in trivial propagation rule
1154 % ... ==> ... | true.
1155 check_trivial_propagation_rule(PragmaRule) :-
1156 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1157 ( Rule = rule([],_,_,true) ->
1158 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1159 set_all_passive(RuleNb)
1160 ;
1161 true
1162 ).
1164 check_head_constraints([],_,_).
1165 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1166 functor(Constr,F,A),
1167 ( member(F/A,Decls) ->
1168 check_head_constraints(Rest,Decls,PragmaRule)
1169 ;
1170 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1171 ).
1173 check_pragmas([],_).
1174 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1175 check_pragma(Pragma,PragmaRule),
1176 check_pragmas(Pragmas,PragmaRule).
1178 check_pragma(Pragma,PragmaRule) :-
1179 var(Pragma), !,
1180 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1181 check_pragma(passive(ID), PragmaRule) :-
1182 !,
1183 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1184 ( memberchk_eq(ID,IDs1) ->
1185 true
1186 ; memberchk_eq(ID,IDs2) ->
1187 true
1188 ;
1189 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1190 ),
1191 passive(RuleNb,ID).
1193 check_pragma(mpassive(IDs), PragmaRule) :-
1194 !,
1195 PragmaRule = pragma(_,_,_,_,RuleNb),
1196 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1197 maplist(passive(RuleNb),IDs).
1199 check_pragma(Pragma, PragmaRule) :-
1200 Pragma = already_in_heads,
1201 !,
1202 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1204 check_pragma(Pragma, PragmaRule) :-
1205 Pragma = already_in_head(_),
1206 !,
1207 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1209 check_pragma(Pragma, PragmaRule) :-
1210 Pragma = no_history,
1211 !,
1212 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1213 PragmaRule = pragma(_,_,_,_,N),
1214 no_history(N).
1216 check_pragma(Pragma, PragmaRule) :-
1217 Pragma = history(HistoryName,IDs),
1218 !,
1219 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1220 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1221 ( IDs1 \== [] ->
1222 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1223 ; \+ atom(HistoryName) ->
1224 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1225 ; \+ is_set(IDs) ->
1226 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1227 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1228 history(RuleNb,HistoryName,IDs)
1229 ;
1230 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1231 ).
1232 check_pragma(Pragma,PragmaRule) :-
1233 Pragma = line_number(LineNumber),
1234 !,
1235 PragmaRule = pragma(_,_,_,_,RuleNb),
1236 line_number(RuleNb,LineNumber).
1238 check_history_pragma_ids([], _, _).
1239 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1240 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1241 check_history_pragma_ids(IDs,IDs1,IDs2).
1243 check_pragma(Pragma,PragmaRule) :-
1244 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1246 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1247 %% no_history(+RuleNb) is det.
1248 :- chr_constraint no_history/1.
1249 :- chr_option(mode,no_history(+)).
1250 :- chr_option(type_declaration,no_history(int)).
1252 %% has_no_history(+RuleNb) is semidet.
1253 :- chr_constraint has_no_history/1.
1254 :- chr_option(mode,has_no_history(+)).
1255 :- chr_option(type_declaration,has_no_history(int)).
1257 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1258 has_no_history(_) <=> fail.
1260 :- chr_constraint history/3.
1261 :- chr_option(mode,history(+,+,+)).
1262 :- chr_option(type_declaration,history(any,any,list)).
1264 :- chr_constraint named_history/3.
1266 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1267 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1269 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1270 length(IDs1,L1), length(IDs2,L2),
1271 ( L1 \== L2 ->
1272 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1273 ;
1274 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1275 ).
1277 test_named_history_id_pairs(_, [], _, []).
1278 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1279 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1280 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1282 :- chr_constraint test_named_history_id_pair/4.
1283 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1285 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1286 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1287 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1288 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1290 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1291 named_history(_,_,_) <=> fail.
1293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1296 format_rule(PragmaRule) :-
1297 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1298 ( MaybeName = yes(Name) ->
1299 write('rule '), write(Name)
1300 ;
1301 write('rule number '), write(RuleNumber)
1302 ),
1303 get_line_number(RuleNumber,LineNumber),
1304 write(' (line '),
1305 write(LineNumber),
1306 write(')').
1308 check_rule_indexing(PragmaRule) :-
1309 PragmaRule = pragma(Rule,_,_,_,_),
1310 Rule = rule(H1,H2,G,_),
1311 term_variables(H1-H2,HeadVars),
1312 remove_anti_monotonic_guards(G,HeadVars,NG),
1313 check_indexing(H1,NG-H2),
1314 check_indexing(H2,NG-H1),
1315 % EXPERIMENT
1316 ( chr_pp_flag(term_indexing,on) ->
1317 term_variables(NG,GuardVariables),
1318 append(H1,H2,Heads),
1319 check_specs_indexing(Heads,GuardVariables,Specs)
1320 ;
1321 true
1322 ).
1324 :- chr_constraint indexing_spec/2.
1325 :- chr_option(mode,indexing_spec(+,+)).
1327 :- chr_constraint get_indexing_spec/2.
1328 :- chr_option(mode,get_indexing_spec(+,-)).
1331 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1332 get_indexing_spec(_,Spec) <=> Spec = [].
1334 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1335 <=>
1336 append(Specs1,Specs2,Specs),
1337 indexing_spec(FA,Specs).
1339 remove_anti_monotonic_guards(G,Vars,NG) :-
1340 conj2list(G,GL),
1341 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1342 list2conj(NGL,NG).
1344 remove_anti_monotonic_guard_list([],_,[]).
1345 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1346 ( G = var(X), memberchk_eq(X,Vars) ->
1347 NGs = RGs
1348 % TODO: this is not correct
1349 % ; G = functor(Term,Functor,Arity), % isotonic
1350 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1351 % NGs = RGs
1352 ;
1353 NGs = [G|RGs]
1354 ),
1355 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1357 check_indexing([],_).
1358 check_indexing([Head|Heads],Other) :-
1359 functor(Head,F,A),
1360 Head =.. [_|Args],
1361 term_variables(Heads-Other,OtherVars),
1362 check_indexing(Args,1,F/A,OtherVars),
1363 check_indexing(Heads,[Head|Other]).
1365 check_indexing([],_,_,_).
1366 check_indexing([Arg|Args],I,FA,OtherVars) :-
1367 ( is_indexed_argument(FA,I) ->
1368 true
1369 ; nonvar(Arg) ->
1370 indexed_argument(FA,I)
1371 ; % var(Arg) ->
1372 term_variables(Args,ArgsVars),
1373 append(ArgsVars,OtherVars,RestVars),
1374 ( memberchk_eq(Arg,RestVars) ->
1375 indexed_argument(FA,I)
1376 ;
1377 true
1378 )
1379 ),
1380 J is I + 1,
1381 term_variables(Arg,NVars),
1382 append(NVars,OtherVars,NOtherVars),
1383 check_indexing(Args,J,FA,NOtherVars).
1385 check_specs_indexing([],_,[]).
1386 check_specs_indexing([Head|Heads],Variables,Specs) :-
1387 Specs = [Spec|RSpecs],
1388 term_variables(Heads,OtherVariables,Variables),
1389 check_spec_indexing(Head,OtherVariables,Spec),
1390 term_variables(Head,NVariables,Variables),
1391 check_specs_indexing(Heads,NVariables,RSpecs).
1393 check_spec_indexing(Head,OtherVariables,Spec) :-
1394 functor(Head,F,A),
1395 Spec = spec(F,A,ArgSpecs),
1396 Head =.. [_|Args],
1397 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1398 indexing_spec(F/A,[ArgSpecs]).
1400 check_args_spec_indexing([],_,_,[]).
1401 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1402 term_variables(Args,Variables,OtherVariables),
1403 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1404 ArgSpecs = [ArgSpec|RArgSpecs]
1405 ;
1406 ArgSpecs = RArgSpecs
1407 ),
1408 J is I + 1,
1409 term_variables(Arg,NOtherVariables,OtherVariables),
1410 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1412 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1413 ( var(Arg) ->
1414 memberchk_eq(Arg,Variables),
1415 ArgSpec = specinfo(I,any,[])
1416 ;
1417 functor(Arg,F,A),
1418 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1419 Arg =.. [_|Args],
1420 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1421 ).
1423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1425 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1426 % Occurrences
1428 add_occurrences([]).
1429 add_occurrences([Rule|Rules]) :-
1430 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1431 add_occurrences(H1,IDs1,simplification,Nb),
1432 add_occurrences(H2,IDs2,propagation,Nb),
1433 add_occurrences(Rules).
1435 add_occurrences([],[],_,_).
1436 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1437 functor(H,F,A),
1438 FA = F/A,
1439 new_occurrence(FA,RuleNb,ID,Type),
1440 add_occurrences(Hs,IDs,Type,RuleNb).
1442 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1444 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1445 % Observation Analysis
1446 %
1447 % CLASSIFICATION
1448 %
1449 %
1450 %
1451 %
1452 %
1453 %
1455 :- chr_constraint observation_analysis/1.
1456 :- chr_option(mode, observation_analysis(+)).
1458 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1459 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1460 ( chr_pp_flag(store_in_guards, on) ->
1461 observation_analysis(RuleNb, Guard, guard, Cs)
1462 ;
1463 true
1464 ),
1465 observation_analysis(RuleNb, Body, body, Cs)
1467 pragma passive(Id).
1468 observation_analysis(_) <=> true.
1470 observation_analysis(RuleNb, Term, GB, Cs) :-
1471 ( all_spawned(RuleNb,GB) ->
1472 true
1473 ; var(Term) ->
1474 spawns_all(RuleNb,GB)
1475 ; Term = true ->
1476 true
1477 ; Term = fail ->
1478 true
1479 ; Term = '!' ->
1480 true
1481 ; Term = (T1,T2) ->
1482 observation_analysis(RuleNb,T1,GB,Cs),
1483 observation_analysis(RuleNb,T2,GB,Cs)
1484 ; Term = (T1;T2) ->
1485 observation_analysis(RuleNb,T1,GB,Cs),
1486 observation_analysis(RuleNb,T2,GB,Cs)
1487 ; Term = (T1->T2) ->
1488 observation_analysis(RuleNb,T1,GB,Cs),
1489 observation_analysis(RuleNb,T2,GB,Cs)
1490 ; Term = (\+ T) ->
1491 observation_analysis(RuleNb,T,GB,Cs)
1492 ; functor(Term,F,A), member(F/A,Cs) ->
1493 spawns(RuleNb,GB,F/A)
1494 ; Term = (_ = _) ->
1495 spawns_all_triggers(RuleNb,GB)
1496 ; Term = (_ is _) ->
1497 spawns_all_triggers(RuleNb,GB)
1498 ; builtin_binds_b(Term,Vars) ->
1499 ( Vars == [] ->
1500 true
1501 ;
1502 spawns_all_triggers(RuleNb,GB)
1503 )
1504 ;
1505 spawns_all(RuleNb,GB)
1506 ).
1508 :- chr_constraint spawns/3.
1509 :- chr_option(mode, spawns(+,+,+)).
1510 :- chr_type spawns_type ---> guard ; body.
1511 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1513 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1514 :- chr_option(mode, spawns_all(+,+)).
1515 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1516 :- chr_option(mode, spawns_all_triggers(+,+)).
1517 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1519 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1520 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1521 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1522 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1523 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1524 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1526 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1527 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1528 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1529 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1531 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1532 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1534 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1535 \
1536 spawns(RuleNb1,GB,C1)
1537 <=>
1538 \+ is_passive(RuleNb2,O)
1539 |
1540 spawns_all(RuleNb1,GB)
1541 pragma
1542 passive(Id).
1544 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1545 ==>
1546 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1547 \+ is_passive(RuleNb2,O), may_trigger(C1)
1548 |
1549 spawns_all_triggers_implies_spawns_all
1550 pragma
1551 passive(Id).
1553 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1554 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1555 spawns_all_triggers_implies_spawns_all \
1556 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1558 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1559 \
1560 spawns(RuleNb1,GB,C1)
1561 <=>
1562 may_trigger(C1),
1563 \+ is_passive(RuleNb2,O)
1564 |
1565 spawns_all_triggers(RuleNb1,GB)
1566 pragma
1567 passive(Id).
1569 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1570 spawns(RuleNb1,GB,C1)
1571 ==>
1572 \+ may_trigger(C1),
1573 \+ is_passive(RuleNb2,O)
1574 |
1575 spawns_all_triggers(RuleNb1,GB)
1576 pragma
1577 passive(Id).
1579 % a bit dangerous this rule: could start propagating too much too soon?
1580 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1581 spawns(RuleNb1,GB,C1)
1582 ==>
1583 RuleNb1 \== RuleNb2, C1 \== C2,
1584 \+ is_passive(RuleNb2,O)
1585 |
1586 spawns(RuleNb1,GB,C2)
1587 pragma
1588 passive(Id).
1590 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1591 spawns_all_triggers(RuleNb1,GB)
1592 ==>
1593 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1594 |
1595 spawns(RuleNb1,GB,C2)
1596 pragma
1597 passive(Id).
1600 :- chr_constraint all_spawned/2.
1601 :- chr_option(mode, all_spawned(+,+)).
1602 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1603 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1604 all_spawned(RuleNb,GB) <=> fail.
1607 % Overview of the supported queries:
1608 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1609 % only succeeds if the occurrence is observed by the
1610 % guard resp. body (depending on the last argument) of its rule
1611 % is_observed(+functor/artiy, +occurrence_number, -)
1612 % succeeds if the occurrence is observed by either the guard or
1613 % the body of its rule
1614 % NOTE: the last argument is NOT bound by this query
1615 %
1616 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1617 % succeeds if the given constraint is observed by the given
1618 % guard resp. body
1619 % do_is_observed(+functor/artiy,+rule_number)
1620 % succeeds if the given constraint is observed by the given
1621 % rule (either its guard or its body)
1624 is_observed(C,O) :-
1625 is_observed(C,O,_),
1626 ai_is_observed(C,O).
1628 is_stored_in_guard(C,RuleNb) :-
1629 chr_pp_flag(store_in_guards, on),
1630 do_is_observed(C,RuleNb,guard).
1632 :- chr_constraint is_observed/3.
1633 :- chr_option(mode, is_observed(+,+,+)).
1634 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1635 is_observed(_,_,_) <=> fail. % this will not happen in practice
1638 :- chr_constraint do_is_observed/3.
1639 :- chr_option(mode, do_is_observed(+,+,+)).
1640 :- chr_constraint do_is_observed/2.
1641 :- chr_option(mode, do_is_observed(+,+)).
1643 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1645 % (1) spawns_all
1646 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1647 % and some non-passive occurrence of some (possibly other) constraint
1648 % exists in a rule (could be same rule) with at least one occurrence of C
1650 spawns_all(RuleNb,GB),
1651 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1652 \
1653 do_is_observed(C,RuleNb,GB)
1654 <=>
1655 \+ is_passive(RuleNb2,O)
1656 |
1657 true.
1659 spawns_all(RuleNb,_),
1660 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1661 \
1662 do_is_observed(C,RuleNb)
1663 <=>
1664 \+ is_passive(RuleNb2,O)
1665 |
1666 true.
1668 % (2) spawns
1669 % a constraint C is observed if the GB of the rule it occurs in spawns a
1670 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1671 % as an occurrence of C
1673 spawns(RuleNb,GB,C2),
1674 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1675 \
1676 do_is_observed(C,RuleNb,GB)
1677 <=>
1678 \+ is_passive(RuleNb2,O)
1679 |
1680 true.
1682 spawns(RuleNb,_,C2),
1683 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1684 \
1685 do_is_observed(C,RuleNb)
1686 <=>
1687 \+ is_passive(RuleNb2,O)
1688 |
1689 true.
1691 % (3) spawns_all_triggers
1692 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1693 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1694 % exists in a rule (could be same rule) with at least one occurrence of C
1696 spawns_all_triggers(RuleNb,GB),
1697 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1698 \
1699 do_is_observed(C,RuleNb,GB)
1700 <=>
1701 \+ is_passive(RuleNb2,O), may_trigger(C2)
1702 |
1703 true.
1705 spawns_all_triggers(RuleNb,_),
1706 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1707 \
1708 do_is_observed(C,RuleNb)
1709 <=>
1710 \+ is_passive(RuleNb2,O), may_trigger(C2)
1711 |
1712 true.
1714 % (4) conservativeness
1715 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1716 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1719 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1721 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1723 %%
1724 %% Generated predicates
1725 %% attach_$CONSTRAINT
1726 %% attach_increment
1727 %% detach_$CONSTRAINT
1728 %% attr_unify_hook
1730 %% attach_$CONSTRAINT
1731 generate_attach_detach_a_constraint_all([],[]).
1732 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1733 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1734 generate_attach_a_constraint(Constraint,Clauses1),
1735 generate_detach_a_constraint(Constraint,Clauses2)
1736 ;
1737 Clauses1 = [],
1738 Clauses2 = []
1739 ),
1740 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1741 append([Clauses1,Clauses2,Clauses3],Clauses).
1743 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1744 generate_attach_a_constraint_nil(Constraint,Clause1),
1745 generate_attach_a_constraint_cons(Constraint,Clause2).
1747 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1748 make_name('attach_',FA,Name),
1749 Atom =.. [Name,Vars,Susp].
1751 generate_attach_a_constraint_nil(FA,Clause) :-
1752 Clause = (Head :- true),
1753 attach_constraint_atom(FA,[],_,Head).
1755 generate_attach_a_constraint_cons(FA,Clause) :-
1756 Clause = (Head :- Body),
1757 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1758 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1759 Body = ( AttachBody, Subscribe, RecursiveCall ),
1760 get_max_constraint_index(N),
1761 ( N == 1 ->
1762 generate_attach_body_1(FA,Var,Susp,AttachBody)
1763 ;
1764 generate_attach_body_n(FA,Var,Susp,AttachBody)
1765 ),
1766 % SWI-Prolog specific code
1767 chr_pp_flag(solver_events,NMod),
1768 ( NMod \== none ->
1769 Args = [[Var|_],Susp],
1770 get_target_module(Mod),
1771 use_auxiliary_predicate(run_suspensions),
1772 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1773 ;
1774 Subscribe = true
1775 ).
1777 generate_attach_body_1(FA,Var,Susp,Body) :-
1778 get_target_module(Mod),
1779 Body =
1780 ( get_attr(Var, Mod, Susps) ->
1781 put_attr(Var, Mod, [Susp|Susps])
1782 ;
1783 put_attr(Var, Mod, [Susp])
1784 ).
1786 generate_attach_body_n(F/A,Var,Susp,Body) :-
1787 get_constraint_index(F/A,Position),
1788 get_max_constraint_index(Total),
1789 get_target_module(Mod),
1790 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1791 singleton_attr(Total,Susp,Position,NewAttr3),
1792 Body =
1793 ( get_attr(Var,Mod,TAttr) ->
1794 AddGoal,
1795 put_attr(Var,Mod,NTAttr)
1796 ;
1797 put_attr(Var,Mod,NewAttr3)
1798 ), !.
1800 %% detach_$CONSTRAINT
1801 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1802 generate_detach_a_constraint_nil(Constraint,Clause1),
1803 generate_detach_a_constraint_cons(Constraint,Clause2).
1805 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1806 make_name('detach_',FA,Name),
1807 Atom =.. [Name,Vars,Susp].
1809 generate_detach_a_constraint_nil(FA,Clause) :-
1810 Clause = ( Head :- true),
1811 detach_constraint_atom(FA,[],_,Head).
1813 generate_detach_a_constraint_cons(FA,Clause) :-
1814 Clause = (Head :- Body),
1815 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1816 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1817 Body = ( DetachBody, RecursiveCall ),
1818 get_max_constraint_index(N),
1819 ( N == 1 ->
1820 generate_detach_body_1(FA,Var,Susp,DetachBody)
1821 ;
1822 generate_detach_body_n(FA,Var,Susp,DetachBody)
1823 ).
1825 generate_detach_body_1(FA,Var,Susp,Body) :-
1826 get_target_module(Mod),
1827 Body =
1828 ( get_attr(Var,Mod,Susps) ->
1829 'chr sbag_del_element'(Susps,Susp,NewSusps),
1830 ( NewSusps == [] ->
1831 del_attr(Var,Mod)
1832 ;
1833 put_attr(Var,Mod,NewSusps)
1834 )
1835 ;
1836 true
1837 ).
1839 generate_detach_body_n(F/A,Var,Susp,Body) :-
1840 get_constraint_index(F/A,Position),
1841 get_max_constraint_index(Total),
1842 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1843 get_target_module(Mod),
1844 Body =
1845 ( get_attr(Var,Mod,TAttr) ->
1846 RemGoal
1847 ;
1848 true
1849 ), !.
1851 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1852 %-------------------------------------------------------------------------------
1853 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1854 :- chr_constraint generate_indexed_variables_body/4.
1855 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1856 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1857 %-------------------------------------------------------------------------------
1858 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1859 get_indexing_spec(F/A,Specs),
1860 ( chr_pp_flag(term_indexing,on) ->
1861 spectermvars(Specs,Args,F,A,Body,Vars)
1862 ;
1863 get_constraint_type_det(F/A,ArgTypes),
1864 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1865 ( MaybeBody == empty ->
1866 Body = true,
1867 Vars = []
1868 ; N == 0 ->
1869 ( Args = [Term] ->
1870 true
1871 ;
1872 Term =.. [term|Args]
1873 ),
1874 Body = term_variables(Term,Vars)
1875 ;
1876 MaybeBody = Body
1877 )
1878 ).
1879 generate_indexed_variables_body(FA,_,_,_) <=>
1880 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1881 %===============================================================================
1883 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1884 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1885 J is I + 1,
1886 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1887 ( Mode == (?),
1888 is_indexed_argument(FA,I) ->
1889 ( atomic_type(Type) ->
1890 Body =
1891 (
1892 ( var(V) ->
1893 Vars = [V|Tail]
1894 ;
1895 Vars = Tail
1896 ),
1897 Continuation
1898 ),
1899 ( RBody == empty ->
1900 Continuation = true, Tail = []
1901 ;
1902 Continuation = RBody
1903 )
1904 ;
1905 ( RBody == empty ->
1906 Body = term_variables(V,Vars)
1907 ;
1908 Body = (term_variables(V,Vars,Tail),RBody)
1909 )
1910 ),
1911 N = M
1912 ; Mode == (-), is_indexed_argument(FA,I) ->
1913 ( RBody == empty ->
1914 Body = (Vars = [V])
1915 ;
1916 Body = (Vars = [V|Tail],RBody)
1917 ),
1918 N is M + 1
1919 ;
1920 Vars = Tail,
1921 Body = RBody,
1922 N is M + 1
1923 ).
1924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1925 % EXPERIMENTAL
1926 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1927 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1929 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1930 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1931 Goal = (ArgGoal,RGoal),
1932 argspecs(Specs,I,TempArgSpecs,RSpecs),
1933 merge_argspecs(TempArgSpecs,ArgSpecs),
1934 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1935 J is I + 1,
1936 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1938 argspecs([],_,[],[]).
1939 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1940 argspecs(Rest,I,ArgSpecs,RestSpecs).
1941 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1942 ( I == J ->
1943 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1944 ( Specs = [] ->
1945 RRestSpecs = RestSpecs
1946 ;
1947 RestSpecs = [Specs|RRestSpecs]
1948 )
1949 ;
1950 ArgSpecs = RArgSpecs,
1951 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1952 ),
1953 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1955 merge_argspecs(In,Out) :-
1956 sort(In,Sorted),
1957 merge_argspecs_(Sorted,Out).
1959 merge_argspecs_([],[]).
1960 merge_argspecs_([X],R) :- !, R = [X].
1961 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1962 ( (F1 == any ; F2 == any) ->
1963 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1964 ; F1 == F2 ->
1965 append(A1,A2,A),
1966 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1967 ;
1968 R = [specinfo(I,F1,A1)|RR],
1969 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1970 ).
1972 arggoal(List,Arg,Goal,L,T) :-
1973 ( List == [] ->
1974 L = T,
1975 Goal = true
1976 ; List = [specinfo(_,any,_)] ->
1977 Goal = term_variables(Arg,L,T)
1978 ;
1979 Goal =
1980 ( var(Arg) ->
1981 L = [Arg|T]
1982 ;
1983 Cases
1984 ),
1985 arggoal_cases(List,Arg,L,T,Cases)
1986 ).
1988 arggoal_cases([],_,L,T,L=T).
1989 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1990 ( ArgSpecs == [] ->
1991 Cases = RCases
1992 ; ArgSpecs == [[]] ->
1993 Cases = RCases
1994 ; FA = F/A ->
1995 Cases = (Case ; RCases),
1996 functor(Term,F,A),
1997 Term =.. [_|Args],
1998 Case = (Arg = Term -> ArgsGoal),
1999 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2000 ),
2001 arggoal_cases(Rest,Arg,L,T,RCases).
2002 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2004 generate_extra_clauses(Constraints,List) :-
2005 generate_activate_clauses(Constraints,List,Tail0),
2006 generate_remove_clauses(Constraints,Tail0,Tail1),
2007 generate_allocate_clauses(Constraints,Tail1,Tail2),
2008 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2009 generate_novel_production(Tail3,Tail4),
2010 generate_extend_history(Tail4,Tail5),
2011 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2012 generate_empty_named_history_initialisations(Tail6,Tail7),
2013 Tail7 = [].
2015 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2016 % remove_constraint_internal/[1/3]
2018 generate_remove_clauses([],List,List).
2019 generate_remove_clauses([C|Cs],List,Tail) :-
2020 generate_remove_clause(C,List,List1),
2021 generate_remove_clauses(Cs,List1,Tail).
2023 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2024 uses_state(Constraint,removed),
2025 ( chr_pp_flag(inline_insertremove,off) ->
2026 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2027 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2028 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2029 ;
2030 delay_phase_end(validate_store_type_assumptions,
2031 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2032 )
2033 ).
2035 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2036 make_name('$remove_constraint_internal_',Constraint,Name),
2037 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2038 Goal =.. [Name, Susp,Delete]
2039 ;
2040 Goal =.. [Name,Susp,Agenda,Delete]
2041 ).
2043 generate_remove_clause(Constraint,List,Tail) :-
2044 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2045 List = [RemoveClause|Tail],
2046 RemoveClause = (Head :- RemoveBody),
2047 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2048 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2049 ;
2050 List = Tail
2051 ).
2053 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2054 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2055 ( Role == active ->
2056 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2057 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2058 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2059 ; Role == partner ->
2060 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2061 GetStateValue = true,
2062 MaybeDelete = DeleteYes
2063 ),
2064 RemoveBody =
2065 (
2066 GetState,
2067 GetStateValue,
2068 UpdateState,
2069 MaybeDelete
2070 )
2071 ;
2072 static_suspension_term(Constraint,Susp2),
2073 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2074 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2075 ( chr_pp_flag(debugable,on) ->
2076 Constraint = Functor / _,
2077 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2078 ;
2079 true
2080 ),
2081 ( Role == active ->
2082 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2083 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2084 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2085 ; Role == partner ->
2086 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2087 GetStateValue = true,
2088 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2089 ),
2090 RemoveBody =
2091 (
2092 Susp = Susp2,
2093 GetStateValue,
2094 UpdateState,
2095 MaybeDelete
2096 )
2097 ).
2099 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2100 % activate_constraint/4
2102 generate_activate_clauses([],List,List).
2103 generate_activate_clauses([C|Cs],List,Tail) :-
2104 generate_activate_clause(C,List,List1),
2105 generate_activate_clauses(Cs,List1,Tail).
2107 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2108 ( chr_pp_flag(inline_insertremove,off) ->
2109 use_auxiliary_predicate(activate_constraint,Constraint),
2110 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2111 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2112 ;
2113 delay_phase_end(validate_store_type_assumptions,
2114 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2115 )
2116 ).
2118 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2119 make_name('$activate_constraint_',Constraint,Name),
2120 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2121 Goal =.. [Name,Store, Susp]
2122 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2123 Goal =.. [Name,Store, Susp, Generation]
2124 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2125 Goal =.. [Name,Store, Vars, Susp, Generation]
2126 ;
2127 Goal =.. [Name,Store, Vars, Susp]
2128 ).
2130 generate_activate_clause(Constraint,List,Tail) :-
2131 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2132 List = [Clause|Tail],
2133 Clause = (Head :- Body),
2134 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2135 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2136 ;
2137 List = Tail
2138 ).
2140 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2141 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2142 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2143 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2144 ;
2145 GenerationHandling = true
2146 ),
2147 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2148 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2149 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2150 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2151 ;
2152 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2153 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2154 ( chr_pp_flag(guard_locks,off) ->
2155 NoneLocked = true
2156 ;
2157 NoneLocked = 'chr none_locked'( Vars)
2158 ),
2159 if_used_state(Constraint,not_stored_yet,
2160 ( State == not_stored_yet ->
2161 ArgumentsGoal,
2162 IndexedVariablesBody,
2163 NoneLocked,
2164 StoreYes
2165 ;
2166 % Vars = [],
2167 StoreNo
2168 ),
2169 % (Vars = [],StoreNo),StoreVarsGoal)
2170 StoreNo,StoreVarsGoal)
2171 ),
2172 Body =
2173 (
2174 GetState,
2175 GetStateValue,
2176 UpdateState,
2177 GenerationHandling,
2178 StoreVarsGoal
2179 ).
2180 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2181 % allocate_constraint/4
2183 generate_allocate_clauses([],List,List).
2184 generate_allocate_clauses([C|Cs],List,Tail) :-
2185 generate_allocate_clause(C,List,List1),
2186 generate_allocate_clauses(Cs,List1,Tail).
2188 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2189 uses_state(Constraint,not_stored_yet),
2190 ( chr_pp_flag(inline_insertremove,off) ->
2191 use_auxiliary_predicate(allocate_constraint,Constraint),
2192 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2193 ;
2194 Goal = (Susp = Suspension, Goal0),
2195 delay_phase_end(validate_store_type_assumptions,
2196 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2197 )
2198 ).
2200 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2201 make_name('$allocate_constraint_',Constraint,Name),
2202 Goal =.. [Name,Susp|Args].
2204 generate_allocate_clause(Constraint,List,Tail) :-
2205 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2206 List = [Clause|Tail],
2207 Clause = (Head :- Body),
2208 Constraint = _/A,
2209 length(Args,A),
2210 allocate_constraint_atom(Constraint,Susp,Args,Head),
2211 allocate_constraint_body(Constraint,Susp,Args,Body)
2212 ;
2213 List = Tail
2214 ).
2216 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2217 static_suspension_term(Constraint,Suspension),
2218 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2219 ( chr_pp_flag(debugable,on) ->
2220 Constraint = Functor / _,
2221 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2222 ;
2223 true
2224 ),
2225 ( chr_pp_flag(debugable,on) ->
2226 ( may_trigger(Constraint) ->
2227 append(Args,[Susp],VarsSusp),
2228 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2229 get_target_module(Mod),
2230 Continuation = Mod : ContinuationGoal
2231 ;
2232 Continuation = true
2233 ),
2234 Init = (Susp = Suspension),
2235 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2236 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2237 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2238 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2239 Susp = Suspension, Init = true, CreateContinuation = true
2240 ;
2241 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2242 ),
2243 ( uses_history(Constraint) ->
2244 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2245 ;
2246 CreateHistory = true
2247 ),
2248 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2249 ( has_suspension_field(Constraint,id) ->
2250 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2251 GenID = 'chr gen_id'(Id)
2252 ;
2253 GenID = true
2254 ),
2255 Body =
2256 (
2257 Init,
2258 CreateContinuation,
2259 CreateGeneration,
2260 CreateHistory,
2261 CreateState,
2262 GenID
2263 ).
2265 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2266 % insert_constraint_internal
2268 generate_insert_constraint_internal_clauses([],List,List).
2269 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2270 generate_insert_constraint_internal_clause(C,List,List1),
2271 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2273 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2274 ( chr_pp_flag(inline_insertremove,off) ->
2275 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2276 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2277 ;
2278 delay_phase_end(validate_store_type_assumptions,
2279 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2280 )
2281 ).
2284 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2285 insert_constraint_internal_constraint_name(Constraint,Name),
2286 ( chr_pp_flag(debugable,on) ->
2287 Goal =.. [Name, Vars, Self, Closure | Args]
2288 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2289 Goal =.. [Name,Self | Args]
2290 ;
2291 Goal =.. [Name,Vars, Self | Args]
2292 ).
2294 insert_constraint_internal_constraint_name(Constraint,Name) :-
2295 make_name('$insert_constraint_internal_',Constraint,Name).
2297 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2298 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2299 List = [Clause|Tail],
2300 Clause = (Head :- Body),
2301 Constraint = _/A,
2302 length(Args,A),
2303 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2304 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2305 ;
2306 List = Tail
2307 ).
2310 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2311 static_suspension_term(Constraint,Suspension),
2312 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2313 ( chr_pp_flag(debugable,on) ->
2314 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2315 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2316 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2317 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2318 ;
2319 CreateGeneration = true
2320 ),
2321 ( chr_pp_flag(debugable,on) ->
2322 Constraint = Functor / _,
2323 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2324 ;
2325 true
2326 ),
2327 ( uses_history(Constraint) ->
2328 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2329 ;
2330 CreateHistory = true
2331 ),
2332 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2333 List = [Clause|Tail],
2334 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2335 suspension_term_base_fields(Constraint,BaseFields),
2336 ( has_suspension_field(Constraint,id) ->
2337 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2338 GenID = 'chr gen_id'(Id)
2339 ;
2340 GenID = true
2341 ),
2342 Body =
2343 (
2344 Susp = Suspension,
2345 CreateState,
2346 CreateGeneration,
2347 CreateHistory,
2348 GenID
2349 )
2350 ;
2351 ( has_suspension_field(Constraint,id) ->
2352 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2353 GenID = 'chr gen_id'(Id)
2354 ;
2355 GenID = true
2356 ),
2357 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2358 ( chr_pp_flag(guard_locks,off) ->
2359 NoneLocked = true
2360 ;
2361 NoneLocked = 'chr none_locked'( Vars)
2362 ),
2363 Body =
2364 (
2365 Susp = Suspension,
2366 IndexedVariablesBody,
2367 NoneLocked,
2368 CreateState,
2369 CreateGeneration,
2370 CreateHistory,
2371 GenID
2372 )
2373 ).
2375 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2376 % novel_production/2
2378 generate_novel_production(List,Tail) :-
2379 ( is_used_auxiliary_predicate(novel_production) ->
2380 List = [Clause|Tail],
2381 Clause =
2382 (
2383 '$novel_production'( Self, Tuple) :-
2384 % arg( 3, Self, Ref), % ARGXXX
2385 % 'chr get_mutable'( History, Ref),
2386 arg( 3, Self, History), % ARGXXX
2387 ( hprolog:get_ds( Tuple, History, _) ->
2388 fail
2389 ;
2390 true
2391 )
2392 )
2393 ;
2394 List = Tail
2395 ).
2397 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2398 % extend_history/2
2400 generate_extend_history(List,Tail) :-
2401 ( is_used_auxiliary_predicate(extend_history) ->
2402 List = [Clause|Tail],
2403 Clause =
2404 (
2405 '$extend_history'( Self, Tuple) :-
2406 % arg( 3, Self, Ref), % ARGXXX
2407 % 'chr get_mutable'( History, Ref),
2408 arg( 3, Self, History), % ARGXXX
2409 hprolog:put_ds( Tuple, History, x, NewHistory),
2410 setarg( 3, Self, NewHistory) % ARGXXX
2411 )
2412 ;
2413 List = Tail
2414 ).
2416 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2417 %
2418 :- chr_constraint
2419 empty_named_history_initialisations/2,
2420 generate_empty_named_history_initialisation/1,
2421 find_empty_named_histories/0.
2423 generate_empty_named_history_initialisations(List, Tail) :-
2424 empty_named_history_initialisations(List, Tail),
2425 find_empty_named_histories.
2427 find_empty_named_histories, history(_, Name, []) ==>
2428 generate_empty_named_history_initialisation(Name).
2430 generate_empty_named_history_initialisation(Name) \
2431 generate_empty_named_history_initialisation(Name) <=> true.
2432 generate_empty_named_history_initialisation(Name) \
2433 empty_named_history_initialisations(List, Tail) # Passive
2434 <=>
2435 empty_named_history_global_variable(Name, GlobalVariable),
2436 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2437 empty_named_history_initialisations(Rest, Tail)
2438 pragma passive(Passive).
2440 find_empty_named_histories \
2441 generate_empty_named_history_initialisation(_) # Passive <=> true
2442 pragma passive(Passive).
2444 find_empty_named_histories,
2445 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2446 pragma passive(Passive).
2448 find_empty_named_histories <=>
2449 chr_error(internal, 'find_empty_named_histories was not removed', []).
2452 empty_named_history_global_variable(Name, GlobalVariable) :-
2453 atom_concat('chr empty named history ', Name, GlobalVariable).
2455 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2456 empty_named_history_global_variable(Name, GlobalVariable).
2458 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2459 empty_named_history_global_variable(Name, GlobalVariable).
2462 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2463 % run_suspensions/2
2465 generate_run_suspensions_clauses([],List,List).
2466 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2467 generate_run_suspensions_clause(C,List,List1),
2468 generate_run_suspensions_clauses(Cs,List1,Tail).
2470 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2471 make_name('$run_suspensions_',Constraint,Name),
2472 Goal =.. [Name,Suspensions].
2474 generate_run_suspensions_clause(Constraint,List,Tail) :-
2475 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2476 List = [Clause1,Clause2|Tail],
2477 run_suspensions_goal(Constraint,[],Clause1),
2478 ( chr_pp_flag(debugable,on) ->
2479 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2480 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2481 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2482 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2483 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2484 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2485 Clause2 =
2486 (
2487 Clause2Head :-
2488 GetState,
2489 GetStateValue,
2490 ( State==active ->
2491 UpdateState,
2492 GetGeneration,
2493 GetGenerationValue,
2494 Generation is Gen+1,
2495 UpdateGeneration,
2496 GetContinuation,
2497 (
2498 'chr debug_event'(wake(Suspension)),
2499 call(Continuation)
2500 ;
2501 'chr debug_event'(fail(Suspension)), !,
2502 fail
2503 ),
2504 (
2505 'chr debug_event'(exit(Suspension))
2506 ;
2507 'chr debug_event'(redo(Suspension)),
2508 fail
2509 ),
2510 GetPost,
2511 GetPostValue,
2512 ( Post==triggered ->
2513 UpdatePost % catching constraints that did not do anything
2514 ;
2515 true
2516 )
2517 ;
2518 true
2519 ),
2520 Clause2Recursion
2521 )
2522 ;
2523 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2524 static_suspension_term(Constraint,SuspensionTerm),
2525 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2526 append(Arguments,[Suspension],VarsSusp),
2527 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2528 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2529 ( uses_field(Constraint,generation) ->
2530 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2531 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2532 ;
2533 GenerationHandling = true
2534 ),
2535 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2536 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2537 if_used_state(Constraint,removed,
2538 ( GetState,
2539 ( State==active
2540 -> ReactivateConstraint
2541 ; true)
2542 ),ReactivateConstraint,CondReactivate),
2543 ReactivateConstraint =
2544 (
2545 UpdateState,
2546 GenerationHandling,
2547 Continuation,
2548 GetPostState,
2549 ( Post==triggered ->
2550 UpdatePostState % catching constraints that did not do anything
2551 ;
2552 true
2553 )
2554 ),
2555 Clause2 =
2556 (
2557 Clause2Head :-
2558 Suspension = SuspensionTerm,
2559 CondReactivate,
2560 Clause2Recursion
2561 )
2562 )
2563 ;
2564 List = Tail
2565 ).
2567 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2569 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2570 generate_attach_increment(Clauses) :-
2571 get_max_constraint_index(N),
2572 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2573 Clauses = [Clause1,Clause2],
2574 generate_attach_increment_empty(Clause1),
2575 ( N == 1 ->
2576 generate_attach_increment_one(Clause2)
2577 ;
2578 generate_attach_increment_many(N,Clause2)
2579 )
2580 ;
2581 Clauses = []
2582 ).
2584 generate_attach_increment_empty((attach_increment([],_) :- true)).
2586 generate_attach_increment_one(Clause) :-
2587 Head = attach_increment([Var|Vars],Susps),
2588 get_target_module(Mod),
2589 ( chr_pp_flag(guard_locks,off) ->
2590 NotLocked = true
2591 ;
2592 NotLocked = 'chr not_locked'( Var)
2593 ),
2594 Body =
2595 (
2596 NotLocked,
2597 ( get_attr(Var,Mod,VarSusps) ->
2598 sort(VarSusps,SortedVarSusps),
2599 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2600 put_attr(Var,Mod,MergedSusps)
2601 ;
2602 put_attr(Var,Mod,Susps)
2603 ),
2604 attach_increment(Vars,Susps)
2605 ),
2606 Clause = (Head :- Body).
2608 generate_attach_increment_many(N,Clause) :-
2609 Head = attach_increment([Var|Vars],TAttr1),
2610 % writeln(merge_attributes_1_before),
2611 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2612 % writeln(merge_attributes_1_after),
2613 get_target_module(Mod),
2614 ( chr_pp_flag(guard_locks,off) ->
2615 NotLocked = true
2616 ;
2617 NotLocked = 'chr not_locked'( Var)
2618 ),
2619 Body =
2620 (
2621 NotLocked,
2622 ( get_attr(Var,Mod,TAttr2) ->
2623 MergeGoal,
2624 put_attr(Var,Mod,Attr)
2625 ;
2626 put_attr(Var,Mod,TAttr1)
2627 ),
2628 attach_increment(Vars,TAttr1)
2629 ),
2630 Clause = (Head :- Body).
2632 %% attr_unify_hook
2633 generate_attr_unify_hook(Clauses) :-
2634 get_max_constraint_index(N),
2635 ( N == 0 ->
2636 Clauses = []
2637 ;
2638 ( N == 1 ->
2639 generate_attr_unify_hook_one(Clauses)
2640 ;
2641 generate_attr_unify_hook_many(N,Clauses)
2642 )
2643 ).
2645 generate_attr_unify_hook_one([Clause]) :-
2646 Head = attr_unify_hook(Susps,Other),
2647 get_target_module(Mod),
2648 get_indexed_constraint(1,C),
2649 ( get_store_type(C,ST),
2650 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2651 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2652 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2653 ( atomic_types_suspended_constraint(C) ->
2654 SortGoal1 = true,
2655 SortedSusps = Susps,
2656 SortGoal2 = true,
2657 SortedOtherSusps = OtherSusps,
2658 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2659 NonvarBody = true
2660 ;
2661 SortGoal1 = sort(Susps, SortedSusps),
2662 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2663 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2664 use_auxiliary_predicate(attach_increment),
2665 NonvarBody =
2666 ( compound(Other) ->
2667 term_variables(Other,OtherVars),
2668 attach_increment(OtherVars, SortedSusps)
2669 ;
2670 true
2671 )
2672 ),
2673 Body =
2674 (
2675 SortGoal1,
2676 ( var(Other) ->
2677 ( get_attr(Other,Mod,OtherSusps) ->
2678 SortGoal2,
2679 MergeGoal,
2680 put_attr(Other,Mod,NewSusps),
2681 WakeNewSusps
2682 ;
2683 put_attr(Other,Mod,SortedSusps),
2684 WakeSusps
2685 )
2686 ;
2687 NonvarBody,
2688 WakeSusps
2689 )
2690 ),
2691 Clause = (Head :- Body)
2692 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2693 make_run_suspensions(List,List,WakeNewSusps),
2694 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2695 Body =
2696 ( get_attr(Other,Mod,OtherSusps) ->
2697 MergeGoal,
2698 WakeNewSusps
2699 ;
2700 put_attr(Other,Mod,Susps)
2701 ),
2702 Clause = (Head :- Body)
2703 ).
2706 generate_attr_unify_hook_many(N,[Clause]) :-
2707 chr_pp_flag(dynattr,off), !,
2708 Head = attr_unify_hook(Attr,Other),
2709 get_target_module(Mod),
2710 make_attr(N,Mask,SuspsList,Attr),
2711 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2712 list2conj(SortGoalList,SortGoals),
2713 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2714 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2715 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2716 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2717 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2718 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2719 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2720 NonvarBody = true
2721 ;
2722 use_auxiliary_predicate(attach_increment),
2723 NonvarBody =
2724 ( compound(Other) ->
2725 term_variables(Other,OtherVars),
2726 attach_increment(OtherVars,SortedAttr)
2727 ;
2728 true
2729 )
2730 ),
2731 Body =
2732 (
2733 SortGoals,
2734 ( var(Other) ->
2735 ( get_attr(Other,Mod,TOtherAttr) ->
2736 MergeGoal,
2737 put_attr(Other,Mod,MergedAttr),
2738 WakeMergedSusps
2739 ;
2740 put_attr(Other,Mod,SortedAttr),
2741 WakeSortedSusps
2742 )
2743 ;
2744 NonvarBody,
2745 WakeSortedSusps
2746 )
2747 ),
2748 Clause = (Head :- Body).
2750 % NEW
2751 generate_attr_unify_hook_many(N,Clauses) :-
2752 Head = attr_unify_hook(Attr,Other),
2753 get_target_module(Mod),
2754 normalize_attr(Attr,NormalGoal,NormalAttr),
2755 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2756 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2757 make_run_suspensions(N),
2758 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2759 NonvarBody = true
2760 ;
2761 use_auxiliary_predicate(attach_increment),
2762 NonvarBody =
2763 ( compound(Other) ->
2764 term_variables(Other,OtherVars),
2765 attach_increment(OtherVars,NormalAttr)
2766 ;
2767 true
2768 )
2769 ),
2770 Body =
2771 (
2772 NormalGoal,
2773 ( var(Other) ->
2774 ( get_attr(Other,Mod,OtherAttr) ->
2775 NormalOtherGoal,
2776 MergeGoal,
2777 put_attr(Other,Mod,MergedAttr),
2778 '$dispatch_run_suspensions'(MergedAttr)
2779 ;
2780 put_attr(Other,Mod,NormalAttr),
2781 '$dispatch_run_suspensions'(NormalAttr)
2782 )
2783 ;
2784 NonvarBody,
2785 '$dispatch_run_suspensions'(NormalAttr)
2786 )
2787 ),
2788 Clause = (Head :- Body),
2789 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2790 DispatchList1 = ('$dispatch_run_suspensions'([])),
2791 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2792 run_suspensions_dispatchers(N,[],Dispatchers).
2794 % NEW
2795 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2796 ( N > 0 ->
2797 get_indexed_constraint(N,C),
2798 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2799 ( may_trigger(C) ->
2800 run_suspensions_goal(C,List,Body)
2801 ;
2802 Body = true
2803 ),
2804 M is N - 1,
2805 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2806 ;
2807 Dispatchers = Acc
2808 ).
2810 % NEW
2811 make_run_suspensions(N) :-
2812 ( N > 0 ->
2813 ( get_indexed_constraint(N,C),
2814 may_trigger(C) ->
2815 use_auxiliary_predicate(run_suspensions,C)
2816 ;
2817 true
2818 ),
2819 M is N - 1,
2820 make_run_suspensions(M)
2821 ;
2822 true
2823 ).
2825 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2826 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2828 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2829 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2830 use_auxiliary_predicate(run_suspensions,C),
2831 ( wakes_partially(C) ->
2832 run_suspensions_goal(C,OneSusps,Goal)
2833 ;
2834 run_suspensions_goal(C,AllSusps,Goal)
2835 )
2836 ;
2837 Goal = true
2838 ).
2840 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2841 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2843 make_run_suspensions_loop([],[],_,true).
2844 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2845 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2846 J is I + 1,
2847 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2849 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2850 % $insert_in_store_F/A
2851 % $delete_from_store_F/A
2853 generate_insert_delete_constraints([],[]).
2854 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2855 ( is_stored(FA) ->
2856 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2857 ;
2858 Clauses = RestClauses
2859 ),
2860 generate_insert_delete_constraints(Rest,RestClauses).
2862 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2863 insert_constraint_clause(FA,Clauses,RestClauses1),
2864 delete_constraint_clause(FA,RestClauses1,RestClauses).
2866 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2867 % insert_in_store
2869 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2870 ( chr_pp_flag(inline_insertremove,off) ->
2871 use_auxiliary_predicate(insert_in_store,FA),
2872 insert_constraint_atom(FA,Susp,Goal)
2873 ;
2874 delay_phase_end(validate_store_type_assumptions,
2875 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2876 insert_constraint_direct_used_vars(UsedVars,Vars)
2877 )
2878 )
2879 ).
2881 insert_constraint_direct_used_vars([],_).
2882 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2883 nth1(Index,Vars,Var),
2884 insert_constraint_direct_used_vars(Rest,Vars).
2886 insert_constraint_atom(FA,Susp,Call) :-
2887 make_name('$insert_in_store_',FA,Functor),
2888 Call =.. [Functor,Susp].
2890 insert_constraint_clause(C,Clauses,RestClauses) :-
2891 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2892 Clauses = [Clause|RestClauses],
2893 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2894 insert_constraint_atom(C,Susp,Head),
2895 insert_constraint_body(C,Susp,UsedVars,Body),
2896 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2897 ( chr_pp_flag(store_counter,on) ->
2898 InsertCounterInc = '$insert_counter_inc'
2899 ;
2900 InsertCounterInc = true
2901 )
2902 ;
2903 Clauses = RestClauses
2904 ).
2906 insert_constraint_used_vars([],_,_,true).
2907 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2908 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2909 insert_constraint_used_vars(Rest,C,Susp,Goals).
2911 insert_constraint_body(C,Susp,UsedVars,Body) :-
2912 get_store_type(C,StoreType),
2913 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2915 insert_constraint_body(default,C,Susp,[],Body) :-
2916 global_list_store_name(C,StoreName),
2917 make_get_store_goal(StoreName,Store,GetStoreGoal),
2918 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2919 ( chr_pp_flag(debugable,on) ->
2920 Cell = [Susp|Store],
2921 Body =
2922 (
2923 GetStoreGoal,
2924 UpdateStoreGoal
2925 )
2926 ;
2927 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2928 Body =
2929 (
2930 GetStoreGoal,
2931 Cell = [Susp|Store],
2932 UpdateStoreGoal,
2933 ( Store = [NextSusp|_] ->
2934 SetGoal
2935 ;
2936 true
2937 )
2938 )
2939 ).
2940 % get_target_module(Mod),
2941 % get_max_constraint_index(Total),
2942 % ( Total == 1 ->
2943 % generate_attach_body_1(C,Store,Susp,AttachBody)
2944 % ;
2945 % generate_attach_body_n(C,Store,Susp,AttachBody)
2946 % ),
2947 % Body =
2948 % (
2949 % 'chr default_store'(Store),
2950 % AttachBody
2951 % ).
2952 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2953 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2954 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2955 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2956 sort_out_used_vars(MixedUsedVars,UsedVars).
2957 insert_constraint_body(atomic_constants([Index],_),C,Susp,UsedVars,Body) :-
2958 atomic_constant_store_index_name(C,[Index],IndexName),
2959 UsedVars = [Index - Key],
2960 IndexLookup =.. [IndexName,Key,StoreName],
2961 Body =
2962 ( IndexLookup ->
2963 nb_getval(StoreName,Store),
2964 b_setval(StoreName,[Susp|Store])
2965 ;
2966 true
2967 ).
2968 insert_constraint_body(ground_constants([Index],_),C,Susp,UsedVars,Body) :-
2969 ground_constant_store_index_name(C,[Index],IndexName),
2970 UsedVars = [Index - Key],
2971 IndexLookup =.. [IndexName,Key,StoreName],
2972 Body =
2973 ( IndexLookup ->
2974 nb_getval(StoreName,Store),
2975 b_setval(StoreName,[Susp|Store])
2976 ;
2977 true
2978 ).
2979 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2980 global_ground_store_name(C,StoreName),
2981 make_get_store_goal(StoreName,Store,GetStoreGoal),
2982 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2983 ( chr_pp_flag(debugable,on) ->
2984 Cell = [Susp|Store],
2985 Body =
2986 (
2987 GetStoreGoal,
2988 UpdateStoreGoal
2989 )
2990 ;
2991 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2992 Body =
2993 (
2994 GetStoreGoal,
2995 Cell = [Susp|Store],
2996 UpdateStoreGoal,
2997 ( Store = [NextSusp|_] ->
2998 SetGoal
2999 ;
3000 true
3001 )
3002 )
3003 ).
3004 % global_ground_store_name(C,StoreName),
3005 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3006 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3007 % Body =
3008 % (
3009 % GetStoreGoal, % nb_getval(StoreName,Store),
3010 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3011 % ).
3012 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3013 % TODO: generalize to more than one !!!
3014 get_target_module(Module),
3015 Body = ( get_attr(Variable,Module,AssocStore) ->
3016 insert_assoc_store(AssocStore,Key,Susp)
3017 ;
3018 new_assoc_store(AssocStore),
3019 put_attr(Variable,Module,AssocStore),
3020 insert_assoc_store(AssocStore,Key,Susp)
3021 ).
3023 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3024 global_singleton_store_name(C,StoreName),
3025 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3026 Body =
3027 (
3028 UpdateStoreGoal
3029 ).
3030 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3031 find_with_var_identity(
3032 B-UV,
3033 [Susp],
3034 (
3035 member(ST,StoreTypes),
3036 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
3037 ),
3038 BodiesUsedVars
3039 ),
3040 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
3041 list2conj(Bodies,Body),
3042 sort_out_used_vars(NestedUsedVars,UsedVars).
3043 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3044 UsedVars = [Index-Var],
3045 get_identifier_size(ISize),
3046 functor(Struct,struct,ISize),
3047 get_identifier_index(C,Index,IIndex),
3048 arg(IIndex,Struct,Susps),
3049 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3050 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3051 UsedVars = [Index-Var],
3052 type_indexed_identifier_structure(IndexType,Struct),
3053 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3054 arg(IIndex,Struct,Susps),
3055 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3057 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3058 flatten(NestedUsedVars,FlatUsedVars),
3059 sort(FlatUsedVars,SortedFlatUsedVars),
3060 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3062 sort_out_used_vars1([],[]).
3063 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3064 sort_out_used_vars1([I-X,J-Y|R],L) :-
3065 ( I == J ->
3066 X = Y,
3067 sort_out_used_vars1([I-X|R],L)
3068 ;
3069 L = [I-X|T],
3070 sort_out_used_vars1([J-Y|R],T)
3071 ).
3073 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3074 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3075 multi_hash_store_name(FA,Index,StoreName),
3076 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3077 Body =
3078 (
3079 KeyBody,
3080 nb_getval(StoreName,Store),
3081 insert_iht(Store,Key,Susp)
3082 ),
3083 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3085 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3086 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3087 multi_hash_store_name(FA,Index,StoreName),
3088 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3089 make_get_store_goal(StoreName,Store,GetStoreGoal),
3090 ( chr_pp_flag(ht_removal,on)
3091 -> ht_prev_field(Index,PrevField),
3092 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3093 SetGoal),
3094 Body =
3095 (
3096 GetStoreGoal,
3097 insert_ht(Store,Key,Susp,Result),
3098 ( Result = [_,NextSusp|_]
3099 -> SetGoal
3100 ; true
3101 )
3102 )
3103 ; Body =
3104 (
3105 GetStoreGoal,
3106 insert_ht(Store,Key,Susp)
3107 )
3108 ),
3109 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3111 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3112 % Delete
3114 delete_constraint_clause(C,Clauses,RestClauses) :-
3115 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3116 Clauses = [Clause|RestClauses],
3117 Clause = (Head :- Body),
3118 delete_constraint_atom(C,Susp,Head),
3119 C = F/A,
3120 functor(Head,F,A),
3121 delete_constraint_body(C,Head,Susp,[],Body)
3122 ;
3123 Clauses = RestClauses
3124 ).
3126 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3127 functor(Head,F,A),
3128 C = F/A,
3129 ( chr_pp_flag(inline_insertremove,off) ->
3130 use_auxiliary_predicate(delete_from_store,C),
3131 delete_constraint_atom(C,Susp,Goal)
3132 ;
3133 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3134 ).
3136 delete_constraint_atom(C,Susp,Atom) :-
3137 make_name('$delete_from_store_',C,Functor),
3138 Atom =.. [Functor,Susp].
3141 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3142 Body = (CounterBody,DeleteBody),
3143 ( chr_pp_flag(store_counter,on) ->
3144 CounterBody = '$delete_counter_inc'
3145 ;
3146 CounterBody = true
3147 ),
3148 get_store_type(C,StoreType),
3149 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3151 delete_constraint_body(default,C,_,Susp,_,Body) :-
3152 ( chr_pp_flag(debugable,on) ->
3153 global_list_store_name(C,StoreName),
3154 make_get_store_goal(StoreName,Store,GetStoreGoal),
3155 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3156 Body =
3157 (
3158 GetStoreGoal, % nb_getval(StoreName,Store),
3159 'chr sbag_del_element'(Store,Susp,NStore),
3160 UpdateStoreGoal % b_setval(StoreName,NStore)
3161 )
3162 ;
3163 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3164 global_list_store_name(C,StoreName),
3165 make_get_store_goal(StoreName,Store,GetStoreGoal),
3166 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3167 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3168 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3169 Body =
3170 (
3171 GetGoal,
3172 ( var(PredCell) ->
3173 GetStoreGoal, % nb_getval(StoreName,Store),
3174 Store = [_|Tail],
3175 UpdateStoreGoal,
3176 ( Tail = [NextSusp|_] ->
3177 SetGoal1
3178 ;
3179 true
3180 )
3181 ;
3182 PredCell = [_,_|Tail],
3183 setarg(2,PredCell,Tail),
3184 ( Tail = [NextSusp|_] ->
3185 SetGoal2
3186 ;
3187 true
3188 )
3189 )
3190 )
3191 ).
3192 % get_target_module(Mod),
3193 % get_max_constraint_index(Total),
3194 % ( Total == 1 ->
3195 % generate_detach_body_1(C,Store,Susp,DetachBody),
3196 % Body =
3197 % (
3198 % 'chr default_store'(Store),
3199 % DetachBody
3200 % )
3201 % ;
3202 % generate_detach_body_n(C,Store,Susp,DetachBody),
3203 % Body =
3204 % (
3205 % 'chr default_store'(Store),
3206 % DetachBody
3207 % )
3208 % ).
3209 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3210 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3211 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3212 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3213 delete_constraint_body(atomic_constants([Index],_),C,Head,Susp,VarDict,Body) :-
3214 atomic_constant_store_index_name(C,[Index],IndexName),
3215 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Key,Goal),
3216 IndexLookup =.. [IndexName,Key,StoreName],
3217 Body =
3218 (Goal,
3219 ( IndexLookup ->
3220 nb_getval(StoreName,Store),
3221 'chr sbag_del_element'(Store,Susp,NStore),
3222 b_setval(StoreName,NStore)
3223 ;
3224 true
3225 )).
3226 delete_constraint_body(atomic_constants([Index],_),C,Head,Susp,VarDict,Body) :-
3227 ground_constant_store_index_name(C,[Index],IndexName),
3228 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Key,Goal),
3229 IndexLookup =.. [IndexName,Key,StoreName],
3230 Body =
3231 (Goal,
3232 ( IndexLookup ->
3233 nb_getval(StoreName,Store),
3234 'chr sbag_del_element'(Store,Susp,NStore),
3235 b_setval(StoreName,NStore)
3236 ;
3237 true
3238 )).
3239 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3240 ( chr_pp_flag(debugable,on) ->
3241 global_ground_store_name(C,StoreName),
3242 make_get_store_goal(StoreName,Store,GetStoreGoal),
3243 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3244 Body =
3245 (
3246 GetStoreGoal, % nb_getval(StoreName,Store),
3247 'chr sbag_del_element'(Store,Susp,NStore),
3248 UpdateStoreGoal % b_setval(StoreName,NStore)
3249 )
3250 ;
3251 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3252 global_ground_store_name(C,StoreName),
3253 make_get_store_goal(StoreName,Store,GetStoreGoal),
3254 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3255 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3256 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3257 Body =
3258 (
3259 GetGoal,
3260 ( var(PredCell) ->
3261 GetStoreGoal, % nb_getval(StoreName,Store),
3262 Store = [_|Tail],
3263 UpdateStoreGoal,
3264 ( Tail = [NextSusp|_] ->
3265 SetGoal1
3266 ;
3267 true
3268 )
3269 ;
3270 PredCell = [_,_|Tail],
3271 setarg(2,PredCell,Tail),
3272 ( Tail = [NextSusp|_] ->
3273 SetGoal2
3274 ;
3275 true
3276 )
3277 )
3278 )
3279 ).
3280 % global_ground_store_name(C,StoreName),
3281 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3282 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3283 % Body =
3284 % (
3285 % GetStoreGoal, % nb_getval(StoreName,Store),
3286 % 'chr sbag_del_element'(Store,Susp,NStore),
3287 % UpdateStoreGoal % b_setval(StoreName,NStore)
3288 % ).
3289 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3290 get_target_module(Module),
3291 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3292 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3293 Body = (
3294 VariableGoal,
3295 get_attr(Variable,Module,AssocStore),
3296 KeyGoal,
3297 delete_assoc_store(AssocStore,Key,Susp)
3298 ).
3299 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3300 global_singleton_store_name(C,StoreName),
3301 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3302 Body =
3303 (
3304 UpdateStoreGoal % b_setval(StoreName,[])
3305 ).
3306 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3307 find_with_var_identity(
3308 B,
3309 [Susp/VarDict/Head],
3310 (
3311 member(ST,StoreTypes),
3312 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3313 ),
3314 Bodies
3315 ),
3316 list2conj(Bodies,Body).
3317 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3318 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3319 get_identifier_size(ISize),
3320 functor(Struct,struct,ISize),
3321 get_identifier_index(C,Index,IIndex),
3322 arg(IIndex,Struct,Susps),
3323 Body = (
3324 VariableGoal,
3325 Variable = Struct,
3326 'chr sbag_del_element'(Susps,Susp,NSusps),
3327 setarg(IIndex,Variable,NSusps)
3328 ).
3329 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3330 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3331 type_indexed_identifier_structure(IndexType,Struct),
3332 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3333 arg(IIndex,Struct,Susps),
3334 Body = (
3335 VariableGoal,
3336 Variable = Struct,
3337 'chr sbag_del_element'(Susps,Susp,NSusps),
3338 setarg(IIndex,Variable,NSusps)
3339 ).
3341 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3342 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3343 multi_hash_store_name(FA,Index,StoreName),
3344 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3345 Body =
3346 (
3347 KeyBody,
3348 nb_getval(StoreName,Store),
3349 delete_iht(Store,Key,Susp)
3350 ),
3351 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3352 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3353 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3354 multi_hash_store_name(C,Index,StoreName),
3355 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3356 make_get_store_goal(StoreName,Store,GetStoreGoal),
3357 ( chr_pp_flag(ht_removal,on)
3358 -> ht_prev_field(Index,PrevField),
3359 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3360 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3361 SetGoal1),
3362 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3363 SetGoal2),
3364 Body =
3365 (
3366 GetGoal,
3367 ( var(Prev)
3368 -> GetStoreGoal,
3369 KeyBody,
3370 delete_first_ht(Store,Key,Values),
3371 ( Values = [NextSusp|_]
3372 -> SetGoal1
3373 ; true
3374 )
3375 ; Prev = [_,_|Values],
3376 setarg(2,Prev,Values),
3377 ( Values = [NextSusp|_]
3378 -> SetGoal2
3379 ; true
3380 )
3381 )
3382 )
3383 ; Body =
3384 (
3385 KeyBody,
3386 GetStoreGoal, % nb_getval(StoreName,Store),
3387 delete_ht(Store,Key,Susp)
3388 )
3389 ),
3390 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3392 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3394 :- chr_constraint
3395 module_initializer/1,
3396 module_initializers/1.
3398 module_initializers(G), module_initializer(Initializer) <=>
3399 G = (Initializer,Initializers),
3400 module_initializers(Initializers).
3402 module_initializers(G) <=>
3403 G = true.
3405 generate_attach_code(Constraints,[Enumerate|L]) :-
3406 enumerate_stores_code(Constraints,Enumerate),
3407 generate_attach_code(Constraints,L,T),
3408 module_initializers(Initializers),
3409 prolog_global_variables_code(PrologGlobalVariables),
3410 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3412 generate_attach_code([],L,L).
3413 generate_attach_code([C|Cs],L,T) :-
3414 get_store_type(C,StoreType),
3415 generate_attach_code(StoreType,C,L,L1),
3416 generate_attach_code(Cs,L1,T).
3418 generate_attach_code(default,C,L,T) :-
3419 global_list_store_initialisation(C,L,T).
3420 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3421 multi_inthash_store_initialisations(Indexes,C,L,L1),
3422 multi_inthash_via_lookups(Indexes,C,L1,T).
3423 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3424 multi_hash_store_initialisations(Indexes,C,L,L1),
3425 multi_hash_lookups(Indexes,C,L1,T).
3426 generate_attach_code(atomic_constants(Index,Constants),C,L,T) :-
3427 maplist(atomic_constant_store_name(C,Index),Constants,StoreNames),
3428 findall(Initializer,
3429 ( member(StoreName,StoreNames),
3430 Initializer = nb_setval(StoreName,[])
3431 ),
3432 Initializers),
3433 maplist(module_initializer,Initializers),
3434 atomic_constants_code(C,Index,Constants,L,T).
3435 generate_attach_code(ground_constants(Index,Constants),C,L,T) :-
3436 maplist(ground_constant_store_name(C,Index),Constants,StoreNames),
3437 findall(Initializer,
3438 ( member(StoreName,StoreNames),
3439 Initializer = nb_setval(StoreName,[])
3440 ),
3441 Initializers),
3442 maplist(module_initializer,Initializers),
3443 ground_constants_code(C,Index,Constants,L,T).
3444 generate_attach_code(global_ground,C,L,T) :-
3445 global_ground_store_initialisation(C,L,T).
3446 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3447 use_auxiliary_module(chr_assoc_store).
3448 generate_attach_code(global_singleton,C,L,T) :-
3449 global_singleton_store_initialisation(C,L,T).
3450 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3451 multi_store_generate_attach_code(StoreTypes,C,L,T).
3452 generate_attach_code(identifier_store(Index),C,L,T) :-
3453 get_identifier_index(C,Index,IIndex),
3454 ( IIndex == 2 ->
3455 get_identifier_size(ISize),
3456 functor(Struct,struct,ISize),
3457 Struct =.. [_,Label|Stores],
3458 set_elems(Stores,[]),
3459 Clause1 = new_identifier(Label,Struct),
3460 functor(Struct2,struct,ISize),
3461 arg(1,Struct2,Label2),
3462 Clause2 =
3463 ( user:portray(Struct2) :-
3464 write('<id:'),
3465 print(Label2),
3466 write('>')
3467 ),
3468 functor(Struct3,struct,ISize),
3469 arg(1,Struct3,Label3),
3470 Clause3 = identifier_label(Struct3,Label3),
3471 L = [Clause1,Clause2,Clause3|T]
3472 ;
3473 L = T
3474 ).
3475 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3476 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3477 ( IIndex == 2 ->
3478 identifier_store_initialization(IndexType,L,L1),
3479 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3480 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3481 get_type_indexed_identifier_size(IndexType,ISize),
3482 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3483 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3484 type_indexed_identifier_structure(IndexType,Struct),
3485 Struct =.. [_,Label|Stores],
3486 set_elems(Stores,[]),
3487 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3488 Clause1 =.. [Name1,Label,Struct],
3489 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3490 Goal1 =.. [Name1,Label1b,S1b],
3491 type_indexed_identifier_structure(IndexType,Struct1b),
3492 Struct1b =.. [_,Label1b|Stores1b],
3493 set_elems(Stores1b,[]),
3494 Expansion1 = (S1b = Struct1b),
3495 Clause1b = user:goal_expansion(Goal1,Expansion1),
3496 % writeln(Clause1-Clause1b),
3497 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3498 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3499 type_indexed_identifier_structure(IndexType,Struct2),
3500 arg(1,Struct2,Label2),
3501 Clause2 =
3502 ( user:portray(Struct2) :-
3503 write('<id:'),
3504 print(Label2),
3505 write('>')
3506 ),
3507 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3508 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3509 type_indexed_identifier_structure(IndexType,Struct3),
3510 arg(1,Struct3,Label3),
3511 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3512 Clause3 =.. [Name3,Struct3,Label3],
3513 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3514 Goal3b =.. [Name3,S3b,L3b],
3515 type_indexed_identifier_structure(IndexType,Struct3b),
3516 arg(1,Struct3b,L3b),
3517 Expansion3b = (S3 = Struct3b),
3518 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3519 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3520 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3521 identifier_store_name(IndexType,GlobalVariable),
3522 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3523 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3524 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3525 Clause4 =
3526 ( LookupAtom :-
3527 nb_getval(GlobalVariable,HT),
3528 ( lookup_ht(HT,X,[IX]) ->
3529 true
3530 ;
3531 NewIdentifierGoal,
3532 insert_ht(HT,X,IX)
3533 )
3534 ),
3535 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3536 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3537 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3538 ;
3539 L = T
3540 ).
3542 lookup_identifier_atom(Key,X,IX,Atom) :-
3543 atom_concat('lookup_identifier_',Key,LookupFunctor),
3544 Atom =.. [LookupFunctor,X,IX].
3546 identifier_label_atom(IndexType,IX,X,Atom) :-
3547 type_indexed_identifier_name(IndexType,identifier_label,Name),
3548 Atom =.. [Name,IX,X].
3550 multi_store_generate_attach_code([],_,L,L).
3551 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3552 generate_attach_code(ST,C,L,L1),
3553 multi_store_generate_attach_code(STs,C,L1,T).
3555 multi_inthash_store_initialisations([],_,L,L).
3556 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3557 use_auxiliary_module(chr_integertable_store),
3558 multi_hash_store_name(FA,Index,StoreName),
3559 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3560 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3561 L1 = L,
3562 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3563 multi_hash_store_initialisations([],_,L,L).
3564 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3565 use_auxiliary_module(chr_hashtable_store),
3566 multi_hash_store_name(FA,Index,StoreName),
3567 prolog_global_variable(StoreName),
3568 make_init_store_goal(StoreName,HT,InitStoreGoal),
3569 module_initializer((new_ht(HT),InitStoreGoal)),
3570 L1 = L,
3571 multi_hash_store_initialisations(Indexes,FA,L1,T).
3573 global_list_store_initialisation(C,L,T) :-
3574 ( is_stored(C) ->
3575 global_list_store_name(C,StoreName),
3576 prolog_global_variable(StoreName),
3577 make_init_store_goal(StoreName,[],InitStoreGoal),
3578 module_initializer(InitStoreGoal)
3579 ;
3580 true
3581 ),
3582 L = T.
3583 global_ground_store_initialisation(C,L,T) :-
3584 global_ground_store_name(C,StoreName),
3585 prolog_global_variable(StoreName),
3586 make_init_store_goal(StoreName,[],InitStoreGoal),
3587 module_initializer(InitStoreGoal),
3588 L = T.
3589 global_singleton_store_initialisation(C,L,T) :-
3590 global_singleton_store_name(C,StoreName),
3591 prolog_global_variable(StoreName),
3592 make_init_store_goal(StoreName,[],InitStoreGoal),
3593 module_initializer(InitStoreGoal),
3594 L = T.
3595 identifier_store_initialization(IndexType,L,T) :-
3596 use_auxiliary_module(chr_hashtable_store),
3597 identifier_store_name(IndexType,StoreName),
3598 prolog_global_variable(StoreName),
3599 make_init_store_goal(StoreName,HT,InitStoreGoal),
3600 module_initializer((new_ht(HT),InitStoreGoal)),
3601 L = T.
3604 multi_inthash_via_lookups([],_,L,L).
3605 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3606 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3607 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3608 L = [(Head :- Body)|L1],
3609 multi_inthash_via_lookups(Indexes,C,L1,T).
3610 multi_hash_lookups([],_,L,L).
3611 multi_hash_lookups([Index|Indexes],C,L,T) :-
3612 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3613 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3614 L = [(Head :- Body)|L1],
3615 multi_hash_lookups(Indexes,C,L1,T).
3617 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3618 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3619 Head =.. [Name,Key,SuspsList].
3621 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3622 %
3623 % Returns goal that performs hash table lookup.
3624 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3625 % INLINED:
3626 ( get_store_type(ConstraintSymbol,multi_store(Stores)),
3627 memberchk(atomic_constants(Index,Constants),Stores) ->
3628 ( ground(Key) ->
3629 atomic_constant_store_name(ConstraintSymbol,Index,Key,StoreName),
3630 Goal = nb_getval(StoreName,SuspsList)
3631 ;
3632 atomic_constant_store_index_name(ConstraintSymbol,Index,IndexName),
3633 Lookup =.. [IndexName,Key,StoreName],
3634 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3635 )
3636 ; get_store_type(ConstraintSymbol,multi_store(Stores)),
3637 memberchk(ground_constants(Index,Constants),Stores) ->
3638 ( ground(Key) ->
3639 ground_constant_store_name(ConstraintSymbol,Index,Key,StoreName),
3640 Goal = nb_getval(StoreName,SuspsList)
3641 ;
3642 ground_constant_store_index_name(ConstraintSymbol,Index,IndexName),
3643 Lookup =.. [IndexName,Key,StoreName],
3644 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3645 )
3646 ;
3647 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3648 make_get_store_goal(StoreName,HT,GetStoreGoal),
3649 ( HashType == hash, specialized_hash_term_call(Key,Hash,HashCall) ->
3650 Goal =
3651 (
3652 GetStoreGoal, % nb_getval(StoreName,HT),
3653 HashCall, % hash_term(Key,Hash),
3654 lookup_ht1(HT,Hash,Key,SuspsList)
3655 )
3656 ;
3657 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3658 Goal =
3659 (
3660 GetStoreGoal, % nb_getval(StoreName,HT),
3661 hash_term(Key,Hash),
3662 Lookup
3663 )
3664 )
3665 ).
3668 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3669 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3671 specialized_hash_term_call(Key,Hash,Call) :-
3672 ( ground(Key) ->
3673 % This is based on a property of SWI-Prolog's
3674 % hash_term/2 predicate:
3675 % the hash value is stable over repeated invocations
3676 % of SWI-Prolog
3677 hash_term(Key,Hash),
3678 Call = true
3679 ;
3680 nonvar(Key),
3681 specialize_hash_term(Key,NewKey),
3682 NewKey \== Key,
3683 Call = hash_term(NewKey,Hash)
3684 ).
3686 specialize_hash_term(Term,NewTerm) :-
3687 ( ground(Term) ->
3688 hash_term(Term,NewTerm)
3689 ; var(Term) ->
3690 NewTerm = Term
3691 ;
3692 Term =.. [F|Args],
3693 maplist(specialize_hash_term,Args,NewArgs),
3694 NewTerm =.. [F|NewArgs]
3695 ).
3697 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3698 ( /* chr_pp_flag(experiment,off) ->
3699 true
3700 ; */ atomic(Key) ->
3701 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3702 ; ground(Key) ->
3703 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3704 ;
3705 actual_non_atomic_multi_hash_key(ConstraintSymbol,Index)
3706 ),
3707 delay_phase_end(validate_store_type_assumptions,
3708 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3710 :- chr_constraint actual_atomic_multi_hash_keys/3.
3711 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3713 :- chr_constraint actual_ground_multi_hash_keys/3.
3714 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3716 :- chr_constraint actual_non_atomic_multi_hash_key/2.
3717 :- chr_option(mode,actual_non_atomic_multi_hash_key(+,+)).
3719 /*
3720 actual_atomic_multi_hash_keys(C,Index,Keys)
3721 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3723 actual_ground_multi_hash_keys(C,Index,Keys)
3724 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3726 actual_non_atomic_multi_hash_key(C,Index)
3727 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3728 */
3729 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3730 <=> append(Keys1,Keys2,Keys0),
3731 sort(Keys0,Keys),
3732 actual_atomic_multi_hash_keys(C,Index,Keys).
3734 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3735 <=> append(Keys1,Keys2,Keys0),
3736 sort(Keys0,Keys),
3737 actual_ground_multi_hash_keys(C,Index,Keys).
3739 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3740 <=> append(Keys1,Keys2,Keys0),
3741 sort(Keys0,Keys),
3742 actual_ground_multi_hash_keys(C,Index,Keys).
3744 actual_non_atomic_multi_hash_key(C,Index) \ actual_non_atomic_multi_hash_key(C,Index)
3745 <=> true.
3747 actual_non_atomic_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3748 <=> true.
3750 actual_non_atomic_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3751 <=> true.
3753 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3754 %
3755 % Returns predicate name of hash table lookup predicate.
3756 multi_hash_lookup_name(F/A,Index,Name) :-
3757 ( integer(Index) ->
3758 IndexName = Index
3759 ; is_list(Index) ->
3760 atom_concat_list(Index,IndexName)
3761 ),
3762 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3764 multi_hash_store_name(F/A,Index,Name) :-
3765 get_target_module(Mod),
3766 ( integer(Index) ->
3767 IndexName = Index
3768 ; is_list(Index) ->
3769 atom_concat_list(Index,IndexName)
3770 ),
3771 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3773 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3774 ( ( integer(Index) ->
3775 I = Index
3776 ;
3777 Index = [I]
3778 ) ->
3779 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3780 ; is_list(Index) ->
3781 sort(Index,Indexes),
3782 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3783 once(pairup(Bodies,Keys,ArgKeyPairs)),
3784 Key =.. [k|Keys],
3785 list2conj(Bodies,KeyBody)
3786 ).
3788 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3789 ( ( integer(Index) ->
3790 I = Index
3791 ;
3792 Index = [I]
3793 ) ->
3794 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3795 ; is_list(Index) ->
3796 sort(Index,Indexes),
3797 find_with_var_identity(
3798 Goal-KeyI,
3799 [Susp/Head/VarDict],
3800 (
3801 member(I,Indexes),
3802 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3803 ),
3804 ArgKeyPairs
3805 ),
3806 once(pairup(Bodies,Keys,ArgKeyPairs)),
3807 Key =.. [k|Keys],
3808 list2conj(Bodies,KeyBody)
3809 ).
3811 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3812 arg(Index,Head,OriginalArg),
3813 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3814 Goal = true
3815 ;
3816 functor(Head,F,A),
3817 C = F/A,
3818 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3819 ).
3821 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3822 ( ( integer(Index) ->
3823 I = Index
3824 ;
3825 Index = [I]
3826 ) ->
3827 UsedVars = [I-Key]
3828 ; is_list(Index) ->
3829 sort(Index,Indexes),
3830 pairup(Indexes,Keys,UsedVars),
3831 Key =.. [k|Keys]
3832 ).
3834 multi_hash_key_args(Index,Head,KeyArgs) :-
3835 ( integer(Index) ->
3836 arg(Index,Head,Arg),
3837 KeyArgs = [Arg]
3838 ; is_list(Index) ->
3839 sort(Index,Indexes),
3840 term_variables(Head,Vars),
3841 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3842 ).
3845 %-------------------------------------------------------------------------------
3846 atomic_constants_code(C,Index,Constants,L,T) :-
3847 atomic_constant_store_index_name(C,Index,IndexName),
3848 findall(Clause,
3849 ( member(Constant,Constants),
3850 atomic_constant_store_name(C,Index,Constant,StoreName),
3851 Clause =.. [IndexName,Constant,StoreName]
3852 ),
3853 Clauses),
3854 append(Clauses,T,L).
3856 atomic_constant_store_name(F/A,[Index],Constant,Name) :-
3857 get_target_module(Mod),
3858 atom_concat_list(['$chr_store_atomic_constant_',Mod,'____',F,'___',A,'___',Index,'___',Constant],Name).
3860 atomic_constant_store_index_name(F/A,[Index],Name) :-
3861 get_target_module(Mod),
3862 atom_concat_list(['$chr_store_atomic_constant_',Mod,'____',F,'___',A,'___',Index],Name).
3863 %-------------------------------------------------------------------------------
3864 ground_constants_code(C,Index,Terms,L,T) :-
3865 ground_constant_store_index_name(C,Index,IndexName),
3866 findall(StoreName,
3867 ( member(Constant,Terms),
3868 ground_constant_store_name(C,Index,Constant,StoreName)
3869 ),
3870 StoreNames),
3871 length(Terms,N),
3872 replicate(N,[],More),
3873 % writeln(StoreNames),
3874 trie_index([Terms|More],StoreNames,IndexName,L,T).
3875 % findall(Clause,
3876 % ( member(Term,Terms),
3877 % ground_constant_store_name(C,Index,Term,StoreName),
3878 % Clause =.. [IndexName,Term,StoreName] % TODO: replace with trie
3879 % ),
3880 % Clauses),
3881 % append(Clauses,T,L).
3883 ground_constant_store_name(F/A,Index,Term,Name) :-
3884 get_target_module(Mod),
3885 term_to_atom(Term,Constant),
3886 term_to_atom(Index,IndexAtom),
3887 atom_concat_list(['$chr_store_ground_constant_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3889 ground_constant_store_index_name(F/A,Index,Name) :-
3890 get_target_module(Mod),
3891 term_to_atom(Index,IndexAtom),
3892 atom_concat_list(['$chr_store_ground_constant_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3894 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3895 % writeln(trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail)),
3896 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3898 trie_step([],_,_,[],[],L,L) :- !.
3899 % length MorePatterns == length Patterns == length Results
3900 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3901 % writeln(trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T)),
3902 MorePatterns = [List|_],
3903 length(List,N),
3904 findall(F/A,
3905 ( member(Pattern,Patterns),
3906 functor(Pattern,F,A)
3907 ),
3908 FAs0),
3909 sort(FAs0,FAs),
3910 N1 is N + 1,
3911 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3913 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3914 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3915 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3916 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3918 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3919 % format('% ~w\n',[F/A]),
3920 Clause = (Head :- Body),
3921 N1 is N + 1,
3922 functor(Head,Symbol,N1),
3923 arg(N1,Head,Result),
3924 functor(IndexPattern,F,A),
3925 arg(1,Head,IndexPattern),
3926 Head =.. [_,_|RestArgs],
3927 IndexPattern =.. [_|Args],
3928 append(Args,RestArgs,RecArgs),
3929 ( RecArgs == [Result] ->
3930 List = Tail,
3931 Body = true,
3932 % writeln(Results),
3933 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
3934 % writeln(MoreResults),
3935 MoreResults = [Result]
3936 ;
3937 gensym(Prefix,RSymbol),
3938 Body =.. [RSymbol|RecArgs],
3939 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
3940 trie_step(Cases,RSymbol,Prefix,MoreCases,MoreResults,List,Tail)
3941 ).
3943 rec_cases([],[],[],_,[],[],[]).
3944 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
3945 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
3946 Cases = [Case|NCases],
3947 MoreCases = [MoreCase|NMoreCases],
3948 MoreResults = [Result|NMoreResults],
3949 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
3950 ;
3951 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
3952 ).
3954 %-------------------------------------------------------------------------------
3955 global_list_store_name(F/A,Name) :-
3956 get_target_module(Mod),
3957 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
3958 global_ground_store_name(F/A,Name) :-
3959 get_target_module(Mod),
3960 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
3961 global_singleton_store_name(F/A,Name) :-
3962 get_target_module(Mod),
3963 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
3965 identifier_store_name(TypeName,Name) :-
3966 get_target_module(Mod),
3967 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
3969 :- chr_constraint prolog_global_variable/1.
3970 :- chr_option(mode,prolog_global_variable(+)).
3972 :- chr_constraint prolog_global_variables/1.
3973 :- chr_option(mode,prolog_global_variables(-)).
3975 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
3977 prolog_global_variables(List), prolog_global_variable(Name) <=>
3978 List = [Name|Tail],
3979 prolog_global_variables(Tail).
3980 prolog_global_variables(List) <=> List = [].
3982 %% SWI begin
3983 prolog_global_variables_code(Code) :-
3984 prolog_global_variables(Names),
3985 ( Names == [] ->
3986 Code = []
3987 ;
3988 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
3989 Code = [(:- dynamic user:exception/3),
3990 (:- multifile user:exception/3),
3991 (user:exception(undefined_global_variable,Name,retry) :-
3992 (
3993 '$chr_prolog_global_variable'(Name),
3994 '$chr_initialization'
3995 )
3996 )
3997 |
3998 NameDeclarations
3999 ]
4000 ).
4001 %% SWI end
4002 %% SICStus begin
4003 % prolog_global_variables_code([]).
4004 %% SICStus end
4005 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4006 %sbag_member_call(S,L,sysh:mem(S,L)).
4007 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4008 %sbag_member_call(S,L,member(S,L)).
4009 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4010 %update_mutable_call(A,B,setarg(1, B, A)).
4011 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4012 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4014 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4015 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4016 % create_get_mutable(Value,Field,Get1).
4017 %
4018 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4019 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4020 % update_mutable_call(NewValue,Field,Set).
4021 %
4022 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4023 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4024 % create_get_mutable_ref(Value,Field,Get1),
4025 % update_mutable_call(NewValue,Field,Set).
4026 %
4027 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4028 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4029 % create_mutable_call(Value,Field,Create).
4030 %
4031 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4032 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4033 % create_get_mutable(Value,Field,Get).
4034 %
4035 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4036 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4037 % create_get_mutable_ref(Value,Field,Get),
4038 % update_mutable_call(NewValue,Field,Set).
4040 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4041 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4043 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4044 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4046 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4047 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4048 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4050 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4051 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4053 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4054 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4056 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4057 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4058 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4060 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4062 enumerate_stores_code(Constraints,Clause) :-
4063 Head = '$enumerate_constraints'(Constraint),
4064 enumerate_store_bodies(Constraints,Constraint,Bodies),
4065 list2disj(Bodies,Body),
4066 Clause = (Head :- Body).
4068 enumerate_store_bodies([],_,[]).
4069 enumerate_store_bodies([C|Cs],Constraint,L) :-
4070 ( is_stored(C) ->
4071 get_store_type(C,StoreType),
4072 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
4073 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4074 C = F/_,
4075 Constraint0 =.. [F|Arguments],
4076 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4077 L = [Body|T]
4078 ;
4079 L = T
4080 ),
4081 enumerate_store_bodies(Cs,Constraint,T).
4083 enumerate_store_body(default,C,Susp,Body) :-
4084 global_list_store_name(C,StoreName),
4085 sbag_member_call(Susp,List,Sbag),
4086 make_get_store_goal(StoreName,List,GetStoreGoal),
4087 Body =
4088 (
4089 GetStoreGoal, % nb_getval(StoreName,List),
4090 Sbag
4091 ).
4092 % get_constraint_index(C,Index),
4093 % get_target_module(Mod),
4094 % get_max_constraint_index(MaxIndex),
4095 % Body1 =
4096 % (
4097 % 'chr default_store'(GlobalStore),
4098 % get_attr(GlobalStore,Mod,Attr)
4099 % ),
4100 % ( MaxIndex > 1 ->
4101 % NIndex is Index + 1,
4102 % sbag_member_call(Susp,List,Sbag),
4103 % Body2 =
4104 % (
4105 % arg(NIndex,Attr,List),
4106 % Sbag
4107 % )
4108 % ;
4109 % sbag_member_call(Susp,Attr,Sbag),
4110 % Body2 = Sbag
4111 % ),
4112 % Body = (Body1,Body2).
4113 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4114 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4115 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4116 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4117 enumerate_store_body(atomic_constants(_,_),_,_,_) :- fail.
4118 enumerate_store_body(ground_constants(_,_),_,_,_) :- fail.
4119 enumerate_store_body(global_ground,C,Susp,Body) :-
4120 global_ground_store_name(C,StoreName),
4121 sbag_member_call(Susp,List,Sbag),
4122 make_get_store_goal(StoreName,List,GetStoreGoal),
4123 Body =
4124 (
4125 GetStoreGoal, % nb_getval(StoreName,List),
4126 Sbag
4127 ).
4128 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4129 Body = fail.
4130 enumerate_store_body(global_singleton,C,Susp,Body) :-
4131 global_singleton_store_name(C,StoreName),
4132 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4133 Body =
4134 (
4135 GetStoreGoal, % nb_getval(StoreName,Susp),
4136 Susp \== []
4137 ).
4138 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4139 once((
4140 member(ST,STs),
4141 enumerate_store_body(ST,C,Susp,Body)
4142 )).
4143 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4144 Body = fail.
4145 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4146 Body = fail.
4148 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4149 multi_hash_store_name(C,I,StoreName),
4150 B =
4151 (
4152 nb_getval(StoreName,HT),
4153 value_iht(HT,Susp)
4154 ).
4155 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4156 multi_hash_store_name(C,I,StoreName),
4157 make_get_store_goal(StoreName,HT,GetStoreGoal),
4158 B =
4159 (
4160 GetStoreGoal, % nb_getval(StoreName,HT),
4161 value_ht(HT,Susp)
4162 ).
4164 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4167 :- chr_constraint
4168 prev_guard_list/8,
4169 prev_guard_list/6,
4170 simplify_guards/1,
4171 set_all_passive/1.
4173 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4174 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4175 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4176 :- chr_option(mode,simplify_guards(+)).
4177 :- chr_option(mode,set_all_passive(+)).
4179 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4180 % GUARD SIMPLIFICATION
4181 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4182 % If the negation of the guards of earlier rules entails (part of)
4183 % the current guard, the current guard can be simplified. We can only
4184 % use earlier rules with a head that matches if the head of the current
4185 % rule does, and which make it impossible for the current rule to match
4186 % if they fire (i.e. they shouldn't be propagation rules and their
4187 % head constraints must be subsets of those of the current rule).
4188 % At this point, we know for sure that the negation of the guard
4189 % of such a rule has to be true (otherwise the earlier rule would have
4190 % fired, because of the refined operational semantics), so we can use
4191 % that information to simplify the guard by replacing all entailed
4192 % conditions by true/0. As a consequence, the never-stored analysis
4193 % (in a further phase) will detect more cases of never-stored constraints.
4194 %
4195 % e.g. c(X),d(Y) <=> X > 0 | ...
4196 % e(X) <=> X < 0 | ...
4197 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4198 % \____________/
4199 % true
4201 guard_simplification :-
4202 ( chr_pp_flag(guard_simplification,on) ->
4203 precompute_head_matchings,
4204 simplify_guards(1)
4205 ;
4206 true
4207 ).
4209 % for every rule, we create a prev_guard_list where the last argument
4210 % eventually is a list of the negations of earlier guards
4211 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4212 <=>
4213 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4214 append(Head1,Head2,Heads),
4215 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4216 multiple_occ_constraints_checked([]),
4217 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4219 append(IDs1,IDs2,IDs),
4220 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4221 empty_q(EmptyHeap),
4222 insert_list_q(HeapData,EmptyHeap,Heap),
4223 next_prev_rule(Heap,_,Heap1),
4224 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4225 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4226 NextRule is RuleNb+1,
4227 simplify_guards(NextRule).
4229 next_prev_rule(Heap,RuleNb,NHeap) :-
4230 ( find_min_q(Heap,_-Priority) ->
4231 Priority = (-RuleNb),
4232 normalize_heap(Heap,Priority,NHeap)
4233 ;
4234 RuleNb = 0,
4235 NHeap = Heap
4236 ).
4238 normalize_heap(Heap,Priority,NHeap) :-
4239 ( find_min_q(Heap,_-Priority) ->
4240 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4241 ( O > 1 ->
4242 NO is O -1,
4243 get_occurrence(C,NO,RuleNb,_),
4244 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4245 ;
4246 Heap2 = Heap1
4247 ),
4248 normalize_heap(Heap2,Priority,NHeap)
4249 ;
4250 NHeap = Heap
4251 ).
4253 % no more rule
4254 simplify_guards(_)
4255 <=>
4256 true.
4258 % The negation of the guard of a non-propagation rule is added
4259 % if its kept head constraints are a subset of the kept constraints of
4260 % the rule we're working on, and its removed head constraints (at least one)
4261 % are a subset of the removed constraints.
4263 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4264 <=>
4265 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4266 H1 \== [],
4267 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4268 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4269 |
4270 append(H1,H2,Heads),
4271 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4272 append(GuardList,DerivedInfo,GL1),
4273 normalize_conj_list(GL1,GL),
4274 append(GH_New1,GH,GH1),
4275 normalize_conj_list(GH1,GH_New),
4276 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4277 % PrevPrevRuleNb is PrevRuleNb-1,
4278 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4280 % if this isn't the case, we skip this one and try the next rule
4281 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4282 <=>
4283 ( N > 0 ->
4284 next_prev_rule(Heap,N1,NHeap),
4285 % N1 is N-1,
4286 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4287 ;
4288 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4289 ).
4291 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4292 <=>
4293 GH \== []
4294 |
4295 head_types_modes_condition(GH,H,TypeInfo),
4296 conj2list(TypeInfo,TI),
4297 term_variables(H,HeadVars),
4298 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4299 normalize_conj_list(Info,InfoL),
4300 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4302 head_types_modes_condition([],H,true).
4303 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4304 types_modes_condition(H,GH,TI1),
4305 head_types_modes_condition(GHs,H,TI2).
4307 %%
4308 %
4309 % when all earlier guards are added or skipped, we simplify the guard.
4310 % if it's different from the original one, we change the rule
4312 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4313 <=>
4314 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4315 G \== true, % let's not try to simplify this ;)
4316 append(M,GuardList,Info),
4317 simplify_guard(G,B,Info,SimpleGuard,NB),
4318 G \== SimpleGuard
4319 |
4320 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4321 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4323 %% normalize_conj_list(+List,-NormalList) is det.
4324 %
4325 % Removes =true= elements and flattens out conjunctions.
4327 normalize_conj_list(List,NormalList) :-
4328 list2conj(List,Conj),
4329 conj2list(Conj,NormalList).
4331 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4332 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4333 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4335 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4336 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4337 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4338 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4339 append(Renaming1,ExtraRenaming,Renaming2),
4340 list2conj(PrevMatchings,Match),
4341 negate_b(Match,HeadsDontMatch),
4342 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4343 list2conj(HeadsMatch,HeadsMatchBut),
4344 term_variables(Renaming2,RenVars),
4345 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4346 new_vars(MGVars,RenVars,ExtraRenaming2),
4347 append(Renaming2,ExtraRenaming2,Renaming),
4348 ( PrevGuard == true -> % true can't fail
4349 Info_ = HeadsDontMatch
4350 ;
4351 negate_b(PrevGuard,TheGuardFailed),
4352 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4353 ),
4354 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4355 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4356 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4357 list2conj(RenamedMatchings_,RenamedMatchings),
4358 apply_guard_wrt_term(H,RenamedG2,GH2),
4359 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4360 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4362 simplify_guard(G,B,Info,SG,NB) :-
4363 conj2list(G,LG),
4364 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4365 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4366 list2conj(SGL,SG).
4369 new_vars([],_,[]).
4370 new_vars([A|As],RV,ER) :-
4371 ( memberchk_eq(A,RV) ->
4372 new_vars(As,RV,ER)
4373 ;
4374 ER = [A-NewA,NewA-A|ER2],
4375 new_vars(As,RV,ER2)
4376 ).
4378 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4379 %
4380 % check if a list of constraints is a subset of another list of constraints
4381 % (multiset-subset), meanwhile computing a variable renaming to convert
4382 % one into the other.
4383 head_subset(H,Head,Renaming) :-
4384 head_subset(H,Head,Renaming,[],_).
4386 head_subset([],Remainder,Renaming,Renaming,Remainder).
4387 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4388 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4389 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4391 % check if A is in the list, remove it from Headleft
4392 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4393 ( variable_replacement(A,X,Acc,Renaming),
4394 Remainder = Xs
4395 ;
4396 Remainder = [X|RRemainder],
4397 head_member(Xs,A,Renaming,Acc,RRemainder)
4398 ).
4399 %-------------------------------------------------------------------------------%
4400 % memoing code to speed up repeated computation
4402 :- chr_constraint precompute_head_matchings/0.
4404 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4405 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4406 append(H1,H2,Heads),
4407 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4408 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4409 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4411 precompute_head_matchings <=> true.
4413 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4414 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4416 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4417 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4419 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4420 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4421 <=>
4422 Q1 = NHeads,
4423 Q2 = Matchings.
4424 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4426 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4427 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4428 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4429 %-------------------------------------------------------------------------------%
4431 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4432 extract_arguments(Heads,Arguments),
4433 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4434 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4436 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4437 extract_arguments(Heads,Arguments),
4438 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4439 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4441 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4442 extract_arguments(Heads,Arguments1),
4443 extract_arguments(MatchingFreeHeads,Arguments2),
4444 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4446 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4447 %
4448 % Returns list of arguments of given list of constraints.
4449 extract_arguments([],[]).
4450 extract_arguments([Constraint|Constraints],AllArguments) :-
4451 Constraint =.. [_|Arguments],
4452 append(Arguments,RestArguments,AllArguments),
4453 extract_arguments(Constraints,RestArguments).
4455 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4456 %
4457 % Substitutes arguments of constraints with those in the given list.
4459 substitute_arguments([],[],[]).
4460 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4461 functor(Constraint,F,N),
4462 split_at(N,Variables,Arguments,RestVariables),
4463 NConstraint =.. [F|Arguments],
4464 substitute_arguments(Constraints,RestVariables,NConstraints).
4466 make_matchings_explicit([],[],_,MC,MC,[]).
4467 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4468 ( var(Arg) ->
4469 ( memberchk_eq(Arg,VarAcc) ->
4470 list2disj(MatchingCondition,MatchingCondition_disj),
4471 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4472 NVarAcc = VarAcc
4473 ;
4474 Matchings = RestMatchings,
4475 NewVar = Arg,
4476 NVarAcc = [Arg|VarAcc]
4477 ),
4478 MatchingCondition2 = MatchingCondition
4479 ;
4480 functor(Arg,F,A),
4481 Arg =.. [F|RecArgs],
4482 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4483 FlatArg =.. [F|RecVars],
4484 ( RecMatchings == [] ->
4485 Matchings = [functor(NewVar,F,A)|RestMatchings]
4486 ;
4487 list2conj(RecMatchings,ArgM_conj),
4488 list2disj(MatchingCondition,MatchingCondition_disj),
4489 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4490 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4491 ),
4492 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4493 term_variables(Args,ArgVars),
4494 append(ArgVars,VarAcc,NVarAcc)
4495 ),
4496 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4499 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4500 %
4501 % Returns list of new variables and list of pairwise unifications between given list and variables.
4503 make_matchings_explicit_not_negated([],[],[]).
4504 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4505 Matchings = [Var = X|RMatchings],
4506 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4508 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4509 %
4510 % (Partially) applies substitutions of =Goal= to given list.
4512 apply_guard_wrt_term([],_Guard,[]).
4513 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4514 ( var(Term) ->
4515 apply_guard_wrt_variable(Guard,Term,NTerm)
4516 ;
4517 Term =.. [F|HArgs],
4518 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4519 NTerm =.. [F|NewHArgs]
4520 ),
4521 apply_guard_wrt_term(RH,Guard,RGH).
4523 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4524 %
4525 % (Partially) applies goal =Guard= wrt variable.
4527 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4528 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4529 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4530 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4531 ( Guard = (X = Y), Variable == X ->
4532 NVariable = Y
4533 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4534 functor(NVariable,Functor,Arity)
4535 ;
4536 NVariable = Variable
4537 ).
4539 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4540 % ALWAYS FAILING HEADS
4541 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4543 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4544 <=>
4545 chr_pp_flag(check_impossible_rules,on),
4546 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4547 append(M,GuardList,Info),
4548 guard_entailment:entails_guard(Info,fail)
4549 |
4550 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4551 set_all_passive(RuleNb).
4553 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4554 % HEAD SIMPLIFICATION
4555 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4557 % now we check the head matchings (guard may have been simplified meanwhile)
4558 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4559 <=>
4560 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4561 simplify_heads(M,GuardList,G,B,NewM,NewB),
4562 NewM \== [],
4563 extract_arguments(Head1,VH1),
4564 extract_arguments(Head2,VH2),
4565 extract_arguments(H,VH),
4566 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4567 substitute_arguments(Head1,H1,NewH1),
4568 substitute_arguments(Head2,H2,NewH2),
4569 append(NewB,NewB_,NewBody),
4570 list2conj(NewBody,BodyMatchings),
4571 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4572 (Head1 \== NewH1 ; Head2 \== NewH2 )
4573 |
4574 rule(RuleNb,NewRule).
4576 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4577 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4578 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4580 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4581 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4582 ( NH == M ->
4583 H2_ = M,
4584 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4585 ;
4586 (M = functor(X,F,A), NH == X ->
4587 length(A_args,A),
4588 (var(H2) ->
4589 NewB1 = [],
4590 H2_ =.. [F|A_args]
4591 ;
4592 H2 =.. [F|OrigArgs],
4593 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4594 H2_ =.. [F|A_args_]
4595 ),
4596 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4597 append(NewB1,NewB2,NewB)
4598 ;
4599 H2_ = H2,
4600 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4601 )
4602 ).
4604 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4605 ( NH == M ->
4606 H1_ = M,
4607 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4608 ;
4609 (M = functor(X,F,A), NH == X ->
4610 length(A_args,A),
4611 (var(H1) ->
4612 NewB1 = [],
4613 H1_ =.. [F|A_args]
4614 ;
4615 H1 =.. [F|OrigArgs],
4616 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4617 H1_ =.. [F|A_args_]
4618 ),
4619 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4620 append(NewB1,NewB2,NewB)
4621 ;
4622 H1_ = H1,
4623 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4624 )
4625 ).
4627 use_same_args([],[],[],_,_,[]).
4628 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4629 var(OA),!,
4630 Out = OA,
4631 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4632 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4633 nonvar(OA),!,
4634 ( common_variables(OA,Body) ->
4635 NewB = [NA = OA|NextB]
4636 ;
4637 NewB = NextB
4638 ),
4639 Out = NA,
4640 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4643 simplify_heads([],_GuardList,_G,_Body,[],[]).
4644 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4645 M = (A = B),
4646 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4647 guard_entailment:entails_guard(GuardList,(A=B)) ->
4648 ( common_variables(B,G-RM-GuardList) ->
4649 NewB = NextB,
4650 NewM = NextM
4651 ;
4652 ( common_variables(B,Body) ->
4653 NewB = [A = B|NextB]
4654 ;
4655 NewB = NextB
4656 ),
4657 NewM = [A|NextM]
4658 )
4659 ;
4660 ( nonvar(B), functor(B,BFu,BAr),
4661 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4662 NewB = NextB,
4663 ( common_variables(B,G-RM-GuardList) ->
4664 NewM = NextM
4665 ;
4666 NewM = [functor(A,BFu,BAr)|NextM]
4667 )
4668 ;
4669 NewM = NextM,
4670 NewB = NextB
4671 )
4672 ),
4673 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4675 common_variables(B,G) :-
4676 term_variables(B,BVars),
4677 term_variables(G,GVars),
4678 intersect_eq(BVars,GVars,L),
4679 L \== [].
4682 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4683 % ALWAYS FAILING GUARDS
4684 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4686 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4687 set_all_passive(_) <=> true.
4689 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4690 ==>
4691 chr_pp_flag(check_impossible_rules,on),
4692 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4693 conj2list(G,GL),
4694 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4695 guard_entailment:entails_guard(GL,fail)
4696 |
4697 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4698 set_all_passive(RuleNb).
4702 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4703 % OCCURRENCE SUBSUMPTION
4704 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4706 :- chr_constraint
4707 first_occ_in_rule/4,
4708 next_occ_in_rule/6.
4710 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4711 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4713 :- chr_constraint multiple_occ_constraints_checked/1.
4714 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4716 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4717 occurrence(C,O,RuleNb,ID,_),
4718 occurrence(C,O2,RuleNb,ID2,_),
4719 rule(RuleNb,Rule)
4720 \
4721 multiple_occ_constraints_checked(Done)
4722 <=>
4723 O < O2,
4724 chr_pp_flag(occurrence_subsumption,on),
4725 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4726 H1 \== [],
4727 \+ memberchk_eq(C,Done)
4728 |
4729 first_occ_in_rule(RuleNb,C,O,ID),
4730 multiple_occ_constraints_checked([C|Done]).
4732 % Find first occurrence of constraint =C= in rule =RuleNb=
4733 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4734 <=>
4735 O < O2
4736 |
4737 first_occ_in_rule(RuleNb,C,O,ID).
4739 first_occ_in_rule(RuleNb,C,O,ID_o1)
4740 <=>
4741 C = F/A,
4742 functor(FreshHead,F,A),
4743 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4745 % Skip passive occurrences.
4746 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4747 <=>
4748 O2 is O+1
4749 |
4750 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4752 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)
4753 <=>
4754 O2 is O+1,
4755 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4756 |
4757 append(H1,H2,Heads),
4758 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4759 ( ExtraCond == [chr_pp_void_info] ->
4760 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4761 ;
4762 append(ExtraCond,Cond,NewCond),
4763 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4764 copy_term(GuardList,FGuardList),
4765 variable_replacement(GuardList,FGuardList,GLRepl),
4766 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4767 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4768 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4769 append(NewCond,GuardList2,BigCond),
4770 append(BigCond,GuardList3,BigCond2),
4771 copy_with_variable_replacement(M,M2,Repl),
4772 copy_with_variable_replacement(M,M3,Repl2),
4773 append(M3,BigCond2,BigCond3),
4774 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4775 list2conj(CheckCond,OccSubsum),
4776 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4777 ( OccSubsum \= chr_pp_void_info ->
4778 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4779 passive(RuleNb,ID_o2)
4780 ;
4781 true
4782 )
4783 ;
4784 true
4785 ),!,
4786 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4787 ).
4790 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4791 <=>
4792 true.
4794 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4795 <=>
4796 true.
4798 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4799 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4800 append(ID2,ID1,IDs),
4801 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4802 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4803 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4804 copy_with_variable_replacement(G,FG,Repl),
4805 extract_explicit_matchings(FG,FG2),
4806 negate_b(FG2,NotFG),
4807 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4808 ( safely_unifiable(FH,FH2), FH=FH2 ->
4809 FailCond = [(NotFG;FMPCond)]
4810 ;
4811 % in this case, not much can be done
4812 % e.g. c(f(...)), c(g(...)) <=> ...
4813 FailCond = [chr_pp_void_info]
4814 ).
4816 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4817 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4818 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4819 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4820 Cond = (chr_pp_not_in_store(H);Cond1),
4821 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4823 extract_explicit_matchings((A,B),D) :- !,
4824 ( extract_explicit_matchings(A) ->
4825 extract_explicit_matchings(B,D)
4826 ;
4827 D = (A,E),
4828 extract_explicit_matchings(B,E)
4829 ).
4830 extract_explicit_matchings(A,D) :- !,
4831 ( extract_explicit_matchings(A) ->
4832 D = true
4833 ;
4834 D = A
4835 ).
4837 extract_explicit_matchings(A=B) :-
4838 var(A), var(B), !, A=B.
4839 extract_explicit_matchings(A==B) :-
4840 var(A), var(B), !, A=B.
4842 safely_unifiable(H,I) :- var(H), !.
4843 safely_unifiable([],[]) :- !.
4844 safely_unifiable([H|Hs],[I|Is]) :- !,
4845 safely_unifiable(H,I),
4846 safely_unifiable(Hs,Is).
4847 safely_unifiable(H,I) :-
4848 nonvar(H),
4849 nonvar(I),
4850 H =.. [F|HA],
4851 I =.. [F|IA],
4852 safely_unifiable(HA,IA).
4856 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4857 % TYPE INFORMATION
4858 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4860 :- chr_constraint
4861 type_definition/2,
4862 type_alias/2,
4863 constraint_type/2,
4864 get_type_definition/2,
4865 get_constraint_type/2.
4868 :- chr_option(mode,type_definition(?,?)).
4869 :- chr_option(mode,get_type_definition(?,?)).
4870 :- chr_option(mode,type_alias(?,?)).
4871 :- chr_option(mode,constraint_type(+,+)).
4872 :- chr_option(mode,get_constraint_type(+,-)).
4874 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4875 % Consistency checks of type aliases
4877 type_alias(T,T2) <=>
4878 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4879 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4880 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4882 type_alias(T1,A1), type_alias(T2,A2) <=>
4883 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4884 \+ (T1\=T2) |
4885 copy_term_nat(T1,T1_),
4886 copy_term_nat(T2,T2_),
4887 T1_ = T2_,
4888 chr_error(type_error,
4889 '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_]).
4891 type_alias(T,B) \ type_alias(X,T2) <=>
4892 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4893 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4894 chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4895 type_alias(X2,D1).
4897 oneway_unification(X,Y) :-
4898 term_variables(X,XVars),
4899 chr_runtime:lockv(XVars),
4900 X=Y,
4901 chr_runtime:unlockv(XVars).
4903 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4904 % Consistency checks of type definitions
4906 type_definition(T1,_), type_definition(T2,_)
4907 <=>
4908 functor(T1,F,A), functor(T2,F,A)
4909 |
4910 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
4912 type_definition(T1,_), type_alias(T2,_)
4913 <=>
4914 functor(T1,F,A), functor(T2,F,A)
4915 |
4916 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
4918 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4919 %% get_type_definition(+Type,-Definition) is semidet.
4920 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4922 get_type_definition(T,Def)
4923 <=>
4924 \+ ground(T)
4925 |
4926 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
4928 type_alias(T,D) \ get_type_definition(T2,Def)
4929 <=>
4930 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4931 copy_term_nat((T,D),(T1,D1)),T1=T2
4932 |
4933 ( get_type_definition(D1,Def) ->
4934 true
4935 ;
4936 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
4937 ).
4939 type_definition(T,D) \ get_type_definition(T2,Def)
4940 <=>
4941 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4942 copy_term_nat((T,D),(T1,D1)),T1=T2
4943 |
4944 Def = D1.
4946 get_type_definition(Type,Def)
4947 <=>
4948 atomic_builtin_type(Type,_,_)
4949 |
4950 Def = [Type].
4952 get_type_definition(Type,Def)
4953 <=>
4954 compound_builtin_type(Type,_,_)
4955 |
4956 Def = [Type].
4958 get_type_definition(X,Y) <=> fail.
4960 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4961 %% get_type_definition_det(+Type,-Definition) is det.
4962 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4963 get_type_definition_det(Type,Definition) :-
4964 ( get_type_definition(Type,Definition) ->
4965 true
4966 ;
4967 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
4968 ).
4970 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4971 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
4972 %
4973 % Return argument types of =ConstraintSymbol=, but fails if none where
4974 % declared.
4975 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4976 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
4977 get_constraint_type(_,_) <=> fail.
4979 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4980 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
4981 %
4982 % Like =get_constraint_type/2=, but returns list of =any= types when
4983 % no types are declared.
4984 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4985 get_constraint_type_det(ConstraintSymbol,Types) :-
4986 ( get_constraint_type(ConstraintSymbol,Types) ->
4987 true
4988 ;
4989 ConstraintSymbol = _ / N,
4990 replicate(N,any,Types)
4991 ).
4992 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4993 %% unalias_type(+Alias,-Type) is det.
4994 %
4995 % Follows alias chain until base type is reached.
4996 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4997 :- chr_constraint unalias_type/2.
4999 unalias_var @
5000 unalias_type(Alias,BaseType)
5001 <=>
5002 var(Alias)
5003 |
5004 BaseType = Alias.
5006 unalias_alias @
5007 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5008 <=>
5009 nonvar(AliasProtoType),
5010 nonvar(Alias),
5011 functor(AliasProtoType,F,A),
5012 functor(Alias,F,A),
5013 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5014 Alias = AliasInstance
5015 |
5016 unalias_type(Type,BaseType).
5018 unalias_type_definition @
5019 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5020 <=>
5021 nonvar(ProtoType),
5022 nonvar(Alias),
5023 functor(ProtoType,F,A),
5024 functor(Alias,F,A)
5025 |
5026 BaseType = Alias.
5028 unalias_atomic_builtin @
5029 unalias_type(Alias,BaseType)
5030 <=>
5031 atomic_builtin_type(Alias,_,_)
5032 |
5033 BaseType = Alias.
5035 unalias_compound_builtin @
5036 unalias_type(Alias,BaseType)
5037 <=>
5038 compound_builtin_type(Alias,_,_)
5039 |
5040 BaseType = Alias.
5042 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5043 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5044 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5045 :- chr_constraint types_modes_condition/3.
5046 :- chr_option(mode,types_modes_condition(+,+,?)).
5047 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5049 types_modes_condition([],[],T) <=> T=true.
5051 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5052 <=>
5053 functor(Head,F,A)
5054 |
5055 Head =.. [_|Args],
5056 Condition = (ModesCondition, TypesCondition, RestCondition),
5057 modes_condition(Modes,Args,ModesCondition),
5058 get_constraint_type_det(F/A,Types),
5059 UnrollHead =.. [_|RealArgs],
5060 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5061 types_modes_condition(Heads,UnrollHeads,RestCondition).
5063 types_modes_condition([Head|_],_,_)
5064 <=>
5065 functor(Head,F,A),
5066 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5069 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5070 %% modes_condition(+Modes,+Args,-Condition) is det.
5071 %
5072 % Return =Condition= on =Args= that checks =Modes=.
5073 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5074 modes_condition([],[],true).
5075 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5076 ( Mode == (+) ->
5077 Condition = ( ground(Arg) , RCondition )
5078 ; Mode == (-) ->
5079 Condition = ( var(Arg) , RCondition )
5080 ;
5081 Condition = RCondition
5082 ),
5083 modes_condition(Modes,Args,RCondition).
5085 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5086 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5087 %
5088 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5089 % =UnrollArgs= controls the depth of type definition unrolling.
5090 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5091 types_condition([],[],[],[],true).
5092 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5093 ( Mode == (-) ->
5094 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5095 ;
5096 get_type_definition_det(Type,Def),
5097 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5098 ( Mode == (+) ->
5099 TypeConditionList = TypeConditionList1
5100 ;
5101 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5102 )
5103 ),
5104 list2disj(TypeConditionList,DisjTypeConditionList),
5105 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5107 type_condition([],_,_,_,[]).
5108 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5109 ( var(DefCase) ->
5110 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5111 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5112 true
5113 ; compound_builtin_type(DefCase,Arg,Condition) ->
5114 true
5115 ;
5116 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5117 ),
5118 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5120 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5121 :- chr_type atomic_builtin_type ---> any
5122 ; number
5123 ; float
5124 ; int
5125 ; natural
5126 ; dense_int
5127 ; chr_identifier
5128 ; chr_identifier(any).
5129 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5131 atomic_builtin_type(any,_Arg,true).
5132 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5133 atomic_builtin_type(int,Arg,integer(Arg)).
5134 atomic_builtin_type(number,Arg,number(Arg)).
5135 atomic_builtin_type(float,Arg,float(Arg)).
5136 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5137 atomic_builtin_type(chr_identifier,_Arg,true).
5139 compound_builtin_type(chr_identifier(_),_Arg,true).
5141 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5142 ( nonvar(DefCase) ->
5143 functor(DefCase,F,A),
5144 ( A == 0 ->
5145 Condition = (Arg = DefCase)
5146 ; var(UnrollArg) ->
5147 Condition = functor(Arg,F,A)
5148 ; functor(UnrollArg,F,A) ->
5149 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5150 DefCase =.. [_|ArgTypes],
5151 UnrollArg =.. [_|UnrollArgs],
5152 functor(Template,F,A),
5153 Template =.. [_|TemplateArgs],
5154 replicate(A,Mode,ArgModes),
5155 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5156 ;
5157 Condition = functor(Arg,F,A)
5158 )
5159 ;
5160 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5161 ).
5164 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5165 % Static type checking
5166 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5167 % Checks head constraints and CHR constraint calls in bodies.
5168 %
5169 % TODO:
5170 % - type clashes involving built-in types
5171 % - Prolog built-ins in guard and body
5172 % - indicate position in terms in error messages
5173 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5174 :- chr_constraint
5175 static_type_check/0.
5177 :- chr_type type_error_src ---> head(any) ; body(any).
5179 rule(_,Rule), static_type_check
5180 ==>
5181 copy_term_nat(Rule,RuleCopy),
5182 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5183 (
5184 catch(
5185 ( static_type_check_heads(Head1),
5186 static_type_check_heads(Head2),
5187 conj2list(Body,GoalList),
5188 static_type_check_body(GoalList)
5189 ),
5190 type_error(Error),
5191 ( Error = invalid_functor(Src,Term,Type) ->
5192 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5193 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5194 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5195 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5196 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5197 )
5198 ),
5199 fail % cleanup constraints
5200 ;
5201 true
5202 ).
5205 static_type_check <=> true.
5207 static_type_check_heads([]).
5208 static_type_check_heads([Head|Heads]) :-
5209 static_type_check_head(Head),
5210 static_type_check_heads(Heads).
5212 static_type_check_head(Head) :-
5213 functor(Head,F,A),
5214 get_constraint_type_det(F/A,Types),
5215 Head =..[_|Args],
5216 maplist(static_type_check_term(head(Head)),Args,Types).
5218 static_type_check_body([]).
5219 static_type_check_body([Goal|Goals]) :-
5220 functor(Goal,F,A),
5221 get_constraint_type_det(F/A,Types),
5222 Goal =..[_|Args],
5223 maplist(static_type_check_term(body(Goal)),Args,Types),
5224 static_type_check_body(Goals).
5226 :- chr_constraint static_type_check_term/3.
5227 :- chr_option(mode,static_type_check_term(?,?,?)).
5228 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5230 static_type_check_term(Src,Term,Type)
5231 <=>
5232 var(Term)
5233 |
5234 static_type_check_var(Src,Term,Type).
5235 static_type_check_term(Src,Term,Type)
5236 <=>
5237 atomic_builtin_type(Type,Term,Goal)
5238 |
5239 ( call(Goal) ->
5240 true
5241 ;
5242 throw(type_error(invalid_functor(Src,Term,Type)))
5243 ).
5244 static_type_check_term(Src,Term,Type)
5245 <=>
5246 compound_builtin_type(Type,Term,Goal)
5247 |
5248 ( call(Goal) ->
5249 true
5250 ;
5251 throw(type_error(invalid_functor(Src,Term,Type)))
5252 ).
5253 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5254 <=>
5255 functor(Type,F,A),
5256 functor(AType,F,A)
5257 |
5258 copy_term_nat(AType-ADef,Type-Def),
5259 static_type_check_term(Src,Term,Def).
5261 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5262 <=>
5263 functor(Type,F,A),
5264 functor(AType,F,A)
5265 |
5266 copy_term_nat(AType-ADef,Type-Variants),
5267 functor(Term,TF,TA),
5268 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5269 Term =.. [_|Args],
5270 Variant =.. [_|Types],
5271 maplist(static_type_check_term(Src),Args,Types)
5272 ;
5273 throw(type_error(invalid_functor(Src,Term,Type)))
5274 ).
5276 static_type_check_term(Src,Term,Type)
5277 <=>
5278 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5280 :- chr_constraint static_type_check_var/3.
5281 :- chr_option(mode,static_type_check_var(?,-,?)).
5282 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5284 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5285 <=>
5286 functor(AType,F,A),
5287 functor(Type,F,A)
5288 |
5289 copy_term_nat(AType-ADef,Type-Def),
5290 static_type_check_var(Src,Var,Def).
5292 static_type_check_var(Src,Var,Type)
5293 <=>
5294 atomic_builtin_type(Type,_,_)
5295 |
5296 static_atomic_builtin_type_check_var(Src,Var,Type).
5298 static_type_check_var(Src,Var,Type)
5299 <=>
5300 compound_builtin_type(Type,_,_)
5301 |
5302 true.
5305 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5306 <=>
5307 Type1 \== Type2
5308 |
5309 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5311 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5312 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5313 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5314 :- chr_constraint static_atomic_builtin_type_check_var/3.
5315 :- chr_option(mode,static_type_check_var(?,-,+)).
5316 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5318 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5319 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5320 <=>
5321 true.
5322 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5323 <=>
5324 true.
5325 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5326 <=>
5327 true.
5328 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5329 <=>
5330 true.
5331 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5332 <=>
5333 true.
5334 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5335 <=>
5336 true.
5337 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5338 <=>
5339 true.
5340 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5341 <=>
5342 true.
5343 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5344 <=>
5345 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5347 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5348 %% format_src(+type_error_src) is det.
5349 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5350 format_src(head(Head)) :- format('head ~w',[Head]).
5351 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5353 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5354 % Dynamic type checking
5355 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5357 :- chr_constraint
5358 dynamic_type_check/0,
5359 dynamic_type_check_clauses/1,
5360 get_dynamic_type_check_clauses/1.
5362 generate_dynamic_type_check_clauses(Clauses) :-
5363 ( chr_pp_flag(debugable,on) ->
5364 dynamic_type_check,
5365 get_dynamic_type_check_clauses(Clauses0),
5366 append(Clauses0,
5367 [('$dynamic_type_check'(Type,Term) :-
5368 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5369 )],
5370 Clauses)
5371 ;
5372 Clauses = []
5373 ).
5375 type_definition(T,D), dynamic_type_check
5376 ==>
5377 copy_term_nat(T-D,Type-Definition),
5378 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5379 dynamic_type_check_clauses(DynamicChecks).
5380 type_alias(A,B), dynamic_type_check
5381 ==>
5382 copy_term_nat(A-B,Alias-Body),
5383 dynamic_type_check_alias_clause(Alias,Body,Clause),
5384 dynamic_type_check_clauses([Clause]).
5386 dynamic_type_check <=>
5387 findall(
5388 ('$dynamic_type_check'(Type,Term) :- Goal),
5389 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
5390 BuiltinChecks
5391 ),
5392 dynamic_type_check_clauses(BuiltinChecks).
5394 dynamic_type_check_clause(T,DC,Clause) :-
5395 copy_term(T-DC,Type-DefinitionClause),
5396 functor(DefinitionClause,F,A),
5397 functor(Term,F,A),
5398 DefinitionClause =.. [_|DCArgs],
5399 Term =.. [_|TermArgs],
5400 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5401 list2conj(RecursiveCallList,RecursiveCalls),
5402 Clause = (
5403 '$dynamic_type_check'(Type,Term) :-
5404 RecursiveCalls
5405 ).
5407 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5408 Clause = (
5409 '$dynamic_type_check'(Alias,Term) :-
5410 '$dynamic_type_check'(Body,Term)
5411 ).
5413 dynamic_type_check_call(Type,Term,Call) :-
5414 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5415 % Call = when(nonvar(Term),Goal)
5416 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5417 % Call = when(nonvar(Term),Goal)
5418 % ;
5419 ( Type == any ->
5420 Call = true
5421 ;
5422 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5423 )
5424 % )
5425 .
5427 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5428 <=>
5429 append(C1,C2,C),
5430 dynamic_type_check_clauses(C).
5432 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5433 <=>
5434 Q = C.
5435 get_dynamic_type_check_clauses(Q)
5436 <=>
5437 Q = [].
5439 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5440 % Atomic Types
5441 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5442 % Some optimizations can be applied for atomic types...
5443 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5445 atomic_types_suspended_constraint(C) :-
5446 C = _/N,
5447 get_constraint_type(C,ArgTypes),
5448 get_constraint_mode(C,ArgModes),
5449 findall(I,between(1,N,I),Indexes),
5450 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5452 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5453 ( is_indexed_argument(C,Index) ->
5454 ( Mode == (?) ->
5455 atomic_type(Type)
5456 ;
5457 true
5458 )
5459 ;
5460 true
5461 ).
5463 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5464 %% atomic_type(+Type) is semidet.
5465 %
5466 % Succeeds when all values of =Type= are atomic.
5467 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5468 :- chr_constraint atomic_type/1.
5470 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5472 type_definition(TypePat,Def) \ atomic_type(Type)
5473 <=>
5474 functor(Type,F,A), functor(TypePat,F,A)
5475 |
5476 forall(member(Term,Def),atomic(Term)).
5478 type_alias(TypePat,Alias) \ atomic_type(Type)
5479 <=>
5480 functor(Type,F,A), functor(TypePat,F,A)
5481 |
5482 atomic(Alias),
5483 copy_term_nat(TypePat-Alias,Type-NType),
5484 atomic_type(NType).
5486 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5487 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5488 %
5489 % Succeeds when all values of =Type= are atomic
5490 % and the atom values are finitely enumerable.
5491 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5492 :- chr_constraint enumerated_atomic_type/2.
5494 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5496 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5497 <=>
5498 functor(Type,F,A), functor(TypePat,F,A)
5499 |
5500 forall(member(Term,Def),atomic(Term)),
5501 Atoms = Def.
5503 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5504 <=>
5505 functor(Type,F,A), functor(TypePat,F,A)
5506 |
5507 atomic(Alias),
5508 copy_term_nat(TypePat-Alias,Type-NType),
5509 enumerated_atomic_type(NType,Atoms).
5510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5512 :- chr_constraint
5513 stored/3, % constraint,occurrence,(yes/no/maybe)
5514 stored_completing/3,
5515 stored_complete/3,
5516 is_stored/1,
5517 is_finally_stored/1,
5518 check_all_passive/2.
5520 :- chr_option(mode,stored(+,+,+)).
5521 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5522 :- chr_type storedinfo ---> yes ; no ; maybe.
5523 :- chr_option(mode,stored_complete(+,+,+)).
5524 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5525 :- chr_option(mode,guard_list(+,+,+,+)).
5526 :- chr_option(mode,check_all_passive(+,+)).
5527 :- chr_option(type_declaration,check_all_passive(any,list)).
5529 % change yes in maybe when yes becomes passive
5530 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5531 stored(C,O,yes), stored_complete(C,RO,Yesses)
5532 <=> O < RO | NYesses is Yesses - 1,
5533 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5534 % change yes in maybe when not observed
5535 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5536 <=> O < RO |
5537 NYesses is Yesses - 1,
5538 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5540 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5541 ==> RO =< MO2 | % C2 is never stored
5542 passive(RuleNb,ID).
5547 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5549 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5550 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5551 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5553 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5554 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5555 check_all_passive(RuleNb,IDs2).
5557 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5558 check_all_passive(RuleNb,IDs).
5560 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5561 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5565 % collect the storage information
5566 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5567 <=> NO is O + 1, NYesses is Yesses + 1,
5568 stored_completing(C,NO,NYesses).
5569 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5570 <=> NO is O + 1,
5571 stored_completing(C,NO,Yesses).
5573 stored(C,O,no) \ stored_completing(C,O,Yesses)
5574 <=> stored_complete(C,O,Yesses).
5575 stored_completing(C,O,Yesses)
5576 <=> stored_complete(C,O,Yesses).
5578 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5579 O2 > O | passive(RuleNb,Id).
5581 % decide whether a constraint is stored
5582 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5583 <=> RO =< MO | fail.
5584 is_stored(C) <=> true.
5586 % decide whether a constraint is suspends after occurrences
5587 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5588 <=> RO =< MO | fail.
5589 is_finally_stored(C) <=> true.
5591 storage_analysis(Constraints) :-
5592 ( chr_pp_flag(storage_analysis,on) ->
5593 check_constraint_storages(Constraints)
5594 ;
5595 true
5596 ).
5598 check_constraint_storages([]).
5599 check_constraint_storages([C|Cs]) :-
5600 check_constraint_storage(C),
5601 check_constraint_storages(Cs).
5603 check_constraint_storage(C) :-
5604 get_max_occurrence(C,MO),
5605 check_occurrences_storage(C,1,MO).
5607 check_occurrences_storage(C,O,MO) :-
5608 ( O > MO ->
5609 stored_completing(C,1,0)
5610 ;
5611 check_occurrence_storage(C,O),
5612 NO is O + 1,
5613 check_occurrences_storage(C,NO,MO)
5614 ).
5616 check_occurrence_storage(C,O) :-
5617 get_occurrence(C,O,RuleNb,ID),
5618 ( is_passive(RuleNb,ID) ->
5619 stored(C,O,maybe)
5620 ;
5621 get_rule(RuleNb,PragmaRule),
5622 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5623 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5624 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5625 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5626 check_storage_head2(Head2,O,Heads1,Body)
5627 )
5628 ).
5630 check_storage_head1(Head,O,H1,H2,G) :-
5631 functor(Head,F,A),
5632 C = F/A,
5633 ( H1 == [Head],
5634 H2 == [],
5635 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5636 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5637 Head =.. [_|L],
5638 no_matching(L,[]) ->
5639 stored(C,O,no)
5640 ;
5641 stored(C,O,maybe)
5642 ).
5644 no_matching([],_).
5645 no_matching([X|Xs],Prev) :-
5646 var(X),
5647 \+ memberchk_eq(X,Prev),
5648 no_matching(Xs,[X|Prev]).
5650 check_storage_head2(Head,O,H1,B) :-
5651 functor(Head,F,A),
5652 C = F/A,
5653 ( %(
5654 ( H1 \== [], B == true )
5655 %;
5656 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5657 %)
5658 ->
5659 stored(C,O,maybe)
5660 ;
5661 stored(C,O,yes)
5662 ).
5664 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5666 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5667 %% ____ _ ____ _ _ _ _
5668 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5669 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5670 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5671 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5672 %% |_|
5674 constraints_code(Constraints,Clauses) :-
5675 (chr_pp_flag(reduced_indexing,on),
5676 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5677 none_suspended_on_variables
5678 ;
5679 true
5680 ),
5681 constraints_code1(Constraints,Clauses,[]).
5683 %===============================================================================
5684 :- chr_constraint constraints_code1/3.
5685 :- chr_option(mode,constraints_code1(+,+,+)).
5686 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5687 %-------------------------------------------------------------------------------
5688 constraints_code1([],L,T) <=> L = T.
5689 constraints_code1([C|RCs],L,T)
5690 <=>
5691 constraint_code(C,L,T1),
5692 constraints_code1(RCs,T1,T).
5693 %===============================================================================
5694 :- chr_constraint constraint_code/3.
5695 :- chr_option(mode,constraint_code(+,+,+)).
5696 %-------------------------------------------------------------------------------
5697 %% Generate code for a single CHR constraint
5698 constraint_code(Constraint, L, T)
5699 <=> true
5700 | ( (chr_pp_flag(debugable,on) ;
5701 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5702 ( may_trigger(Constraint) ;
5703 get_allocation_occurrence(Constraint,AO),
5704 get_max_occurrence(Constraint,MO), MO >= AO ) )
5705 ->
5706 constraint_prelude(Constraint,Clause),
5707 add_dummy_location(Clause,LocatedClause),
5708 L = [LocatedClause | L1]
5709 ;
5710 L = L1
5711 ),
5712 Id = [0],
5713 occurrences_code(Constraint,1,Id,NId,L1,L2),
5714 gen_cond_attach_clause(Constraint,NId,L2,T).
5716 %===============================================================================
5717 %% Generate prelude predicate for a constraint.
5718 %% f(...) :- f/a_0(...,Susp).
5719 constraint_prelude(F/A, Clause) :-
5720 vars_susp(A,Vars,Susp,VarsSusp),
5721 Head =.. [ F | Vars],
5722 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5723 build_head(F,A,[0],VarsSusp,Delegate),
5724 ( chr_pp_flag(debugable,on) ->
5725 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5726 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5727 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5728 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5730 ( get_constraint_type(F/A,ArgTypeList) ->
5731 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5732 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5733 ;
5734 DynamicTypeChecks = true
5735 ),
5737 Clause =
5738 ( Head :-
5739 DynamicTypeChecks,
5740 InsertGoal,
5741 InsertCall,
5742 AttachCall,
5743 Inactive,
5744 'chr debug_event'(insert(Head#Susp)),
5745 (
5746 'chr debug_event'(call(Susp)),
5747 Delegate
5748 ;
5749 'chr debug_event'(fail(Susp)), !,
5750 fail
5751 ),
5752 (
5753 'chr debug_event'(exit(Susp))
5754 ;
5755 'chr debug_event'(redo(Susp)),
5756 fail
5757 )
5758 )
5759 ; get_allocation_occurrence(F/A,0) ->
5760 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5761 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5762 Clause = ( Head :- Goal, Inactive, Delegate )
5763 ;
5764 Clause = ( Head :- Delegate )
5765 ).
5767 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5768 ( may_trigger(F/A) ->
5769 build_head(F,A,[0],VarsSusp,Delegate),
5770 ( chr_pp_flag(debugable,off) ->
5771 Goal = Delegate
5772 ;
5773 get_target_module(Mod),
5774 Goal = Mod:Delegate
5775 )
5776 ;
5777 Goal = true
5778 ).
5780 %===============================================================================
5781 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5782 :- chr_option(mode,has_active_occurrence(+)).
5783 :- chr_option(mode,has_active_occurrence(+,+)).
5784 %-------------------------------------------------------------------------------
5785 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5787 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5788 O > MO | fail.
5789 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5790 has_active_occurrence(C,O) <=>
5791 NO is O + 1,
5792 has_active_occurrence(C,NO).
5793 has_active_occurrence(C,O) <=> true.
5794 %===============================================================================
5796 gen_cond_attach_clause(F/A,Id,L,T) :-
5797 ( is_finally_stored(F/A) ->
5798 get_allocation_occurrence(F/A,AllocationOccurrence),
5799 get_max_occurrence(F/A,MaxOccurrence),
5800 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5801 ( only_ground_indexed_arguments(F/A) ->
5802 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5803 ;
5804 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5805 )
5806 ; vars_susp(A,Args,Susp,AllArgs),
5807 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5808 ),
5809 build_head(F,A,Id,AllArgs,Head),
5810 Clause = ( Head :- Body ),
5811 add_dummy_location(Clause,LocatedClause),
5812 L = [LocatedClause | T]
5813 ;
5814 L = T
5815 ).
5817 :- chr_constraint use_auxiliary_predicate/1.
5818 :- chr_option(mode,use_auxiliary_predicate(+)).
5820 :- chr_constraint use_auxiliary_predicate/2.
5821 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5823 :- chr_constraint is_used_auxiliary_predicate/1.
5824 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5826 :- chr_constraint is_used_auxiliary_predicate/2.
5827 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5830 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5832 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5834 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5836 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5838 is_used_auxiliary_predicate(P) <=> fail.
5840 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5841 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5843 is_used_auxiliary_predicate(P,C) <=> fail.
5845 %------------------------------------------------------------------------------%
5846 % Only generate import statements for actually used modules.
5847 %------------------------------------------------------------------------------%
5849 :- chr_constraint use_auxiliary_module/1.
5850 :- chr_option(mode,use_auxiliary_module(+)).
5852 :- chr_constraint is_used_auxiliary_module/1.
5853 :- chr_option(mode,is_used_auxiliary_module(+)).
5856 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5858 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5860 is_used_auxiliary_module(P) <=> fail.
5862 % only called for constraints with
5863 % at least one
5864 % non-ground indexed argument
5865 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5866 vars_susp(A,Args,Susp,AllArgs),
5867 make_suspension_continuation_goal(F/A,AllArgs,Closure),
5868 ( get_store_type(F/A,var_assoc_store(_,_)) ->
5869 Attach = true
5870 ;
5871 attach_constraint_atom(F/A,Vars,Susp,Attach)
5872 ),
5873 FTerm =.. [F|Args],
5874 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5875 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5876 ( may_trigger(F/A) ->
5877 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
5878 Goal =
5879 (
5880 ( var(Susp) ->
5881 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
5882 InsertCall,
5883 Attach
5884 ;
5885 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
5886 )
5887 )
5888 ;
5889 Goal =
5890 (
5891 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
5892 InsertCall,
5893 Attach
5894 )
5895 ).
5897 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
5898 vars_susp(A,Args,Susp,AllArgs),
5899 make_suspension_continuation_goal(F/A,AllArgs,Cont),
5900 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
5901 attach_constraint_atom(F/A,Vars,Susp,Attach)
5902 ;
5903 Attach = true
5904 ),
5905 FTerm =.. [F|Args],
5906 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5907 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
5908 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
5909 Goal =
5910 (
5911 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
5912 InsertCall
5913 )
5914 ;
5915 Goal =
5916 (
5917 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
5918 InsertCall,
5919 Attach
5920 )
5921 ).
5923 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
5924 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5925 attach_constraint_atom(FA,Vars,Susp,Attach)
5926 ;
5927 Attach = true
5928 ),
5929 insert_constraint_goal(FA,Susp,Args,InsertCall),
5930 ( chr_pp_flag(late_allocation,on) ->
5931 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
5932 ;
5933 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
5934 ).
5936 %-------------------------------------------------------------------------------
5937 :- chr_constraint occurrences_code/6.
5938 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
5939 %-------------------------------------------------------------------------------
5940 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
5941 <=> O > MO
5942 | NId = Id, L = T.
5943 occurrences_code(C,O,Id,NId,L,T)
5944 <=>
5945 occurrence_code(C,O,Id,Id1,L,L1),
5946 NO is O + 1,
5947 occurrences_code(C,NO,Id1,NId,L1,T).
5948 %-------------------------------------------------------------------------------
5949 :- chr_constraint occurrence_code/6.
5950 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
5951 %-------------------------------------------------------------------------------
5952 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
5953 <=>
5954 ( named_history(RuleNb,_,_) ->
5955 does_use_history(C,O)
5956 ;
5957 true
5958 ),
5959 NId = Id,
5960 L = T.
5961 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
5962 <=> true |
5963 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
5964 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5965 NId = Id,
5966 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
5967 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5968 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
5969 inc_id(Id,NId),
5970 ( unconditional_occurrence(C,O) ->
5971 L1 = T
5972 ;
5973 gen_alloc_inc_clause(C,O,Id,L1,T)
5974 )
5975 ).
5977 occurrence_code(C,O,_,_,_,_)
5978 <=>
5979 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
5980 %-------------------------------------------------------------------------------
5982 %% Generate code based on one removed head of a CHR rule
5983 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5984 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5985 Rule = rule(_,Head2,_,_),
5986 ( Head2 == [] ->
5987 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5988 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
5989 ;
5990 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5991 ).
5993 %% Generate code based on one persistent head of a CHR rule
5994 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5995 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5996 Rule = rule(Head1,_,_,_),
5997 ( Head1 == [] ->
5998 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5999 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6000 ;
6001 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6002 ).
6004 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6005 vars_susp(A,Vars,Susp,VarsSusp),
6006 build_head(F,A,Id,VarsSusp,Head),
6007 inc_id(Id,IncId),
6008 build_head(F,A,IncId,VarsSusp,CallHead),
6009 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6010 Clause =
6011 (
6012 Head :-
6013 ConditionalAlloc,
6014 CallHead
6015 ),
6016 add_dummy_location(Clause,LocatedClause),
6017 L = [LocatedClause|T].
6019 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6020 get_allocation_occurrence(FA,AO),
6021 ( chr_pp_flag(debugable,off), O == AO ->
6022 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6023 ( may_trigger(FA) ->
6024 Goal = (var(Susp) -> Goal0 ; true)
6025 ;
6026 Goal = Goal0
6027 )
6028 ;
6029 Goal = true
6030 ).
6032 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6033 get_allocation_occurrence(FA,AO),
6034 ( chr_pp_flag(debugable,off), O < AO ->
6035 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6036 ( may_trigger(FA) ->
6037 Goal = (var(Susp) -> Goal0 ; true)
6038 ;
6039 Goal = Goal0
6040 )
6041 ;
6042 Goal = true
6043 ).
6045 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6047 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6048 %
6049 % Reorders guard goals with respect to partner constraint retrieval goals and
6050 % active constraint. Returns combined partner retrieval + guard goal.
6052 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6053 ( chr_pp_flag(guard_via_reschedule,on) ->
6054 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6055 list2conj(ScheduleSkeleton,GoalSkeleton)
6056 ;
6057 length(Retrievals,RL), length(LookupSkeleton,RL),
6058 length(GuardList,GL), length(GuardListSkeleton,GL),
6059 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6060 list2conj(GoalListSkeleton,GoalSkeleton)
6061 ).
6062 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6063 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6064 initialize_unit_dictionary(ActiveHead,Dict),
6065 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6066 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6067 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6068 dependency_reorder(Units,NUnits),
6069 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6070 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6071 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6073 wrap_in_functor(Functor,X,Term) :-
6074 Term =.. [Functor,X].
6076 wrappedunits2lists([],[],[],[]).
6077 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6078 Ss = [GoalCopy|TSs],
6079 ( WrappedGoal = lookup(Goal) ->
6080 Ls = [GoalCopy|TLs],
6081 Gs = TGs
6082 ; WrappedGoal = guard(Goal) ->
6083 Gs = [N-GoalCopy|TGs],
6084 Ls = TLs
6085 ),
6086 wrappedunits2lists(Units,TGs,TLs,TSs).
6088 guard_splitting(Rule,SplitGuardList) :-
6089 Rule = rule(H1,H2,Guard,_),
6090 append(H1,H2,Heads),
6091 conj2list(Guard,GuardList),
6092 term_variables(Heads,HeadVars),
6093 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6094 append(GuardPrefix,[RestGuard],SplitGuardList),
6095 term_variables(RestGuardList,GuardVars1),
6096 % variables that are declared to be ground don't need to be locked
6097 ground_vars(Heads,GroundVars),
6098 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6099 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6100 ( chr_pp_flag(guard_locks,on),
6101 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6102 once(pairup(Locks,Unlocks,LocksUnlocks))
6103 ;
6104 Locks = [],
6105 Unlocks = []
6106 ),
6107 list2conj(Locks,LockPhase),
6108 list2conj(Unlocks,UnlockPhase),
6109 list2conj(RestGuardList,RestGuard1),
6110 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6112 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6113 Rule = rule(_,_,_,Body),
6114 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6115 my_term_copy(Body,VarDict2,BodyCopy).
6118 split_off_simple_guard_new([],_,[],[]).
6119 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6120 ( simple_guard_new(G,VarDict) ->
6121 S = [G|Ss],
6122 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6123 ;
6124 S = [],
6125 C = [G|Gs]
6126 ).
6128 % simple guard: cheap and benign (does not bind variables)
6129 simple_guard_new(G,Vars) :-
6130 builtin_binds_b(G,BoundVars),
6131 \+ (( member(V,BoundVars),
6132 memberchk_eq(V,Vars)
6133 )).
6135 dependency_reorder(Units,NUnits) :-
6136 dependency_reorder(Units,[],NUnits).
6138 dependency_reorder([],Acc,Result) :-
6139 reverse(Acc,Result).
6141 dependency_reorder([Unit|Units],Acc,Result) :-
6142 Unit = unit(_GID,_Goal,Type,GIDs),
6143 ( Type == fixed ->
6144 NAcc = [Unit|Acc]
6145 ;
6146 dependency_insert(Acc,Unit,GIDs,NAcc)
6147 ),
6148 dependency_reorder(Units,NAcc,Result).
6150 dependency_insert([],Unit,_,[Unit]).
6151 dependency_insert([X|Xs],Unit,GIDs,L) :-
6152 X = unit(GID,_,_,_),
6153 ( memberchk(GID,GIDs) ->
6154 L = [Unit,X|Xs]
6155 ;
6156 L = [X | T],
6157 dependency_insert(Xs,Unit,GIDs,T)
6158 ).
6160 build_units(Retrievals,Guard,InitialDict,Units) :-
6161 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6162 build_guard_units(Guard,N,Dict,Tail).
6164 build_retrieval_units([],N,N,Dict,Dict,L,L).
6165 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6166 term_variables(U,Vs),
6167 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6168 L = [unit(N,U,fixed,GIDs)|L1],
6169 N1 is N + 1,
6170 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6172 initialize_unit_dictionary(Term,Dict) :-
6173 term_variables(Term,Vars),
6174 pair_all_with(Vars,0,Dict).
6176 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6177 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6178 ( lookup_eq(Dict,V,GID) ->
6179 ( (GID == This ; memberchk(GID,GIDs) ) ->
6180 GIDs1 = GIDs
6181 ;
6182 GIDs1 = [GID|GIDs]
6183 ),
6184 Dict1 = Dict
6185 ;
6186 Dict1 = [V - This|Dict],
6187 GIDs1 = GIDs
6188 ),
6189 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6191 build_guard_units(Guard,N,Dict,Units) :-
6192 ( Guard = [Goal] ->
6193 Units = [unit(N,Goal,fixed,[])]
6194 ; Guard = [Goal|Goals] ->
6195 term_variables(Goal,Vs),
6196 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6197 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6198 N1 is N + 1,
6199 build_guard_units(Goals,N1,NDict,RUnits)
6200 ).
6202 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6203 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6204 ( lookup_eq(Dict,V,GID) ->
6205 ( (GID == This ; memberchk(GID,GIDs) ) ->
6206 GIDs1 = GIDs
6207 ;
6208 GIDs1 = [GID|GIDs]
6209 ),
6210 Dict1 = [V - This|Dict]
6211 ;
6212 Dict1 = [V - This|Dict],
6213 GIDs1 = GIDs
6214 ),
6215 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6217 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6220 %% ____ _ ____ _ _
6221 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6222 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6223 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6224 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6225 %%
6226 %% _ _ _ ___ __
6227 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6228 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6229 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6230 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6231 %% |_|
6232 :- chr_constraint
6233 functional_dependency/4,
6234 get_functional_dependency/4.
6236 :- chr_option(mode,functional_dependency(+,+,?,?)).
6237 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6239 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6240 <=>
6241 RuleNb > 1, AO > O
6242 |
6243 functional_dependency(C,1,Pattern,Key).
6245 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6246 <=>
6247 RuleNb2 >= RuleNb1
6248 |
6249 QPattern = Pattern, QKey = Key.
6250 get_functional_dependency(_,_,_,_)
6251 <=>
6252 fail.
6254 functional_dependency_analysis(Rules) :-
6255 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6256 functional_dependency_analysis_main(Rules)
6257 ;
6258 true
6259 ).
6261 functional_dependency_analysis_main([]).
6262 functional_dependency_analysis_main([PRule|PRules]) :-
6263 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6264 functional_dependency(C,RuleNb,Pattern,Key)
6265 ;
6266 true
6267 ),
6268 functional_dependency_analysis_main(PRules).
6270 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6271 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6272 Rule = rule(H1,H2,Guard,_),
6273 ( H1 = [C1],
6274 H2 = [C2] ->
6275 true
6276 ; H1 = [C1,C2],
6277 H2 == [] ->
6278 true
6279 ),
6280 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6281 term_variables(C1,Vs),
6282 \+ (
6283 member(V1,Vs),
6284 lookup_eq(List,V1,V2),
6285 memberchk_eq(V2,Vs)
6286 ),
6287 select_pragma_unique_variables(Vs,List,Key1),
6288 copy_term_nat(C1-Key1,Pattern-Key),
6289 functor(C1,F,A).
6291 select_pragma_unique_variables([],_,[]).
6292 select_pragma_unique_variables([V|Vs],List,L) :-
6293 ( lookup_eq(List,V,_) ->
6294 L = T
6295 ;
6296 L = [V|T]
6297 ),
6298 select_pragma_unique_variables(Vs,List,T).
6300 % depends on functional dependency analysis
6301 % and shape of rule: C1 \ C2 <=> true.
6302 set_semantics_rules(Rules) :-
6303 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6304 set_semantics_rules_main(Rules)
6305 ;
6306 true
6307 ).
6309 set_semantics_rules_main([]).
6310 set_semantics_rules_main([R|Rs]) :-
6311 set_semantics_rule_main(R),
6312 set_semantics_rules_main(Rs).
6314 set_semantics_rule_main(PragmaRule) :-
6315 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6316 ( Rule = rule([C1],[C2],true,_),
6317 IDs = ids([ID1],[ID2]),
6318 \+ is_passive(RuleNb,ID1),
6319 functor(C1,F,A),
6320 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6321 copy_term_nat(Pattern-Key,C1-Key1),
6322 copy_term_nat(Pattern-Key,C2-Key2),
6323 Key1 == Key2 ->
6324 passive(RuleNb,ID2)
6325 ;
6326 true
6327 ).
6329 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6330 \+ any_passive_head(RuleNb),
6331 variable_replacement(C1-C2,C2-C1,List),
6332 copy_with_variable_replacement(G,OtherG,List),
6333 negate_b(G,NotG),
6334 once(entails_b(NotG,OtherG)).
6336 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6337 % where C1 and C2 are symmteric constraints
6338 symmetry_analysis(Rules) :-
6339 ( chr_pp_flag(check_unnecessary_active,off) ->
6340 true
6341 ;
6342 symmetry_analysis_main(Rules)
6343 ).
6345 symmetry_analysis_main([]).
6346 symmetry_analysis_main([R|Rs]) :-
6347 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6348 Rule = rule(H1,H2,_,_),
6349 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6350 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6351 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6352 ;
6353 true
6354 ),
6355 symmetry_analysis_main(Rs).
6357 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6358 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6359 ( \+ is_passive(RuleNb,ID),
6360 member2(PreHs,PreIDs,PreH-PreID),
6361 \+ is_passive(RuleNb,PreID),
6362 variable_replacement(PreH,H,List),
6363 copy_with_variable_replacement(Rule,Rule2,List),
6364 identical_guarded_rules(Rule,Rule2) ->
6365 passive(RuleNb,ID)
6366 ;
6367 true
6368 ),
6369 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6371 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6372 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6373 ( \+ is_passive(RuleNb,ID),
6374 member2(PreHs,PreIDs,PreH-PreID),
6375 \+ is_passive(RuleNb,PreID),
6376 variable_replacement(PreH,H,List),
6377 copy_with_variable_replacement(Rule,Rule2,List),
6378 identical_rules(Rule,Rule2) ->
6379 passive(RuleNb,ID)
6380 ;
6381 true
6382 ),
6383 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6388 %% ____ _ _ _ __ _ _ _
6389 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6390 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6391 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6392 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6393 %% |_|
6395 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6396 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6397 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6398 build_head(F,A,Id,HeadVars,ClauseHead),
6399 get_constraint_mode(F/A,Mode),
6400 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6403 guard_splitting(Rule,GuardList0),
6404 ( is_stored_in_guard(F/A, RuleNb) ->
6405 GuardList = [Hole1|GuardList0]
6406 ;
6407 GuardList = GuardList0
6408 ),
6409 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6411 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6413 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6415 ( is_stored_in_guard(F/A, RuleNb) ->
6416 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6417 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6418 GuardCopyList = [Hole1Copy|_],
6419 Hole1Copy = (Allocation, Attachment)
6420 ;
6421 true
6422 ),
6425 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6426 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6428 ( chr_pp_flag(debugable,on) ->
6429 Rule = rule(_,_,Guard,Body),
6430 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6431 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6432 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6433 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6434 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6435 ;
6436 Cut = ActualCut
6437 ),
6438 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6439 Clause = ( ClauseHead :-
6440 FirstMatching,
6441 RescheduledTest,
6442 Cut,
6443 SuspsDetachments,
6444 SuspDetachment,
6445 BodyCopy
6446 ),
6447 add_location(Clause,RuleNb,LocatedClause),
6448 L = [LocatedClause | T].
6450 add_location(Clause,RuleNb,NClause) :-
6451 ( chr_pp_flag(line_numbers,on) ->
6452 get_chr_source_file(File),
6453 get_line_number(RuleNb,LineNb),
6454 NClause = '$source_location'(File,LineNb):Clause
6455 ;
6456 NClause = Clause
6457 ).
6459 add_dummy_location(Clause,NClause) :-
6460 ( chr_pp_flag(line_numbers,on) ->
6461 get_chr_source_file(File),
6462 NClause = '$source_location'(File,1):Clause
6463 ;
6464 NClause = Clause
6465 ).
6466 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6467 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6468 %
6469 % Return goal matching newly introduced variables with variables in
6470 % previously looked-up heads.
6471 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6472 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6473 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6475 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6476 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6477 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6478 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6479 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6480 list2conj(GoalList,Goal).
6482 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6483 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6484 ( var(Arg) ->
6485 ( lookup_eq(VarDict,Arg,OtherVar) ->
6486 ( Mode = (+) ->
6487 ( memberchk_eq(Arg,GroundVars) ->
6488 GoalList = [Var = OtherVar | RestGoalList],
6489 GroundVars1 = GroundVars
6490 ;
6491 GoalList = [Var == OtherVar | RestGoalList],
6492 GroundVars1 = [Arg|GroundVars]
6493 )
6494 ;
6495 GoalList = [Var == OtherVar | RestGoalList],
6496 GroundVars1 = GroundVars
6497 ),
6498 VarDict1 = VarDict
6499 ;
6500 VarDict1 = [Arg-Var | VarDict],
6501 GoalList = RestGoalList,
6502 ( Mode = (+) ->
6503 GroundVars1 = [Arg|GroundVars]
6504 ;
6505 GroundVars1 = GroundVars
6506 )
6507 ),
6508 Pairs = Rest,
6509 RestModes = Modes
6510 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6511 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6512 GoalList = [Goal|RestGoalList],
6513 VarDict = VarDict1,
6514 GroundVars1 = GroundVars,
6515 Pairs = Rest,
6516 RestModes = Modes
6517 ; atomic(Arg) ->
6518 ( Mode = (+) ->
6519 GoalList = [ Var = Arg | RestGoalList]
6520 ;
6521 GoalList = [ Var == Arg | RestGoalList]
6522 ),
6523 VarDict = VarDict1,
6524 GroundVars1 = GroundVars,
6525 Pairs = Rest,
6526 RestModes = Modes
6527 ; Mode == (+), is_ground(GroundVars,Arg) ->
6528 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6529 GoalList = [ Var = ArgCopy | RestGoalList],
6530 VarDict = VarDict1,
6531 GroundVars1 = GroundVars,
6532 Pairs = Rest,
6533 RestModes = Modes
6534 ; Arg =.. [_|Args],
6535 functor(Arg,Fct,N),
6536 functor(Term,Fct,N),
6537 Term =.. [_|Vars],
6538 ( Mode = (+) ->
6539 GoalList = [ Var = Term | RestGoalList ]
6540 ;
6541 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6542 ),
6543 pairup(Args,Vars,NewPairs),
6544 append(NewPairs,Rest,Pairs),
6545 replicate(N,Mode,NewModes),
6546 append(NewModes,Modes,RestModes),
6547 VarDict1 = VarDict,
6548 GroundVars1 = GroundVars
6549 ),
6550 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6552 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6553 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6554 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6555 add_heads_types([],VarTypes,VarTypes).
6556 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6557 add_head_types(Head,VarTypes,VarTypes1),
6558 add_heads_types(Heads,VarTypes1,NVarTypes).
6560 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6561 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6562 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6563 add_head_types(Head,VarTypes,NVarTypes) :-
6564 functor(Head,F,A),
6565 get_constraint_type_det(F/A,ArgTypes),
6566 Head =.. [_|Args],
6567 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6569 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6570 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6571 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6572 add_args_types([],[],VarTypes,VarTypes).
6573 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6574 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6575 add_args_types(Args,Types,VarTypes1,NVarTypes).
6577 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6578 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6579 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6580 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6581 ( var(Term) ->
6582 ( lookup_eq(VarTypes,Term,_) ->
6583 NVarTypes = VarTypes
6584 ;
6585 NVarTypes = [Term-Type|VarTypes]
6586 )
6587 ; ground(Term) ->
6588 NVarTypes = VarTypes
6589 ; % TODO improve approximation!
6590 term_variables(Term,Vars),
6591 length(Vars,VarNb),
6592 replicate(VarNb,any,Types),
6593 add_args_types(Vars,Types,VarTypes,NVarTypes)
6594 ).
6598 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6599 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6600 %
6601 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6602 add_heads_ground_variables([],GroundVars,GroundVars).
6603 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6604 add_head_ground_variables(Head,GroundVars,GroundVars1),
6605 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6607 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6608 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6609 %
6610 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6611 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6612 functor(Head,F,A),
6613 get_constraint_mode(F/A,ArgModes),
6614 Head =.. [_|Args],
6615 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6618 add_arg_ground_variables([],[],GroundVars,GroundVars).
6619 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6620 ( Mode == (+) ->
6621 term_variables(Arg,Vars),
6622 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6623 ;
6624 GroundVars = GroundVars1
6625 ),
6626 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6628 add_var_ground_variables([],GroundVars,GroundVars).
6629 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6630 ( memberchk_eq(Var,GroundVars) ->
6631 GroundVars1 = GroundVars
6632 ;
6633 GroundVars1 = [Var|GroundVars]
6634 ),
6635 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6636 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6637 %% is_ground(+GroundVars,+Term) is semidet.
6638 %
6639 % Determine whether =Term= is always ground.
6640 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6641 is_ground(GroundVars,Term) :-
6642 ( ground(Term) ->
6643 true
6644 ; compound(Term) ->
6645 Term =.. [_|Args],
6646 maplist(is_ground(GroundVars),Args)
6647 ;
6648 memberchk_eq(Term,GroundVars)
6649 ).
6651 %% check_ground(+GroundVars,+Term,-Goal) is det.
6652 %
6653 % Return runtime check to see whether =Term= is ground.
6654 check_ground(GroundVars,Term,Goal) :-
6655 term_variables(Term,Variables),
6656 check_ground_variables(Variables,GroundVars,Goal).
6658 check_ground_variables([],_,true).
6659 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6660 ( memberchk_eq(Var,GroundVars) ->
6661 check_ground_variables(Vars,GroundVars,Goal)
6662 ;
6663 Goal = (ground(Var), RGoal),
6664 check_ground_variables(Vars,GroundVars,RGoal)
6665 ).
6667 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6668 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6670 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6671 ( Heads = [_|_] ->
6672 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6673 ;
6674 GoalList = [],
6675 Susps = [],
6676 VarDict = NVarDict,
6677 GroundVars = NGroundVars
6678 ).
6680 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6681 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6682 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6683 functor(H,F,A),
6684 head_info(H,A,Vars,_,_,Pairs),
6685 get_store_type(F/A,StoreType),
6686 ( StoreType == default ->
6687 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6688 delay_phase_end(validate_store_type_assumptions,
6689 ( static_suspension_term(F/A,Suspension),
6690 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6691 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6692 )
6693 ),
6694 % create_get_mutable_ref(active,State,GetMutable),
6695 get_constraint_mode(F/A,Mode),
6696 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6697 NPairs = Pairs,
6698 sbag_member_call(Susp,VarSusps,Sbag),
6699 ExistentialLookup = (
6700 ViaGoal,
6701 Sbag,
6702 Susp = Suspension, % not inlined
6703 GetState
6704 )
6705 ;
6706 delay_phase_end(validate_store_type_assumptions,
6707 ( static_suspension_term(F/A,Suspension),
6708 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6709 )
6710 ),
6711 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6712 get_constraint_mode(F/A,Mode),
6713 filter_mode(NPairs,Pairs,Mode,NMode),
6714 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6715 ),
6716 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6717 append(NPairs,VarDict1,DA_), % order important here
6718 translate(GroundVars1,DA_,GroundVarsA),
6719 translate(GroundVars1,VarDict1,GroundVarsB),
6720 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6721 Goal =
6722 (
6723 ExistentialLookup,
6724 DiffSuspGoals,
6725 MatchingGoal2
6726 ),
6727 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6729 inline_matching_goal(A==B,true,GVA,GVB) :-
6730 memberchk_eq(A,GVA),
6731 memberchk_eq(B,GVB),
6732 A=B, !.
6734 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6735 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6736 inline_matching_goal(A,A2,GVA,GVB),
6737 inline_matching_goal(B,B2,GVA,GVB).
6738 inline_matching_goal(X,X,_,_).
6741 filter_mode([],_,_,[]).
6742 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6743 ( Var == V ->
6744 Modes = [M|MT],
6745 filter_mode(Rest,R,Ms,MT)
6746 ;
6747 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6748 ).
6750 check_unique_keys([],_).
6751 check_unique_keys([V|Vs],Dict) :-
6752 lookup_eq(Dict,V,_),
6753 check_unique_keys(Vs,Dict).
6755 % Generates tests to ensure the found constraint differs from previously found constraints
6756 % TODO: detect more cases where constraints need be different
6757 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6758 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6759 list2conj(DiffSuspGoalList,DiffSuspGoals).
6761 different_from_other_susps_(_,[],_,_,[]) :- !.
6762 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6763 ( functor(Head,F,A), functor(PreHead,F,A),
6764 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6765 \+ \+ PreHeadCopy = HeadCopy ->
6767 List = [Susp \== PreSusp | Tail]
6768 ;
6769 List = Tail
6770 ),
6771 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6773 % passive_head_via(in,in,in,in,out,out,out) :-
6774 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6775 functor(Head,F,A),
6776 get_constraint_index(F/A,Pos),
6777 common_variables(Head,PrevHeads,CommonVars),
6778 global_list_store_name(F/A,Name),
6779 GlobalGoal = nb_getval(Name,AllSusps),
6780 get_constraint_mode(F/A,ArgModes),
6781 ( Vars == [] ->
6782 Goal = GlobalGoal
6783 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6784 translate([CommonVar],VarDict,[Var]),
6785 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6786 Goal = AttrGoal
6787 ;
6788 translate(CommonVars,VarDict,Vars),
6789 add_heads_types(PrevHeads,[],TypeDict),
6790 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6791 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6792 Goal =
6793 ( ViaGoal ->
6794 AttrGoal
6795 ;
6796 GlobalGoal
6797 )
6798 ).
6800 common_variables(T,Ts,Vs) :-
6801 term_variables(T,V1),
6802 term_variables(Ts,V2),
6803 intersect_eq(V1,V2,Vs).
6805 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6806 get_target_module(Mod),
6807 ( Vars = [A] ->
6808 lookup_eq(TypeDict,A,Type),
6809 ( atomic_type(Type) ->
6810 ViaGoal = var(A),
6811 A = V
6812 ;
6813 ViaGoal = 'chr newvia_1'(A,V)
6814 )
6815 ; Vars = [A,B] ->
6816 ViaGoal = 'chr newvia_2'(A,B,V)
6817 ;
6818 ViaGoal = 'chr newvia'(Vars,V)
6819 ),
6820 AttrGoal =
6821 ( get_attr(V,Mod,TSusps),
6822 TSuspsEqSusps % TSusps = Susps
6823 ),
6824 get_max_constraint_index(N),
6825 ( N == 1 ->
6826 TSuspsEqSusps = true, % TSusps = Susps
6827 AllSusps = TSusps
6828 ;
6829 get_constraint_index(FA,Pos),
6830 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6831 ).
6832 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6833 get_target_module(Mod),
6834 AttrGoal =
6835 ( get_attr(Var,Mod,TSusps),
6836 TSuspsEqSusps % TSusps = Susps
6837 ),
6838 get_max_constraint_index(N),
6839 ( N == 1 ->
6840 TSuspsEqSusps = true, % TSusps = Susps
6841 AllSusps = TSusps
6842 ;
6843 get_constraint_index(FA,Pos),
6844 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6845 ).
6847 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6848 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6849 list2conj(GuardCopyList,GuardCopy).
6851 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6852 Rule = rule(H,_,Guard,Body),
6853 conj2list(Guard,GuardList),
6854 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6855 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6857 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6858 term_variables(RestGuardList,GuardVars),
6859 term_variables(RestGuardListCopyCore,GuardCopyVars),
6860 % variables that are declared to be ground don't need to be locked
6861 ground_vars(H,GroundVars),
6862 list_difference_eq(GuardVars,GroundVars,GuardVars_),
6863 ( chr_pp_flag(guard_locks,on),
6864 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6865 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
6866 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
6867 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
6868 ),
6869 LocksUnlocks) ->
6870 once(pairup(Locks,Unlocks,LocksUnlocks))
6871 ;
6872 Locks = [],
6873 Unlocks = []
6874 ),
6875 list2conj(Locks,LockPhase),
6876 list2conj(Unlocks,UnlockPhase),
6877 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
6878 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
6879 my_term_copy(Body,VarDict2,BodyCopy).
6882 split_off_simple_guard([],_,[],[]).
6883 split_off_simple_guard([G|Gs],VarDict,S,C) :-
6884 ( simple_guard(G,VarDict) ->
6885 S = [G|Ss],
6886 split_off_simple_guard(Gs,VarDict,Ss,C)
6887 ;
6888 S = [],
6889 C = [G|Gs]
6890 ).
6892 % simple guard: cheap and benign (does not bind variables)
6893 simple_guard(G,VarDict) :-
6894 binds_b(G,Vars),
6895 \+ (( member(V,Vars),
6896 lookup_eq(VarDict,V,_)
6897 )).
6899 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
6900 functor(Head,F,A),
6901 C = F/A,
6902 ( is_stored(C) ->
6903 (
6904 (
6905 Id == [0], chr_pp_flag(store_in_guards, off)
6906 ;
6907 ( get_allocation_occurrence(C,AO),
6908 get_max_occurrence(C,MO),
6909 MO < AO )
6910 ),
6911 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
6912 SuspDetachment = true
6913 ;
6914 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
6915 ( chr_pp_flag(late_allocation,on) ->
6916 SuspDetachment =
6917 ( var(Susp) ->
6918 true
6919 ;
6920 UnCondSuspDetachment
6921 )
6922 ;
6923 SuspDetachment = UnCondSuspDetachment
6924 )
6925 )
6926 ;
6927 SuspDetachment = true
6928 ).
6930 partner_constraint_detachments([],[],_,true).
6931 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
6932 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
6933 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
6935 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
6936 functor(Head,F,A),
6937 C = F/A,
6938 ( is_stored(C) ->
6939 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
6940 ( chr_pp_flag(debugable,on) ->
6941 DebugEvent = 'chr debug_event'(remove(Susp))
6942 ;
6943 DebugEvent = true
6944 ),
6945 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
6946 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
6947 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
6948 detach_constraint_atom(C,Vars,Susp,Detach)
6949 ;
6950 Detach = true
6951 )
6952 ;
6953 SuspDetachment = true
6954 ).
6956 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6959 %% ____ _ _ _ _
6960 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
6961 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
6962 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
6963 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
6964 %% |_| |___/
6966 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
6967 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
6968 Rule = rule(_Heads,Heads2,Guard,Body),
6970 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
6971 get_constraint_mode(F/A,Mode),
6972 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6974 build_head(F,A,Id,HeadVars,ClauseHead),
6976 append(RestHeads,Heads2,Heads),
6977 append(OtherIDs,Heads2IDs,IDs),
6978 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
6980 guard_splitting(Rule,GuardList0),
6981 ( is_stored_in_guard(F/A, RuleNb) ->
6982 GuardList = [Hole1|GuardList0]
6983 ;
6984 GuardList = GuardList0
6985 ),
6986 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6988 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6989 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
6991 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6993 ( is_stored_in_guard(F/A, RuleNb) ->
6994 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6995 GuardCopyList = [Hole1Copy|_],
6996 Hole1Copy = Attachment
6997 ;
6998 true
6999 ),
7001 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7002 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7003 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7005 ( chr_pp_flag(debugable,on) ->
7006 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7007 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7008 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7009 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7010 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7011 instrument_goal((!),DebugTry,DebugApply,Cut)
7012 ;
7013 Cut = (!)
7014 ),
7016 Clause = ( ClauseHead :-
7017 FirstMatching,
7018 RescheduledTest,
7019 Cut,
7020 SuspsDetachments,
7021 SuspDetachment,
7022 BodyCopy
7023 ),
7024 add_location(Clause,RuleNb,LocatedClause),
7025 L = [LocatedClause | T].
7027 split_by_ids([],[],_,[],[]).
7028 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7029 ( memberchk_eq(I,I1s) ->
7030 S1s = [S | R1s],
7031 S2s = R2s
7032 ;
7033 S1s = R1s,
7034 S2s = [S | R2s]
7035 ),
7036 split_by_ids(Is,Ss,I1s,R1s,R2s).
7038 split_by_ids([],[],_,[],[],[],[]).
7039 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7040 ( memberchk_eq(I,I1s) ->
7041 S1s = [S | R1s],
7042 SI1s = [I|RSI1s],
7043 S2s = R2s,
7044 SI2s = RSI2s
7045 ;
7046 S1s = R1s,
7047 SI1s = RSI1s,
7048 S2s = [S | R2s],
7049 SI2s = [I|RSI2s]
7050 ),
7051 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7052 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7055 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7056 %% ____ _ _ _ ____
7057 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7058 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7059 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7060 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7061 %% |_| |___/
7063 %% Genereate prelude + worker predicate
7064 %% prelude calls worker
7065 %% worker iterates over one type of removed constraints
7066 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7067 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7068 Rule = rule(Heads1,_,Guard,Body),
7069 append(Heads1,RestHeads2,Heads),
7070 append(IDs1,RestIDs,IDs),
7071 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7072 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7073 extend_id(Id,Id1),
7074 ( memberchk_eq(NID,IDs2) ->
7075 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7076 ;
7077 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7078 ),
7079 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
7080 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7082 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
7083 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7084 Heads = [Head|RHeads],
7085 inc_id(Id,Id1),
7086 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
7087 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
7088 ( memberchk_eq(ID,IDs2) ->
7089 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7090 ;
7091 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7092 ).
7094 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7095 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7096 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7097 build_head(F,A,Id1,VarsSusp,ClauseHead),
7098 get_constraint_mode(F/A,Mode),
7099 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7101 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7103 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7105 extend_id(Id1,DelegateId),
7106 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7107 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7108 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
7110 PreludeClause =
7111 ( ClauseHead :-
7112 FirstMatching,
7113 ModConstraintsGoal,
7114 !,
7115 ConstraintAllocationGoal,
7116 Delegate
7117 ),
7118 add_dummy_location(PreludeClause,LocatedPreludeClause),
7119 L = [LocatedPreludeClause|T].
7121 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7122 Term =.. [_|Args],
7123 delegate_variables(Term,Terms,VarDict,Args,Vars).
7125 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7126 term_variables(PrevTerms,PrevVars),
7127 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7129 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7130 term_variables(Term,V1),
7131 term_variables(Terms,V2),
7132 intersect_eq(V1,V2,V3),
7133 list_difference_eq(V3,PrevVars,V4),
7134 translate(V4,VarDict,Vars).
7137 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7138 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7139 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7140 Rule = rule(_,_,Guard,Body),
7141 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7143 gen_var(OtherSusp),
7144 gen_var(OtherSusps),
7146 functor(CurrentHead,OtherF,OtherA),
7147 gen_vars(OtherA,OtherVars),
7148 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7149 get_constraint_mode(OtherF/OtherA,Mode),
7150 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7152 delay_phase_end(validate_store_type_assumptions,
7153 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7154 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7155 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7156 )
7157 ),
7158 % create_get_mutable_ref(active,State,GetMutable),
7159 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7160 CurrentSuspTest = (
7161 OtherSusp = OtherSuspension,
7162 GetState,
7163 DiffSuspGoals,
7164 FirstMatching
7165 ),
7167 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7168 build_head(F,A,Id,ClauseVars,ClauseHead),
7170 guard_splitting(Rule,GuardList0),
7171 ( is_stored_in_guard(F/A, RuleNb) ->
7172 GuardList = [Hole1|GuardList0]
7173 ;
7174 GuardList = GuardList0
7175 ),
7176 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7178 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7179 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7180 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7182 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7184 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7185 build_head(F,A,Id,RecursiveVars,RecursiveCall),
7186 RecursiveVars2 = [[]|PreVarsAndSusps],
7187 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
7189 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7190 ( is_stored_in_guard(F/A, RuleNb) ->
7191 GuardCopyList = [GuardAttachment|_] % once( ) ??
7192 ;
7193 true
7194 ),
7196 ( is_observed(F/A,O) ->
7197 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7198 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7199 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7200 ;
7201 Attachment = true,
7202 ConditionalRecursiveCall = RecursiveCall,
7203 ConditionalRecursiveCall2 = RecursiveCall2
7204 ),
7206 ( chr_pp_flag(debugable,on) ->
7207 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7208 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7209 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7210 ;
7211 DebugTry = true,
7212 DebugApply = true
7213 ),
7215 ( is_stored_in_guard(F/A, RuleNb) ->
7216 GuardAttachment = Attachment,
7217 BodyAttachment = true
7218 ;
7219 GuardAttachment = true,
7220 BodyAttachment = Attachment % will be true if not observed at all
7221 ),
7223 ( member(unique(ID1,UniqueKeys), Pragmas),
7224 check_unique_keys(UniqueKeys,VarDict) ->
7225 Clause =
7226 ( ClauseHead :-
7227 ( CurrentSuspTest ->
7228 ( RescheduledTest,
7229 DebugTry ->
7230 DebugApply,
7231 Susps1Detachments,
7232 BodyAttachment,
7233 BodyCopy,
7234 ConditionalRecursiveCall2
7235 ;
7236 RecursiveCall2
7237 )
7238 ;
7239 RecursiveCall
7240 )
7241 )
7242 ;
7243 Clause =
7244 ( ClauseHead :-
7245 ( CurrentSuspTest,
7246 RescheduledTest,
7247 DebugTry ->
7248 DebugApply,
7249 Susps1Detachments,
7250 BodyAttachment,
7251 BodyCopy,
7252 ConditionalRecursiveCall
7253 ;
7254 RecursiveCall
7255 )
7256 )
7257 ),
7258 add_location(Clause,RuleNb,LocatedClause),
7259 L = [LocatedClause | T].
7261 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7262 ( may_trigger(FA) ->
7263 does_use_field(FA,generation),
7264 delay_phase_end(validate_store_type_assumptions,
7265 ( static_suspension_term(FA,Suspension),
7266 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7267 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7268 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7269 )
7270 )
7271 ;
7272 delay_phase_end(validate_store_type_assumptions,
7273 ( static_suspension_term(FA,Suspension),
7274 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7275 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7276 )
7277 ),
7278 GetGeneration = true
7279 ),
7280 ConditionalCall =
7281 ( Susp = Suspension,
7282 GetState,
7283 GetGeneration ->
7284 UpdateState,
7285 Call
7286 ;
7287 true
7288 ).
7290 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7294 %% ____ _ _
7295 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7296 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7297 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7298 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7299 %% |_| |___/
7301 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7302 ( RestHeads == [] ->
7303 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7304 ;
7305 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7306 ).
7307 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7308 %% Single headed propagation
7309 %% everything in a single clause
7310 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7311 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7312 build_head(F,A,Id,VarsSusp,ClauseHead),
7314 inc_id(Id,NextId),
7315 build_head(F,A,NextId,VarsSusp,NextHead),
7317 get_constraint_mode(F/A,Mode),
7318 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7319 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7321 % - recursive call -
7322 RecursiveCall = NextHead,
7324 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7325 ActualCut = true
7326 ;
7327 ActualCut = !
7328 ),
7330 Rule = rule(_,_,Guard,Body),
7331 ( chr_pp_flag(debugable,on) ->
7332 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7333 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7334 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7335 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7336 ;
7337 Cut = ActualCut
7338 ),
7339 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7340 use_auxiliary_predicate(novel_production),
7341 use_auxiliary_predicate(extend_history),
7342 does_use_history(F/A,O),
7343 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7345 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7346 ( HistoryIDs == [] ->
7347 empty_named_history_novel_production(HistoryName,NovelProduction),
7348 empty_named_history_extend_history(HistoryName,ExtendHistory)
7349 ;
7350 Tuple = HistoryName
7351 )
7352 ;
7353 Tuple = RuleNb
7354 ),
7356 ( var(NovelProduction) ->
7357 NovelProduction = '$novel_production'(Susp,Tuple),
7358 ExtendHistory = '$extend_history'(Susp,Tuple)
7359 ;
7360 true
7361 ),
7363 ( is_observed(F/A,O) ->
7364 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7365 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7366 ;
7367 Attachment = true,
7368 ConditionalRecursiveCall = RecursiveCall
7369 )
7370 ;
7371 Allocation = true,
7372 NovelProduction = true,
7373 ExtendHistory = true,
7375 ( is_observed(F/A,O) ->
7376 get_allocation_occurrence(F/A,AllocO),
7377 ( O == AllocO ->
7378 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7379 Generation = 0
7380 ; % more room for improvement?
7381 Attachment = (Attachment1, Attachment2),
7382 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7383 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7384 ),
7385 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7386 ;
7387 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7388 ConditionalRecursiveCall = RecursiveCall
7389 )
7390 ),
7392 ( is_stored_in_guard(F/A, RuleNb) ->
7393 GuardAttachment = Attachment,
7394 BodyAttachment = true
7395 ;
7396 GuardAttachment = true,
7397 BodyAttachment = Attachment % will be true if not observed at all
7398 ),
7400 Clause = (
7401 ClauseHead :-
7402 HeadMatching,
7403 Allocation,
7404 NovelProduction,
7405 GuardAttachment,
7406 GuardCopy,
7407 Cut,
7408 ExtendHistory,
7409 BodyAttachment,
7410 BodyCopy,
7411 ConditionalRecursiveCall
7412 ),
7413 add_location(Clause,RuleNb,LocatedClause),
7414 ProgramList = [LocatedClause | ProgramTail].
7416 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7417 %% multi headed propagation
7418 %% prelude + predicates to accumulate the necessary combinations of suspended
7419 %% constraints + predicate to execute the body
7420 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7421 RestHeads = [First|Rest],
7422 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7423 extend_id(Id,ExtendedId),
7424 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7426 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7427 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7428 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7429 build_head(F,A,Id,VarsSusp,PreludeHead),
7430 get_constraint_mode(F/A,Mode),
7431 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7432 Rule = rule(_,_,Guard,Body),
7433 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7435 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7437 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7439 extend_id(Id,NestedId),
7440 append([Susps|VarsSusp],ExtraVars,NestedVars),
7441 build_head(F,A,NestedId,NestedVars,NestedHead),
7442 NestedCall = NestedHead,
7444 Prelude = (
7445 PreludeHead :-
7446 FirstMatching,
7447 FirstSuspGoal,
7448 !,
7449 CondAllocation,
7450 NestedCall
7451 ),
7452 add_dummy_location(Prelude,LocatedPrelude),
7453 L = [LocatedPrelude|T].
7455 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7456 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7457 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
7458 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7460 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7461 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
7462 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
7463 inc_id(Id,IncId),
7464 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7466 %check_fd_lookup_condition(_,_,_,_) :- fail.
7467 check_fd_lookup_condition(F,A,_,_) :-
7468 get_store_type(F/A,global_singleton), !.
7469 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7470 \+ may_trigger(F/A),
7471 get_functional_dependency(F/A,1,P,K),
7472 copy_term(P-K,CurrentHead-Key),
7473 term_variables(PreHeads,PreVars),
7474 intersect_eq(Key,PreVars,Key),!.
7476 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7477 Rule = rule(_,H2,Guard,Body),
7478 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7479 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7480 init(AllSusps,RestSusps),
7481 last(AllSusps,Susp),
7482 gen_var(OtherSusp),
7483 gen_var(OtherSusps),
7484 functor(CurrentHead,OtherF,OtherA),
7485 gen_vars(OtherA,OtherVars),
7486 delay_phase_end(validate_store_type_assumptions,
7487 ( static_suspension_term(OtherF/OtherA,Suspension),
7488 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7489 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7490 )
7491 ),
7492 % create_get_mutable_ref(active,State,GetMutable),
7493 CurrentSuspTest = (
7494 OtherSusp = Suspension,
7495 GetState
7496 ),
7497 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7498 build_head(F,A,Id,ClauseVars,ClauseHead),
7499 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7500 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
7501 RecursiveVars = PreVarsAndSusps1
7502 ;
7503 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7504 PrevId = Id
7505 ),
7506 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7507 RecursiveCall = RecursiveHead,
7508 CurrentHead =.. [_|OtherArgs],
7509 pairup(OtherArgs,OtherVars,OtherPairs),
7510 get_constraint_mode(OtherF/OtherA,Mode),
7511 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7513 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7514 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7515 get_occurrence(F/A,O,_,ID),
7517 ( is_observed(F/A,O) ->
7518 init(FirstVarsSusp,FirstVars),
7519 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7520 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7521 ;
7522 Attachment = true,
7523 ConditionalRecursiveCall = RecursiveCall
7524 ),
7525 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7526 NovelProduction = true,
7527 ExtendHistory = true
7528 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7529 NovelProduction = true,
7530 ExtendHistory = true
7531 ;
7532 get_occurrence(F/A,O,_,ID),
7533 use_auxiliary_predicate(novel_production),
7534 use_auxiliary_predicate(extend_history),
7535 does_use_history(F/A,O),
7536 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7537 ( HistoryIDs == [] ->
7538 empty_named_history_novel_production(HistoryName,NovelProduction),
7539 empty_named_history_extend_history(HistoryName,ExtendHistory)
7540 ;
7541 reverse([OtherSusp|RestSusps],NamedSusps),
7542 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7543 HistorySusps = [HistorySusp|_],
7545 ( length(HistoryIDs, 1) ->
7546 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7547 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7548 ;
7549 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7550 Tuple =.. [t,HistoryName|HistorySusps]
7551 )
7552 )
7553 ;
7554 HistorySusp = Susp,
7555 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7556 sort([ID|RestIDs],HistoryIDs),
7557 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7558 Tuple =.. [t,RuleNb|HistorySusps]
7559 ),
7561 ( var(NovelProduction) ->
7562 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7563 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7564 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7565 ;
7566 true
7567 )
7568 ),
7571 ( chr_pp_flag(debugable,on) ->
7572 Rule = rule(_,_,Guard,Body),
7573 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7574 get_occurrence(F/A,O,_,ID),
7575 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7576 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7577 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7578 ;
7579 DebugTry = true,
7580 DebugApply = true
7581 ),
7583 ( is_stored_in_guard(F/A, RuleNb) ->
7584 GuardAttachment = Attachment,
7585 BodyAttachment = true
7586 ;
7587 GuardAttachment = true,
7588 BodyAttachment = Attachment % will be true if not observed at all
7589 ),
7591 Clause = (
7592 ClauseHead :-
7593 ( CurrentSuspTest,
7594 DiffSuspGoals,
7595 Matching,
7596 NovelProduction,
7597 GuardAttachment,
7598 GuardCopy,
7599 DebugTry ->
7600 DebugApply,
7601 ExtendHistory,
7602 BodyAttachment,
7603 BodyCopy,
7604 ConditionalRecursiveCall
7605 ; RecursiveCall
7606 )
7607 ),
7608 add_location(Clause,RuleNb,LocatedClause),
7609 L = [LocatedClause|T].
7611 novel_production_calls([],[],[],_,_,true).
7612 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7613 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7614 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7615 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7617 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7618 reverse(ReversedRestSusps,RestSusps),
7619 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7621 named_history_susps([],_,_,[]).
7622 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7623 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7624 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7628 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7629 !,
7630 functor(Head,F,A),
7631 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7632 get_constraint_mode(F/A,Mode),
7633 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7634 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7635 append(VarsSusp,ExtraVars,HeadVars).
7636 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7637 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7638 functor(Head,F,A),
7639 gen_var(Susps),
7640 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7641 get_constraint_mode(F/A,Mode),
7642 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7643 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7644 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7646 % returns
7647 % VarDict for the copies of variables in the original heads
7648 % VarsSuspsList list of lists of arguments for the successive heads
7649 % FirstVarsSusp top level arguments
7650 % SuspList list of all suspensions
7651 % Iterators list of all iterators
7652 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7653 !,
7654 functor(Head,F,A),
7655 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7656 get_constraint_mode(F/A,Mode),
7657 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7658 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7659 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7660 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7661 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7662 functor(Head,F,A),
7663 gen_var(Susps),
7664 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7665 get_constraint_mode(F/A,Mode),
7666 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7667 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7668 append(HeadVars,[Susp,Susps],Vars).
7670 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7671 !,
7672 functor(Head,F,A),
7673 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7674 get_constraint_mode(F/A,Mode),
7675 head_arg_matches(Pairs,Mode,[],_,VarDict),
7676 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7677 append(VarsSusp,ExtraVars,HeadVars).
7678 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7679 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7680 functor(Head,F,A),
7681 gen_var(Susps),
7682 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7683 get_constraint_mode(F/A,Mode),
7684 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7685 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7686 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7688 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7690 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7691 %% ____ _ _ _ _
7692 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7693 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7694 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7695 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7696 %%
7697 %% ____ _ _ _
7698 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7699 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7700 %% | _ < __/ |_| | | | __/\ V / (_| | |
7701 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7702 %%
7703 %% ____ _ _
7704 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7705 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7706 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7707 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7708 %% |___/
7710 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7711 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7712 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7713 ;
7714 NRestHeads = RestHeads,
7715 NRestIDs = RestIDs
7716 ).
7718 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7719 term_variables(Head,Vars),
7720 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7721 copy_term_nat(InitialData,InitialDataCopy),
7722 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7723 InitialDataCopy = InitialData,
7724 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7725 reverse(RNRestHeads,NRestHeads),
7726 reverse(RNRestIDs,NRestIDs).
7728 final_data(Entry) :-
7729 Entry = entry(_,_,_,_,[],_).
7731 expand_data(Entry,NEntry,Cost) :-
7732 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7733 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7734 term_variables([Head1|Vars],Vars1),
7735 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7736 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7738 % Assigns score to head based on known variables and heads to lookup
7739 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7740 functor(Head,F,A),
7741 get_store_type(F/A,StoreType),
7742 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7744 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7745 term_variables(Head,HeadVars),
7746 term_variables(RestHeads,RestVars),
7747 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7748 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7749 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7750 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7751 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7752 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7753 term_variables(Head,HeadVars),
7754 term_variables(RestHeads,RestVars),
7755 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7756 Score is Score_ * 2.
7757 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7758 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7759 Score = 1. % guaranteed O(1)
7761 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7762 find_with_var_identity(
7763 S,
7764 t(Head,KnownVars,RestHeads),
7765 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7766 Scores
7767 ),
7768 min_list(Scores,Score).
7769 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7770 Score = 10.
7771 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7772 Score = 10.
7774 order_score_indexes([],_,_,Score,NScore) :-
7775 Score > 0, NScore = 100.
7776 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7777 multi_hash_key_args(I,Head,Args),
7778 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7779 Score1 is Score + 1
7780 ;
7781 Score1 = Score
7782 ),
7783 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7785 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7786 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7787 ( K-R-O == 0-0-0 ->
7788 Score = 0
7789 ; K > 0 ->
7790 Score is max(10 - K,0)
7791 ; R > 0 ->
7792 Score is max(10 - R,1) * 10
7793 ;
7794 Score is max(10-O,1) * 100
7795 ).
7796 order_score_count_vars([],_,_,0-0-0).
7797 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7798 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7799 ( memberchk_eq(V,KnownVars) ->
7800 NK is K + 1,
7801 NR = R, NO = O
7802 ; memberchk_eq(V,RestVars) ->
7803 NR is R + 1,
7804 NK = K, NO = O
7805 ;
7806 NO is O + 1,
7807 NK = K, NR = R
7808 ).
7810 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7811 %% ___ _ _ _
7812 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
7813 %% | || '_ \| | | '_ \| | '_ \ / _` |
7814 %% | || | | | | | | | | | | | | (_| |
7815 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7816 %% |___/
7818 %% SWI begin
7819 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7820 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7821 %% SWI end
7823 %% SICStus begin
7824 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7825 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7826 %% SICStus end
7828 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7830 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7831 %% _ _ _ _ _ _ _
7832 %% | | | | |_(_) (_) |_ _ _
7833 %% | | | | __| | | | __| | | |
7834 %% | |_| | |_| | | | |_| |_| |
7835 %% \___/ \__|_|_|_|\__|\__, |
7836 %% |___/
7838 % Create a fresh variable.
7839 gen_var(_).
7841 % Create =N= fresh variables.
7842 gen_vars(N,Xs) :-
7843 length(Xs,N).
7845 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7846 vars_susp(A,Vars,Susp,VarsSusp),
7847 Head =.. [_|Args],
7848 pairup(Args,Vars,HeadPairs).
7850 inc_id([N|Ns],[O|Ns]) :-
7851 O is N + 1.
7852 dec_id([N|Ns],[M|Ns]) :-
7853 M is N - 1.
7855 extend_id(Id,[0|Id]).
7857 next_id([_,N|Ns],[O|Ns]) :-
7858 O is N + 1.
7860 % return clause Head
7861 % for F/A constraint symbol, predicate identifier Id and arguments Head
7862 build_head(F,A,Id,Args,Head) :-
7863 buildName(F,A,Id,Name),
7864 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
7865 ( may_trigger(F/A) ;
7866 get_allocation_occurrence(F/A,AO),
7867 get_max_occurrence(F/A,MO),
7868 MO >= AO ) ) ->
7869 Head =.. [Name|Args]
7870 ;
7871 init(Args,ArgsWOSusp), % XXX not entirely correct!
7872 Head =.. [Name|ArgsWOSusp]
7873 ).
7875 % return predicate name Result
7876 % for Fct/Aty constraint symbol and predicate identifier List
7877 buildName(Fct,Aty,List,Result) :-
7878 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
7879 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
7880 MO >= AO ) ; List \= [0])) ) ) ->
7881 atom_concat(Fct, '___' ,FctSlash),
7882 atomic_concat(FctSlash,Aty,FctSlashAty),
7883 buildName_(List,FctSlashAty,Result)
7884 ;
7885 Result = Fct
7886 ).
7888 buildName_([],Name,Name).
7889 buildName_([N|Ns],Name,Result) :-
7890 buildName_(Ns,Name,Name1),
7891 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
7892 atomic_concat(NameDash,N,Result).
7894 vars_susp(A,Vars,Susp,VarsSusp) :-
7895 length(Vars,A),
7896 append(Vars,[Susp],VarsSusp).
7898 or_pattern(Pos,Pat) :-
7899 Pow is Pos - 1,
7900 Pat is 1 << Pow. % was 2 ** X
7902 and_pattern(Pos,Pat) :-
7903 X is Pos - 1,
7904 Y is 1 << X, % was 2 ** X
7905 Pat is (-1)*(Y + 1).
7907 make_name(Prefix,F/A,Name) :-
7908 atom_concat_list([Prefix,F,'___',A],Name).
7910 %===============================================================================
7911 % Attribute for attributed variables
7913 make_attr(N,Mask,SuspsList,Attr) :-
7914 length(SuspsList,N),
7915 Attr =.. [v,Mask|SuspsList].
7917 get_all_suspensions2(N,Attr,SuspensionsList) :-
7918 chr_pp_flag(dynattr,off), !,
7919 make_attr(N,_,SuspensionsList,Attr).
7921 % NEW
7922 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
7923 % writeln(get_all_suspensions2),
7924 length(SuspensionsList,N),
7925 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
7928 % NEW
7929 normalize_attr(Attr,NormalGoal,NormalAttr) :-
7930 % writeln(normalize_attr),
7931 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
7933 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
7934 chr_pp_flag(dynattr,off), !,
7935 make_attr(N,_,SuspsList,Attr),
7936 nth1(Position,SuspsList,Suspensions).
7938 % NEW
7939 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
7940 % writeln(get_suspensions),
7941 Goal =
7942 ( memberchk(Position-Suspensions,TAttr) ->
7943 true
7944 ;
7945 Suspensions = []
7946 ).
7948 %-------------------------------------------------------------------------------
7949 % +N: number of constraint symbols
7950 % +Suspension: source-level variable, for suspension
7951 % +Position: constraint symbol number
7952 % -Attr: source-level term, for new attribute
7953 singleton_attr(N,Suspension,Position,Attr) :-
7954 chr_pp_flag(dynattr,off), !,
7955 or_pattern(Position,Pattern),
7956 make_attr(N,Pattern,SuspsList,Attr),
7957 nth1(Position,SuspsList,[Suspension]),
7958 chr_delete(SuspsList,[Suspension],RestSuspsList),
7959 set_elems(RestSuspsList,[]).
7961 % NEW
7962 singleton_attr(N,Suspension,Position,Attr) :-
7963 % writeln(singleton_attr),
7964 Attr = [Position-[Suspension]].
7966 %-------------------------------------------------------------------------------
7967 % +N: number of constraint symbols
7968 % +Suspension: source-level variable, for suspension
7969 % +Position: constraint symbol number
7970 % +TAttr: source-level variable, for old attribute
7971 % -Goal: goal for creating new attribute
7972 % -NTAttr: source-level variable, for new attribute
7973 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7974 chr_pp_flag(dynattr,off), !,
7975 make_attr(N,Mask,SuspsList,Attr),
7976 or_pattern(Position,Pattern),
7977 nth1(Position,SuspsList,Susps),
7978 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
7979 make_attr(N,Mask,SuspsList1,NewAttr1),
7980 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
7981 make_attr(N,NewMask,SuspsList2,NewAttr2),
7982 Goal = (
7983 TAttr = Attr,
7984 ( Mask /\ Pattern =:= Pattern ->
7985 NTAttr = NewAttr1
7986 ;
7987 NewMask is Mask \/ Pattern,
7988 NTAttr = NewAttr2
7989 )
7990 ), !.
7992 % NEW
7993 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7994 % writeln(add_attr),
7995 Goal =
7996 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
7997 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
7998 ;
7999 NTAttr = [Position-[Suspension]|TAttr]
8000 ).
8002 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8003 chr_pp_flag(dynattr,off), !,
8004 or_pattern(Position,Pattern),
8005 and_pattern(Position,DelPattern),
8006 make_attr(N,Mask,SuspsList,Attr),
8007 nth1(Position,SuspsList,Susps),
8008 substitute_eq(Susps,SuspsList,[],SuspsList1),
8009 make_attr(N,NewMask,SuspsList1,Attr1),
8010 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8011 make_attr(N,Mask,SuspsList2,Attr2),
8012 get_target_module(Mod),
8013 Goal = (
8014 TAttr = Attr,
8015 ( Mask /\ Pattern =:= Pattern ->
8016 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8017 ( NewSusps == [] ->
8018 NewMask is Mask /\ DelPattern,
8019 ( NewMask == 0 ->
8020 del_attr(Var,Mod)
8021 ;
8022 put_attr(Var,Mod,Attr1)
8023 )
8024 ;
8025 put_attr(Var,Mod,Attr2)
8026 )
8027 ;
8028 true
8029 )
8030 ), !.
8032 % NEW
8033 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8034 % writeln(rem_attr),
8035 get_target_module(Mod),
8036 Goal =
8037 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8038 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8039 ( NSuspensions == [] ->
8040 ( RAttr == [] ->
8041 del_attr(Var,Mod)
8042 ;
8043 put_attr(Var,Mod,RAttr)
8044 )
8045 ;
8046 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8047 )
8048 ;
8049 true
8050 ).
8052 %-------------------------------------------------------------------------------
8053 % +N: number of constraint symbols
8054 % +TAttr1: source-level variable, for attribute
8055 % +TAttr2: source-level variable, for other attribute
8056 % -Goal: goal for merging the two attributes
8057 % -Attr: source-level term, for merged attribute
8058 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8059 chr_pp_flag(dynattr,off), !,
8060 make_attr(N,Mask1,SuspsList1,Attr1),
8061 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8062 Goal = (
8063 TAttr1 = Attr1,
8064 Goal2
8065 ).
8067 % NEW
8068 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8069 % writeln(merge_attributes),
8070 Goal = (
8071 sort(TAttr1,Sorted1),
8072 sort(TAttr2,Sorted2),
8073 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8074 ).
8077 %-------------------------------------------------------------------------------
8078 % +N: number of constraint symbols
8079 % +Mask1: ...
8080 % +SuspsList1: static term, for suspensions list
8081 % +TAttr2: source-level variable, for other attribute
8082 % -Goal: goal for merging the two attributes
8083 % -Attr: source-level term, for merged attribute
8084 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8085 make_attr(N,Mask2,SuspsList2,Attr2),
8086 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8087 list2conj(Gs,SortGoals),
8088 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8089 make_attr(N,Mask,SuspsList,Attr),
8090 Goal = (
8091 TAttr2 = Attr2,
8092 SortGoals,
8093 Mask is Mask1 \/ Mask2
8094 ).
8097 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8098 % Storetype dependent lookup
8100 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8101 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8102 %% -Goal,-SuspensionList) is det.
8103 %
8104 % Create a universal lookup goal for given head.
8105 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8106 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8107 functor(Head,F,A),
8108 get_store_type(F/A,StoreType),
8109 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8111 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8112 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8113 %% -Goal,-SuspensionList) is det.
8114 %
8115 % Create a universal lookup goal for given head.
8116 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8117 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8118 functor(Head,F,A),
8119 get_store_type(F/A,StoreType),
8120 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8123 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8124 %% +GroundVars,-Goal,-SuspensionList) is det.
8125 %
8126 % Create a universal lookup goal for given head.
8127 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8128 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8129 functor(Head,F,A),
8130 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8131 update_store_type(F/A,default).
8132 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8133 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8134 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8135 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8136 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8137 functor(Head,F,A),
8138 global_ground_store_name(F/A,StoreName),
8139 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8140 update_store_type(F/A,global_ground).
8141 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8142 arg(VarIndex,Head,OVar),
8143 arg(KeyIndex,Head,OKey),
8144 translate([OVar,OKey],VarDict,[Var,Key]),
8145 get_target_module(Module),
8146 Goal = (
8147 get_attr(Var,Module,AssocStore),
8148 lookup_assoc_store(AssocStore,Key,AllSusps)
8149 ).
8150 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8151 functor(Head,F,A),
8152 global_singleton_store_name(F/A,StoreName),
8153 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8154 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8155 update_store_type(F/A,global_singleton).
8156 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8157 once((
8158 member(ST,StoreTypes),
8159 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8160 )).
8161 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8162 functor(Head,F,A),
8163 arg(Index,Head,Var),
8164 translate([Var],VarDict,[KeyVar]),
8165 delay_phase_end(validate_store_type_assumptions,
8166 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8167 ),
8168 update_store_type(F/A,identifier_store(Index)),
8169 get_identifier_index(F/A,Index,_).
8170 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8171 functor(Head,F,A),
8172 arg(Index,Head,Var),
8173 ( var(Var) ->
8174 translate([Var],VarDict,[KeyVar]),
8175 Goal = StructGoal
8176 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8177 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8178 Goal = (LookupGoal,StructGoal)
8179 ),
8180 delay_phase_end(validate_store_type_assumptions,
8181 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8182 ),
8183 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8184 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8186 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8187 get_identifier_size(ISize),
8188 functor(Struct,struct,ISize),
8189 get_identifier_index(C,Index,IIndex),
8190 arg(IIndex,Struct,AllSusps),
8191 Goal = (KeyVar = Struct).
8193 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8194 type_indexed_identifier_structure(IndexType,Struct),
8195 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8196 arg(IIndex,Struct,AllSusps),
8197 Goal = (KeyVar = Struct).
8199 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8200 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8201 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8202 %
8203 % Create a universal hash lookup goal for given head.
8204 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8205 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8206 once((
8207 member(Index,Indexes),
8208 multi_hash_key_args(Index,Head,KeyArgs),
8209 (
8210 translate(KeyArgs,VarDict,KeyArgCopies)
8211 ;
8212 ground(KeyArgs), KeyArgCopies = KeyArgs
8213 )
8214 )),
8215 ( KeyArgCopies = [KeyCopy] ->
8216 true
8217 ;
8218 KeyCopy =.. [k|KeyArgCopies]
8219 ),
8220 functor(Head,F,A),
8221 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8223 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8224 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8226 Goal = (GroundCheck,LookupGoal),
8228 ( HashType == inthash ->
8229 update_store_type(F/A,multi_inthash([Index]))
8230 ;
8231 update_store_type(F/A,multi_hash([Index]))
8232 ).
8234 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8235 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8236 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8237 %% +VarArgDict,-NewVarArgDict) is det.
8238 %
8239 % Create existential lookup goal for given head.
8240 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8241 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8242 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8243 sbag_member_call(Susp,AllSusps,Sbag),
8244 functor(Head,F,A),
8245 delay_phase_end(validate_store_type_assumptions,
8246 ( static_suspension_term(F/A,SuspTerm),
8247 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8248 )
8249 ),
8250 Goal = (
8251 UniversalGoal,
8252 Sbag,
8253 Susp = SuspTerm,
8254 GetState
8255 ).
8256 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8257 functor(Head,F,A),
8258 global_singleton_store_name(F/A,StoreName),
8259 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8260 Goal = (
8261 GetStoreGoal, % nb_getval(StoreName,Susp),
8262 Susp \== [],
8263 Susp = SuspTerm
8264 ),
8265 update_store_type(F/A,global_singleton).
8266 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8267 once((
8268 member(ST,StoreTypes),
8269 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8270 )).
8271 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8272 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8273 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8274 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8275 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8276 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8277 hash_index_filter(Pairs,Index,NPairs),
8279 functor(Head,F,A),
8280 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8281 Sbag = (AllSusps = [Susp])
8282 ;
8283 sbag_member_call(Susp,AllSusps,Sbag)
8284 ),
8285 delay_phase_end(validate_store_type_assumptions,
8286 ( static_suspension_term(F/A,SuspTerm),
8287 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8288 )
8289 ),
8290 Goal = (
8291 LookupGoal,
8292 Sbag,
8293 Susp = SuspTerm, % not inlined
8294 GetState
8295 ).
8296 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8297 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8298 hash_index_filter(Pairs,Index,NPairs),
8300 functor(Head,F,A),
8301 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8302 Sbag = (AllSusps = [Susp])
8303 ;
8304 sbag_member_call(Susp,AllSusps,Sbag)
8305 ),
8306 delay_phase_end(validate_store_type_assumptions,
8307 ( static_suspension_term(F/A,SuspTerm),
8308 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8309 )
8310 ),
8311 Goal = (
8312 LookupGoal,
8313 Sbag,
8314 Susp = SuspTerm, % not inlined
8315 GetState
8316 ).
8317 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8318 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8319 sbag_member_call(Susp,Susps,Sbag),
8320 functor(Head,F,A),
8321 delay_phase_end(validate_store_type_assumptions,
8322 ( static_suspension_term(F/A,SuspTerm),
8323 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8324 )
8325 ),
8326 Goal = (
8327 UGoal,
8328 Sbag,
8329 Susp = SuspTerm, % not inlined
8330 GetState
8331 ).
8333 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8334 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8335 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8336 %% +VarArgDict,-NewVarArgDict) is det.
8337 %
8338 % Create existential hash lookup goal for given head.
8339 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8340 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8341 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8343 hash_index_filter(Pairs,Index,NPairs),
8345 functor(Head,F,A),
8346 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8347 Sbag = (AllSusps = [Susp])
8348 ;
8349 sbag_member_call(Susp,AllSusps,Sbag)
8350 ),
8351 delay_phase_end(validate_store_type_assumptions,
8352 ( static_suspension_term(F/A,SuspTerm),
8353 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8354 )
8355 ),
8356 Goal = (
8357 LookupGoal,
8358 Sbag,
8359 Susp = SuspTerm, % not inlined
8360 GetState
8361 ).
8363 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8364 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8365 %
8366 % Filter out pairs already covered by given hash index.
8367 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8368 hash_index_filter(Pairs,Index,NPairs) :-
8369 ( integer(Index) ->
8370 NIndex = [Index]
8371 ;
8372 NIndex = Index
8373 ),
8374 hash_index_filter(Pairs,NIndex,1,NPairs).
8376 hash_index_filter([],_,_,[]).
8377 hash_index_filter([P|Ps],Index,N,NPairs) :-
8378 ( Index = [I|Is] ->
8379 NN is N + 1,
8380 ( I > N ->
8381 NPairs = [P|NPs],
8382 hash_index_filter(Ps,[I|Is],NN,NPs)
8383 ; I == N ->
8384 hash_index_filter(Ps,Is,NN,NPairs)
8385 )
8386 ;
8387 NPairs = [P|Ps]
8388 ).
8390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8391 %------------------------------------------------------------------------------%
8392 %% assume_constraint_stores(+ConstraintSymbols) is det.
8393 %
8394 % Compute all constraint store types that are possible for the given
8395 % =ConstraintSymbols=.
8396 %------------------------------------------------------------------------------%
8397 assume_constraint_stores([]).
8398 assume_constraint_stores([C|Cs]) :-
8399 ( chr_pp_flag(debugable,off),
8400 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8401 is_stored(C),
8402 get_store_type(C,default) ->
8403 get_indexed_arguments(C,AllIndexedArgs),
8404 get_constraint_mode(C,Modes),
8405 findall(Index,(member(Index,AllIndexedArgs),
8406 nth(Index,Modes,+)),IndexedArgs),
8407 length(IndexedArgs,NbIndexedArgs),
8408 % Construct Index Combinations
8409 ( NbIndexedArgs > 10 ->
8410 findall([Index],member(Index,IndexedArgs),Indexes)
8411 ;
8412 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8413 predsort(longer_list,UnsortedIndexes,Indexes)
8414 ),
8415 % Choose Index Type
8416 ( get_functional_dependency(C,1,Pattern,Key),
8417 all_distinct_var_args(Pattern), Key == [] ->
8418 assumed_store_type(C,global_singleton)
8419 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8420 get_constraint_type_det(C,ArgTypes),
8421 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8423 ( IntHashIndexes = [] ->
8424 Stores = Stores1
8425 ;
8426 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8427 ),
8428 ( HashIndexes = [] ->
8429 Stores1 = Stores2
8430 ;
8431 Stores1 = [multi_hash(HashIndexes)|Stores2]
8432 ),
8433 ( IdentifierIndexes = [] ->
8434 Stores2 = Stores3
8435 ;
8436 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8437 append(WrappedIdentifierIndexes,Stores3,Stores2)
8438 ),
8439 append(CompoundIdentifierIndexes,Stores4,Stores3),
8440 ( only_ground_indexed_arguments(C)
8441 -> Stores4 = [global_ground]
8442 ; Stores4 = [default]
8443 ),
8444 assumed_store_type(C,multi_store(Stores))
8445 ; true
8446 )
8447 ;
8448 true
8449 ),
8450 assume_constraint_stores(Cs).
8452 %------------------------------------------------------------------------------%
8453 %% partition_indexes(+Indexes,+Types,
8454 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8455 %------------------------------------------------------------------------------%
8456 partition_indexes([],_,[],[],[],[]).
8457 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8458 ( Index = [I],
8459 nth(I,Types,Type),
8460 unalias_type(Type,UnAliasedType),
8461 UnAliasedType == chr_identifier ->
8462 IdentifierIndexes = [I|RIdentifierIndexes],
8463 IntHashIndexes = RIntHashIndexes,
8464 HashIndexes = RHashIndexes,
8465 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8466 ; Index = [I],
8467 nth(I,Types,Type),
8468 unalias_type(Type,UnAliasedType),
8469 nonvar(UnAliasedType),
8470 UnAliasedType = chr_identifier(IndexType) ->
8471 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8472 IdentifierIndexes = RIdentifierIndexes,
8473 IntHashIndexes = RIntHashIndexes,
8474 HashIndexes = RHashIndexes
8475 ; Index = [I],
8476 nth(I,Types,Type),
8477 unalias_type(Type,UnAliasedType),
8478 UnAliasedType == dense_int ->
8479 IntHashIndexes = [Index|RIntHashIndexes],
8480 HashIndexes = RHashIndexes,
8481 IdentifierIndexes = RIdentifierIndexes,
8482 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8483 ; member(I,Index),
8484 nth(I,Types,Type),
8485 unalias_type(Type,UnAliasedType),
8486 nonvar(UnAliasedType),
8487 UnAliasedType = chr_identifier(_) ->
8488 % don't use chr_identifiers in hash indexes
8489 IntHashIndexes = RIntHashIndexes,
8490 HashIndexes = RHashIndexes,
8491 IdentifierIndexes = RIdentifierIndexes,
8492 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8493 ;
8494 IntHashIndexes = RIntHashIndexes,
8495 HashIndexes = [Index|RHashIndexes],
8496 IdentifierIndexes = RIdentifierIndexes,
8497 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8498 ),
8499 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8501 longer_list(R,L1,L2) :-
8502 length(L1,N1),
8503 length(L2,N2),
8504 compare(Rt,N2,N1),
8505 ( Rt == (=) ->
8506 compare(R,L1,L2)
8507 ;
8508 R = Rt
8509 ).
8511 all_distinct_var_args(Term) :-
8512 Term =.. [_|Args],
8513 copy_term_nat(Args,NArgs),
8514 all_distinct_var_args_(NArgs).
8516 all_distinct_var_args_([]).
8517 all_distinct_var_args_([X|Xs]) :-
8518 var(X),
8519 X = t,
8520 all_distinct_var_args_(Xs).
8522 get_indexed_arguments(C,IndexedArgs) :-
8523 C = F/A,
8524 get_indexed_arguments(1,A,C,IndexedArgs).
8526 get_indexed_arguments(I,N,C,L) :-
8527 ( I > N ->
8528 L = []
8529 ; ( is_indexed_argument(C,I) ->
8530 L = [I|T]
8531 ;
8532 L = T
8533 ),
8534 J is I + 1,
8535 get_indexed_arguments(J,N,C,T)
8536 ).
8538 validate_store_type_assumptions([]).
8539 validate_store_type_assumptions([C|Cs]) :-
8540 validate_store_type_assumption(C),
8541 validate_store_type_assumptions(Cs).
8543 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8544 % new code generation
8545 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
8546 Rule = rule(H1,_,Guard,Body),
8547 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8548 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8549 flatten(VarsAndSuspsList,VarsAndSusps),
8550 Vars = [ [] | VarsAndSusps],
8551 build_head(F,A,Id,Vars,Head),
8552 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8553 Clause = ( Head :- PredecessorCall),
8554 add_dummy_location(Clause,LocatedClause),
8555 L = [LocatedClause | T].
8556 % ( H1 == [],
8557 % functor(CurrentHead,CF,CA),
8558 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8559 % L = T
8560 % ;
8561 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8562 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8563 % flatten(VarsAndSuspsList,VarsAndSusps),
8564 % Vars = [ [] | VarsAndSusps],
8565 % build_head(F,A,Id,Vars,Head),
8566 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8567 % Clause = ( Head :- PredecessorCall),
8568 % L = [Clause | T]
8569 % ).
8571 % skips back intelligently over global_singleton lookups
8572 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8573 ( Id = [0|_] ->
8574 next_id(Id,PrevId),
8575 PrevVarsAndSusps = BaseCallArgs
8576 ;
8577 VarsAndSuspsList = [_|AllButFirstList],
8578 dec_id(Id,PrevId1),
8579 ( PrevHeads = [PrevHead|PrevHeads1],
8580 functor(PrevHead,F,A),
8581 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8582 PrevIterators = [_|PrevIterators1],
8583 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8584 ;
8585 PrevId = PrevId1,
8586 flatten(AllButFirstList,AllButFirst),
8587 PrevIterators = [PrevIterator|_],
8588 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8589 )
8590 ).
8592 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
8593 Rule = rule(_,_,Guard,Body),
8594 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8595 init(AllSusps,PreSusps),
8596 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8597 gen_var(OtherSusps),
8598 functor(CurrentHead,OtherF,OtherA),
8599 gen_vars(OtherA,OtherVars),
8600 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8601 get_constraint_mode(OtherF/OtherA,Mode),
8602 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8604 delay_phase_end(validate_store_type_assumptions,
8605 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8606 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8607 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8608 )
8609 ),
8611 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8612 % create_get_mutable_ref(active,State,GetMutable),
8613 CurrentSuspTest = (
8614 OtherSusp = OtherSuspension,
8615 GetState,
8616 DiffSuspGoals,
8617 FirstMatching
8618 ),
8619 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8620 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8621 inc_id(Id,NestedId),
8622 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8623 build_head(F,A,Id,ClauseVars,ClauseHead),
8624 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8625 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8626 build_head(F,A,NestedId,NestedVars,NestedHead),
8628 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8629 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
8630 RecursiveVars = PreVarsAndSusps1
8631 ;
8632 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8633 PrevId = Id
8634 ),
8635 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8637 Clause = (
8638 ClauseHead :-
8639 ( CurrentSuspTest,
8640 NextSuspGoal
8641 ->
8642 NestedHead
8643 ; RecursiveHead
8644 )
8645 ),
8646 add_dummy_location(Clause,LocatedClause),
8647 L = [LocatedClause|T].
8649 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8651 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8652 % Observation Analysis
8653 %
8654 % CLASSIFICATION
8655 % Enabled
8656 %
8657 % Analysis based on Abstract Interpretation paper.
8658 %
8659 % TODO:
8660 % stronger analysis domain [research]
8662 :- chr_constraint
8663 initial_call_pattern/1,
8664 call_pattern/1,
8665 call_pattern_worker/1,
8666 final_answer_pattern/2,
8667 abstract_constraints/1,
8668 depends_on/2,
8669 depends_on_ap/4,
8670 depends_on_goal/2,
8671 ai_observed_internal/2,
8672 % ai_observed/2,
8673 ai_not_observed_internal/2,
8674 ai_not_observed/2,
8675 ai_is_observed/2,
8676 depends_on_as/3,
8677 ai_observation_gather_results/0.
8679 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8680 :- chr_type program_point == any.
8682 :- chr_option(mode,initial_call_pattern(+)).
8683 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8685 :- chr_option(mode,call_pattern(+)).
8686 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8688 :- chr_option(mode,call_pattern_worker(+)).
8689 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8691 :- chr_option(mode,final_answer_pattern(+,+)).
8692 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8694 :- chr_option(mode,abstract_constraints(+)).
8695 :- chr_option(type_declaration,abstract_constraints(list)).
8697 :- chr_option(mode,depends_on(+,+)).
8698 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8700 :- chr_option(mode,depends_on_as(+,+,+)).
8701 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8702 :- chr_option(mode,depends_on_goal(+,+)).
8703 :- chr_option(mode,ai_is_observed(+,+)).
8704 :- chr_option(mode,ai_not_observed(+,+)).
8705 % :- chr_option(mode,ai_observed(+,+)).
8706 :- chr_option(mode,ai_not_observed_internal(+,+)).
8707 :- chr_option(mode,ai_observed_internal(+,+)).
8710 abstract_constraints_fd @
8711 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8713 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8714 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8715 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8717 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8718 ai_is_observed(_,_) <=> true.
8720 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8721 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8722 ai_observation_gather_results <=> true.
8724 %------------------------------------------------------------------------------%
8725 % Main Analysis Entry
8726 %------------------------------------------------------------------------------%
8727 ai_observation_analysis(ACs) :-
8728 ( chr_pp_flag(ai_observation_analysis,on),
8729 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8730 list_to_ord_set(ACs,ACSet),
8731 abstract_constraints(ACSet),
8732 ai_observation_schedule_initial_calls(ACSet,ACSet),
8733 ai_observation_gather_results
8734 ;
8735 true
8736 ).
8738 ai_observation_schedule_initial_calls([],_).
8739 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8740 ai_observation_schedule_initial_call(AC,ACs),
8741 ai_observation_schedule_initial_calls(RACs,ACs).
8743 ai_observation_schedule_initial_call(AC,ACs) :-
8744 ai_observation_top(AC,CallPattern),
8745 % ai_observation_bot(AC,ACs,CallPattern),
8746 initial_call_pattern(CallPattern).
8748 ai_observation_schedule_new_calls([],AP).
8749 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8750 AP = odom(_,Set),
8751 initial_call_pattern(odom(AC,Set)),
8752 ai_observation_schedule_new_calls(ACs,AP).
8754 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8755 <=>
8756 ai_observation_leq(AP2,AP1)
8757 |
8758 true.
8760 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
8762 initial_call_pattern(CP) ==> call_pattern(CP).
8764 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
8765 ==>
8766 ai_observation_schedule_new_calls(ACs,AP)
8767 pragma
8768 passive(ID3).
8770 call_pattern(CP) \ call_pattern(CP) <=> true.
8772 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
8773 final_answer_pattern(CP1,AP).
8775 %call_pattern(CP) ==> writeln(call_pattern(CP)).
8777 call_pattern(CP) ==> call_pattern_worker(CP).
8779 %------------------------------------------------------------------------------%
8780 % Abstract Goal
8781 %------------------------------------------------------------------------------%
8783 % AbstractGoala
8784 %call_pattern(odom([],Set)) ==>
8785 % final_answer_pattern(odom([],Set),odom([],Set)).
8787 call_pattern_worker(odom([],Set)) <=>
8788 % writeln(' - AbstractGoal'(odom([],Set))),
8789 final_answer_pattern(odom([],Set),odom([],Set)).
8791 % AbstractGoalb
8792 call_pattern_worker(odom([G|Gs],Set)) <=>
8793 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
8794 CP1 = odom(G,Set),
8795 depends_on_goal(odom([G|Gs],Set),CP1),
8796 call_pattern(CP1).
8798 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
8799 <=> true pragma passive(ID).
8800 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
8801 ==>
8802 CP1 = odom([_|Gs],_),
8803 AP2 = odom([],Set),
8804 CCP = odom(Gs,Set),
8805 call_pattern(CCP),
8806 depends_on(CP1,CCP).
8808 %------------------------------------------------------------------------------%
8809 % Abstract Disjunction
8810 %------------------------------------------------------------------------------%
8812 call_pattern_worker(odom((AG1;AG2),Set)) <=>
8813 CP = odom((AG1;AG2),Set),
8814 InitialAnswerApproximation = odom([],Set),
8815 final_answer_pattern(CP,InitialAnswerApproximation),
8816 CP1 = odom(AG1,Set),
8817 CP2 = odom(AG2,Set),
8818 call_pattern(CP1),
8819 call_pattern(CP2),
8820 depends_on_as(CP,CP1,CP2).
8822 %------------------------------------------------------------------------------%
8823 % Abstract Solve
8824 %------------------------------------------------------------------------------%
8825 call_pattern_worker(odom(builtin,Set)) <=>
8826 % writeln(' - AbstractSolve'(odom(builtin,Set))),
8827 ord_empty(EmptySet),
8828 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
8830 %------------------------------------------------------------------------------%
8831 % Abstract Drop
8832 %------------------------------------------------------------------------------%
8833 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8834 <=>
8835 O > MO
8836 |
8837 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
8838 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8839 pragma
8840 passive(ID2).
8842 %------------------------------------------------------------------------------%
8843 % Abstract Activate
8844 %------------------------------------------------------------------------------%
8845 call_pattern_worker(odom(AC,Set))
8846 <=>
8847 AC = _ / _
8848 |
8849 % writeln(' - AbstractActivate'(odom(AC,Set))),
8850 CP = odom(occ(AC,1),Set),
8851 call_pattern(CP),
8852 depends_on(odom(AC,Set),CP).
8854 %------------------------------------------------------------------------------%
8855 % Abstract Passive
8856 %------------------------------------------------------------------------------%
8857 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8858 <=>
8859 is_passive(RuleNb,ID)
8860 |
8861 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8862 % DEFAULT
8863 NO is O + 1,
8864 DCP = odom(occ(C,NO),Set),
8865 call_pattern(DCP),
8866 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
8867 depends_on(odom(occ(C,O),Set),DCP)
8868 pragma
8869 passive(ID2).
8870 %------------------------------------------------------------------------------%
8871 % Abstract Simplify
8872 %------------------------------------------------------------------------------%
8874 % AbstractSimplify
8875 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8876 <=>
8877 \+ is_passive(RuleNb,ID)
8878 |
8879 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8880 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
8881 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
8882 ai_observation_memo_abstract_goal(RuleNb,AG),
8883 call_pattern(odom(AG,Set2)),
8884 % DEFAULT
8885 NO is O + 1,
8886 DCP = odom(occ(C,NO),Set),
8887 call_pattern(DCP),
8888 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
8889 % DEADLOCK AVOIDANCE
8890 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8891 pragma
8892 passive(ID2).
8894 depends_on_as(CP,CPS,CPD),
8895 final_answer_pattern(CPS,APS),
8896 final_answer_pattern(CPD,APD) ==>
8897 ai_observation_lub(APS,APD,AP),
8898 final_answer_pattern(CP,AP).
8901 :- chr_constraint
8902 ai_observation_memo_simplification_rest_heads/3,
8903 ai_observation_memoed_simplification_rest_heads/3.
8905 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
8906 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
8908 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8909 <=>
8910 QRH = RH.
8911 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8912 <=>
8913 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
8914 once(select2(ID,_,IDs1,H1,_,RestH1)),
8915 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
8916 ai_observation_abstract_constraints(H2,ACs,AH2),
8917 append(ARestHeads,AH2,AbstractHeads),
8918 sort(AbstractHeads,QRH),
8919 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
8920 pragma
8921 passive(ID1),
8922 passive(ID2),
8923 passive(ID3).
8925 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
8927 %------------------------------------------------------------------------------%
8928 % Abstract Propagate
8929 %------------------------------------------------------------------------------%
8932 % AbstractPropagate
8933 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8934 <=>
8935 \+ is_passive(RuleNb,ID)
8936 |
8937 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
8938 % observe partners
8939 ai_observation_memo_propagation_rest_heads(C,O,AHs),
8940 ai_observation_observe_set(Set,AHs,Set2),
8941 ord_add_element(Set2,C,Set3),
8942 ai_observation_memo_abstract_goal(RuleNb,AG),
8943 call_pattern(odom(AG,Set3)),
8944 ( ord_memberchk(C,Set2) ->
8945 Delete = no
8946 ;
8947 Delete = yes
8948 ),
8949 % DEFAULT
8950 NO is O + 1,
8951 DCP = odom(occ(C,NO),Set),
8952 call_pattern(DCP),
8953 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
8954 pragma
8955 passive(ID2).
8957 :- chr_constraint
8958 ai_observation_memo_propagation_rest_heads/3,
8959 ai_observation_memoed_propagation_rest_heads/3.
8961 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
8962 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
8964 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8965 <=>
8966 QRH = RH.
8967 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8968 <=>
8969 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
8970 once(select2(ID,_,IDs2,H2,_,RestH2)),
8971 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
8972 ai_observation_abstract_constraints(H1,ACs,AH1),
8973 append(ARestHeads,AH1,AbstractHeads),
8974 sort(AbstractHeads,QRH),
8975 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
8976 pragma
8977 passive(ID1),
8978 passive(ID2),
8979 passive(ID3).
8981 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
8983 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
8984 final_answer_pattern(CP,APD).
8985 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
8986 final_answer_pattern(CPD,APD) ==>
8987 true |
8988 CP = odom(occ(C,O),_),
8989 ( ai_observation_is_observed(APP,C) ->
8990 ai_observed_internal(C,O)
8991 ;
8992 ai_not_observed_internal(C,O)
8993 ),
8994 ( Delete == yes ->
8995 APP = odom([],Set0),
8996 ord_del_element(Set0,C,Set),
8997 NAPP = odom([],Set)
8998 ;
8999 NAPP = APP
9000 ),
9001 ai_observation_lub(NAPP,APD,AP),
9002 final_answer_pattern(CP,AP).
9004 %------------------------------------------------------------------------------%
9005 % Catch All
9006 %------------------------------------------------------------------------------%
9008 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9010 %------------------------------------------------------------------------------%
9011 % Auxiliary Predicates
9012 %------------------------------------------------------------------------------%
9014 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9015 ord_intersection(S1,S2,S3).
9017 ai_observation_bot(AG,AS,odom(AG,AS)).
9019 ai_observation_top(AG,odom(AG,EmptyS)) :-
9020 ord_empty(EmptyS).
9022 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9023 ord_subset(S2,S1).
9025 ai_observation_observe_set(S,ACSet,NS) :-
9026 ord_subtract(S,ACSet,NS).
9028 ai_observation_abstract_constraint(C,ACs,AC) :-
9029 functor(C,F,A),
9030 AC = F/A,
9031 memberchk(AC,ACs).
9033 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9034 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9036 %------------------------------------------------------------------------------%
9037 % Abstraction of Rule Bodies
9038 %------------------------------------------------------------------------------%
9040 :- chr_constraint
9041 ai_observation_memoed_abstract_goal/2,
9042 ai_observation_memo_abstract_goal/2.
9044 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9045 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9047 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9048 <=>
9049 QAG = AG
9050 pragma
9051 passive(ID1).
9053 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9054 <=>
9055 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9056 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9057 QAG = AG,
9058 ai_observation_memoed_abstract_goal(RuleNb,AG)
9059 pragma
9060 passive(ID1),
9061 passive(ID2).
9063 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9064 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9065 term_variables((H1,H2,Guard),HVars),
9066 append(H1,H2,Heads),
9067 % variables that are declared to be ground are safe,
9068 ground_vars(Heads,GroundVars),
9069 % so we remove them from the list of 'dangerous' head variables
9070 list_difference_eq(HVars,GroundVars,HV),
9071 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9072 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9073 % HV are 'dangerous' variables, all others are fresh and safe
9075 ground_vars([],[]).
9076 ground_vars([H|Hs],GroundVars) :-
9077 functor(H,F,A),
9078 get_constraint_mode(F/A,Mode),
9079 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9080 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9081 ground_vars(Hs,GroundVars2),
9082 append(GroundVars1,GroundVars2,GroundVars).
9084 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9085 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9086 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9087 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9088 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9089 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9090 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9091 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9092 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9093 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9094 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9095 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9096 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9097 % non-CHR constraint is safe if it only binds fresh variables
9098 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9099 builtin_binds_b(G,Vars),
9100 intersect_eq(Vars,HV,[]),
9101 !.
9102 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9103 AG = builtin. % default case if goal is not recognized/safe
9105 ai_observation_is_observed(odom(_,ACSet),AC) :-
9106 \+ ord_memberchk(AC,ACSet).
9108 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9109 unconditional_occurrence(C,O) :-
9110 get_occurrence(C,O,RuleNb,ID),
9111 get_rule(RuleNb,PRule),
9112 PRule = pragma(ORule,_,_,_,_),
9113 copy_term_nat(ORule,Rule),
9114 Rule = rule(H1,H2,Guard,_),
9115 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9116 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9117 once((
9118 H1 = [Head], H2 == []
9119 ;
9120 H2 = [Head], H1 == [], \+ may_trigger(C)
9121 )),
9122 functor(Head,F,A),
9123 Head =.. [_|Args],
9124 unconditional_occurrence_args(Args).
9126 unconditional_occurrence_args([]).
9127 unconditional_occurrence_args([X|Xs]) :-
9128 var(X),
9129 X = x,
9130 unconditional_occurrence_args(Xs).
9132 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9134 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9135 % Partial wake analysis
9136 %
9137 % In a Var = Var unification do not wake up constraints of both variables,
9138 % but rather only those of one variable.
9139 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9141 :- chr_constraint partial_wake_analysis/0.
9142 :- chr_constraint no_partial_wake/1.
9143 :- chr_option(mode,no_partial_wake(+)).
9144 :- chr_constraint wakes_partially/1.
9145 :- chr_option(mode,wakes_partially(+)).
9147 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9148 ==>
9149 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9150 ( is_passive(RuleNb,ID) ->
9151 true
9152 ; Type == simplification ->
9153 select(H,H1,RestH1),
9154 H =.. [_|Args],
9155 term_variables(Guard,Vars),
9156 partial_wake_args(Args,ArgModes,Vars,FA)
9157 ; % Type == propagation ->
9158 select(H,H2,RestH2),
9159 H =.. [_|Args],
9160 term_variables(Guard,Vars),
9161 partial_wake_args(Args,ArgModes,Vars,FA)
9162 ).
9164 partial_wake_args([],_,_,_).
9165 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9166 ( Mode \== (+) ->
9167 ( nonvar(Arg) ->
9168 no_partial_wake(C)
9169 ; memberchk_eq(Arg,Vars) ->
9170 no_partial_wake(C)
9171 ;
9172 true
9173 )
9174 ;
9175 true
9176 ),
9177 partial_wake_args(Args,Modes,Vars,C).
9179 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9181 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9183 wakes_partially(C) <=> true.
9186 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9187 % Generate rules that implement chr_show_store/1 functionality.
9188 %
9189 % CLASSIFICATION
9190 % Experimental
9191 % Unused
9192 %
9193 % Generates additional rules:
9194 %
9195 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9196 % ...
9197 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9198 % $show <=> true.
9200 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9201 ( chr_pp_flag(show,on) ->
9202 Constraints = ['$show'/0|Constraints0],
9203 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9204 inc_rule_count(RuleNb),
9205 Rule = pragma(
9206 rule(['$show'],[],true,true),
9207 ids([0],[]),
9208 [],
9209 no,
9210 RuleNb
9211 )
9212 ;
9213 Constraints = Constraints0,
9214 Rules = Rules0
9215 ).
9217 generate_show_rules([],Rules,Rules).
9218 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9219 functor(C,F,A),
9220 inc_rule_count(RuleNb),
9221 Rule = pragma(
9222 rule([],['$show',C],true,writeln(C)),
9223 ids([],[0,1]),
9224 [passive(1)],
9225 no,
9226 RuleNb
9227 ),
9228 generate_show_rules(Rest,Tail,Rules).
9230 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9231 % Custom supension term layout
9233 static_suspension_term(F/A,Suspension) :-
9234 suspension_term_base(F/A,Base),
9235 Arity is Base + A,
9236 functor(Suspension,suspension,Arity).
9238 has_suspension_field(FA,Field) :-
9239 suspension_term_base_fields(FA,Fields),
9240 memberchk(Field,Fields).
9242 suspension_term_base(FA,Base) :-
9243 suspension_term_base_fields(FA,Fields),
9244 length(Fields,Base).
9246 suspension_term_base_fields(FA,Fields) :-
9247 ( chr_pp_flag(debugable,on) ->
9248 % 1. ID
9249 % 2. State
9250 % 3. Propagation History
9251 % 4. Generation Number
9252 % 5. Continuation Goal
9253 % 6. Functor
9254 Fields = [id,state,history,generation,continuation,functor]
9255 ;
9256 ( uses_history(FA) ->
9257 Fields = [id,state,history|Fields2]
9258 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9259 Fields = [state|Fields2]
9260 ;
9261 Fields = [id,state|Fields2]
9262 ),
9263 ( only_ground_indexed_arguments(FA) ->
9264 get_store_type(FA,StoreType),
9265 basic_store_types(StoreType,BasicStoreTypes),
9266 ( memberchk(global_ground,BasicStoreTypes) ->
9267 % 1. ID
9268 % 2. State
9269 % 3. Propagation History
9270 % 4. Global List Prev
9271 Fields2 = [global_list_prev|Fields3]
9272 ;
9273 % 1. ID
9274 % 2. State
9275 % 3. Propagation History
9276 Fields2 = Fields3
9277 ),
9278 ( chr_pp_flag(ht_removal,on)
9279 -> ht_prev_fields(BasicStoreTypes,Fields3)
9280 ; Fields3 = []
9281 )
9282 ; may_trigger(FA) ->
9283 % 1. ID
9284 % 2. State
9285 % 3. Propagation History
9286 ( uses_field(FA,generation) ->
9287 % 4. Generation Number
9288 % 5. Global List Prev
9289 Fields2 = [generation,global_list_prev|Fields3]
9290 ;
9291 Fields2 = [global_list_prev|Fields3]
9292 ),
9293 ( chr_pp_flag(mixed_stores,on),
9294 chr_pp_flag(ht_removal,on)
9295 -> get_store_type(FA,StoreType),
9296 basic_store_types(StoreType,BasicStoreTypes),
9297 ht_prev_fields(BasicStoreTypes,Fields3)
9298 ; Fields3 = []
9299 )
9300 ;
9301 % 1. ID
9302 % 2. State
9303 % 3. Propagation History
9304 % 4. Global List Prev
9305 Fields2 = [global_list_prev|Fields3],
9306 ( chr_pp_flag(mixed_stores,on),
9307 chr_pp_flag(ht_removal,on)
9308 -> get_store_type(FA,StoreType),
9309 basic_store_types(StoreType,BasicStoreTypes),
9310 ht_prev_fields(BasicStoreTypes,Fields3)
9311 ; Fields3 = []
9312 )
9313 )
9314 ).
9316 ht_prev_fields(Stores,Prevs) :-
9317 ht_prev_fields_int(Stores,PrevsList),
9318 append(PrevsList,Prevs).
9319 ht_prev_fields_int([],[]).
9320 ht_prev_fields_int([H|T],Fields) :-
9321 ( H = multi_hash(Indexes)
9322 -> maplist(ht_prev_field,Indexes,FH),
9323 Fields = [FH|FT]
9324 ; Fields = FT
9325 ),
9326 ht_prev_fields_int(T,FT).
9328 ht_prev_field(Index,Field) :-
9329 ( integer(Index)
9330 -> atom_concat('multi_hash_prev-',Index,Field)
9331 ; Index = [_|_]
9332 -> concat_atom(['multi_hash_prev-'|Index],Field)
9333 ).
9335 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9336 suspension_term_base_fields(FA,Fields),
9337 nth(Index,Fields,FieldName), !,
9338 arg(Index,StaticSuspension,Field).
9339 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9340 suspension_term_base(FA,Base),
9341 StaticSuspension =.. [_|Args],
9342 drop(Base,Args,Field).
9343 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9344 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9347 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9348 suspension_term_base_fields(FA,Fields),
9349 nth(Index,Fields,FieldName), !,
9350 Goal = arg(Index,DynamicSuspension,Field).
9351 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9352 static_suspension_term(FA,StaticSuspension),
9353 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9354 Goal = (DynamicSuspension = StaticSuspension).
9355 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9356 suspension_term_base(FA,Base),
9357 Index is I + Base,
9358 Goal = arg(Index,DynamicSuspension,Field).
9359 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9360 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9363 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9364 suspension_term_base_fields(FA,Fields),
9365 nth(Index,Fields,FieldName), !,
9366 Goal = setarg(Index,DynamicSuspension,Field).
9367 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9368 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9370 basic_store_types(multi_store(Types),Types) :- !.
9371 basic_store_types(Type,[Type]).
9373 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9374 %
9376 :- chr_constraint
9377 phase_end/1,
9378 delay_phase_end/2.
9380 :- chr_option(mode,phase_end(+)).
9381 :- chr_option(mode,delay_phase_end(+,?)).
9383 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9384 % phase_end(Phase) <=> true.
9387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9388 :- chr_constraint
9389 does_use_history/2,
9390 uses_history/1,
9391 novel_production_call/4.
9393 :- chr_option(mode,uses_history(+)).
9394 :- chr_option(mode,does_use_history(+,+)).
9395 :- chr_option(mode,novel_production_call(+,+,?,?)).
9397 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9398 does_use_history(FA,_) \ uses_history(FA) <=> true.
9399 uses_history(_FA) <=> fail.
9401 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9402 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9404 :- chr_constraint
9405 does_use_field/2,
9406 uses_field/2.
9408 :- chr_option(mode,uses_field(+,+)).
9409 :- chr_option(mode,does_use_field(+,+)).
9411 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9412 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9413 uses_field(_FA,_Field) <=> fail.
9415 :- chr_constraint
9416 uses_state/2,
9417 if_used_state/5,
9418 used_states_known/0.
9420 :- chr_option(mode,uses_state(+,+)).
9421 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9424 % states ::= not_stored_yet | passive | active | triggered | removed
9425 %
9426 % allocate CREATES not_stored_yet
9427 % remove CHECKS not_stored_yet
9428 % activate CHECKS not_stored_yet
9429 %
9430 % ==> no allocate THEN no not_stored_yet
9432 % recurs CREATES inactive
9433 % lookup CHECKS inactive
9435 % insert CREATES active
9436 % activate CREATES active
9437 % lookup CHECKS active
9438 % recurs CHECKS active
9440 % runsusp CREATES triggered
9441 % lookup CHECKS triggered
9442 %
9443 % ==> no runsusp THEN no triggered
9445 % remove CREATES removed
9446 % runsusp CHECKS removed
9447 % lookup CHECKS removed
9448 % recurs CHECKS removed
9449 %
9450 % ==> no remove THEN no removed
9452 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9454 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9456 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9457 <=> ResultGoal = Used.
9458 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9459 <=> ResultGoal = NotUsed.
9461 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9462 % Check storedness annotations.
9463 %
9464 % Feature for SSS.
9466 :- chr_constraint stored_assertion/1.
9467 :- chr_option(mode,stored_assertion(+)).
9468 :- chr_option(type_declaration,stored_assertion(constraint)).
9470 :- chr_constraint never_stored_default/2.
9471 :- chr_option(mode,never_stored_default(+,?)).
9472 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9474 generate_never_stored_rules(Constraints,Rules) :-
9475 ( chr_pp_flag(declare_stored_constraints,on) ->
9476 never_stored_rules(Constraints,Rules)
9477 ;
9478 Rules = []
9479 ).
9481 :- chr_constraint never_stored_rules/2.
9482 :- chr_option(mode,never_stored_rules(+,?)).
9483 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9485 never_stored_rules([],Rules) <=> Rules = [].
9486 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9487 Constraint = F/A,
9488 functor(Head,F,A),
9489 inc_rule_count(RuleNb),
9490 Rule = pragma(
9491 rule([Head],[],true,Goal),
9492 ids([0],[]),
9493 [],
9494 no,
9495 RuleNb
9496 ),
9497 Rules = [Rule|Tail],
9498 never_stored_rules(Constraints,Tail).
9499 never_stored_rules([_|Constraints],Rules) <=>
9500 never_stored_rules(Constraints,Rules).
9502 check_storedness_assertions(Constraints) :-
9503 ( chr_pp_flag(declare_stored_constraints,on) ->
9504 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9505 ;
9506 true
9507 ).
9510 :- chr_constraint check_storedness_assertion/1.
9511 :- chr_option(mode,check_storedness_assertion(+)).
9512 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9514 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9515 <=> ( is_stored(Constraint) ->
9516 true
9517 ;
9518 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9519 ).
9520 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9521 <=> ( is_finally_stored(Constraint) ->
9522 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9523 ; is_stored(Constraint) ->
9524 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9525 ;
9526 true
9527 ).
9528 % never-stored, no default goal
9529 check_storedness_assertion(Constraint)
9530 <=> ( is_finally_stored(Constraint) ->
9531 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9532 ; is_stored(Constraint) ->
9533 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9534 ;
9535 true
9536 ).