| blob | f3ba07a94a85522d7c3fb36ea35595b0c56fae6c |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% OPEN BUGS
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * success continuation optimization
64 %% * analyze history usage to determine whether/when
65 %% cheaper suspension is possible:
66 %% don't use history when all partners are passive and self never triggers
67 %% * store constraint unconditionally for unconditional propagation rule,
68 %% if first, i.e. without checking history and set trigger cont to next occ
69 %% * get rid of suspension passing for never triggered constraints,
70 %% up to allocation occurrence
71 %% * get rid of call indirection for never triggered constraints
72 %% up to first allocation occurrence.
73 %% * get rid of unnecessary indirection if last active occurrence
74 %% before unconditional removal is head2, e.g.
75 %% a \ b <=> true.
76 %% a <=> true.
77 %% * Eliminate last clause of never stored constraint, if its body
78 %% is fail, e.g.
79 %% a ...
80 %% a <=> fail.
81 %% * Specialize lookup operations and indexes for functional dependencies.
82 %%
83 %% MORE TODO
84 %%
85 %% * generate code to empty all constraint stores of a module (Bart Demoen)
86 %% * map A \ B <=> true | true rules
87 %% onto efficient code that empties the constraint stores of B
88 %% in O(1) time for ground constraints where A and B do not share
89 %% any variables
90 %% * ground matching seems to be not optimized for compound terms
91 %% in case of simpagation_head2 and propagation occurrences
92 %% * analysis for storage delaying (see primes for case)
93 %% * internal constraints declaration + analyses?
94 %% * Do not store in global variable store if not necessary
95 %% NOTE: affects show_store/1
96 %% * var_assoc multi-level store: variable - ground
97 %% * Do not maintain/check unnecessary propagation history
98 %% for reasons of anti-monotony
99 %% * Strengthen storage analysis for propagation rules
100 %% reason about bodies of rules only containing constraints
101 %% -> fixpoint with observation analysis
102 %% * instantiation declarations
103 %% COMPOUND (bound to nonvar)
104 %% avoid nonvar tests
105 %%
106 %% * make difference between cheap guards for reordering
107 %% and non-binding guards for lock removal
108 %% * fd -> once/[] transformation for propagation
109 %% * cheap guards interleaved with head retrieval + faster
110 %% via-retrieval + non-empty checking for propagation rules
111 %% redo for simpagation_head2 prelude
112 %% * intelligent backtracking for simplification/simpagation rule
113 %% generator_1(X),'_$savecp'(CP_1),
114 %% ...
115 %% if( (
116 %% generator_n(Y),
117 %% test(X,Y)
118 %% ),
119 %% true,
120 %% ('_$cutto'(CP_1), fail)
121 %% ),
122 %% ...
123 %%
124 %% or recently developped cascading-supported approach
125 %% * intelligent backtracking for propagation rule
126 %% use additional boolean argument for each possible smart backtracking
127 %% when boolean at end of list true -> no smart backtracking
128 %% false -> smart backtracking
129 %% only works for rules with at least 3 constraints in the head
130 %% * (set semantics + functional dependency) declaration + resolution
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %% merged
133 %%
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
137 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
138 ]).
139 %% SWI begin
140 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
141 :- use_module(library(ordsets)).
142 %% SWI end
144 :- use_module(hprolog).
145 :- use_module(pairlist).
146 :- use_module(a_star).
147 :- use_module(listmap).
148 :- use_module(clean_code).
149 :- use_module(builtins).
150 :- use_module(find).
151 :- use_module(binomialheap).
152 :- use_module(guard_entailment).
153 :- use_module(chr_compiler_options).
154 :- use_module(chr_compiler_utility).
155 :- use_module(chr_compiler_errors).
156 :- include(chr_op).
157 :- op(1150, fx, chr_type).
158 :- op(1130, xfx, --->).
159 :- op(980, fx, (+)).
160 :- op(980, fx, (-)).
161 :- op(980, fx, (?)).
162 :- op(1150, fx, constraints).
163 :- op(1150, fx, chr_constraint).
165 :- chr_option(debug,off).
166 :- chr_option(optimize,full).
167 :- chr_option(check_guard_bindings,off).
169 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
171 :- chr_type list(T) ---> [] ; [T|list(T)].
173 :- chr_type list == list(any).
175 :- chr_type mode ---> (+) ; (-) ; (?).
177 :- chr_type maybe(T) ---> yes(T) ; no.
179 :- chr_type constraint ---> any / any.
181 :- chr_type module_name == any.
183 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
184 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
185 :- chr_type idspair ---> ids(list(id),list(id)).
187 :- chr_type pragma_type ---> passive(id)
188 ; mpassive(list(id))
189 ; already_in_heads
190 ; already_in_heads(id)
191 ; no_history
192 ; history(history_name,list(id)).
193 :- chr_type history_name== any.
195 :- chr_type rule_name == any.
196 :- chr_type rule_nb == natural.
197 :- chr_type id == natural.
198 :- chr_type occurrence == int.
200 :- chr_type goal == any.
202 :- chr_type store_type ---> default
203 ; multi_store(list(store_type))
204 ; multi_hash(list(list(int)))
205 ; multi_inthash(list(list(int)))
206 ; global_singleton
207 ; global_ground
208 % EXPERIMENTAL STORES
209 ; atomic_constants(list(int),list(any),atomic_coverage)
210 ; ground_constants(list(int),list(any))
211 ; var_assoc_store(int,list(int))
212 ; identifier_store(int)
213 ; type_indexed_identifier_store(int,any).
214 :- chr_type atomic_coverage ---> complete ; incomplete.
216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
218 %------------------------------------------------------------------------------%
219 :- chr_constraint chr_source_file/1.
220 :- chr_option(mode,chr_source_file(+)).
221 :- chr_option(type_declaration,chr_source_file(module_name)).
222 %------------------------------------------------------------------------------%
223 chr_source_file(_) \ chr_source_file(_) <=> true.
225 %------------------------------------------------------------------------------%
226 :- chr_constraint get_chr_source_file/1.
227 :- chr_option(mode,get_chr_source_file(-)).
228 :- chr_option(type_declaration,get_chr_source_file(module_name)).
229 %------------------------------------------------------------------------------%
230 chr_source_file(Mod) \ get_chr_source_file(Query)
231 <=> Query = Mod .
232 get_chr_source_file(Query)
233 <=> Query = user.
236 %------------------------------------------------------------------------------%
237 :- chr_constraint target_module/1.
238 :- chr_option(mode,target_module(+)).
239 :- chr_option(type_declaration,target_module(module_name)).
240 %------------------------------------------------------------------------------%
241 target_module(_) \ target_module(_) <=> true.
243 %------------------------------------------------------------------------------%
244 :- chr_constraint get_target_module/1.
245 :- chr_option(mode,get_target_module(-)).
246 :- chr_option(type_declaration,get_target_module(module_name)).
247 %------------------------------------------------------------------------------%
248 target_module(Mod) \ get_target_module(Query)
249 <=> Query = Mod .
250 get_target_module(Query)
251 <=> Query = user.
253 %------------------------------------------------------------------------------%
254 :- chr_constraint line_number/2.
255 :- chr_option(mode,line_number(+,+)).
256 :- chr_option(type_declaration,line_number(rule_nb,int)).
257 %------------------------------------------------------------------------------%
258 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
260 %------------------------------------------------------------------------------%
261 :- chr_constraint get_line_number/2.
262 :- chr_option(mode,get_line_number(+,-)).
263 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
264 %------------------------------------------------------------------------------%
265 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
266 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
268 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
269 :- chr_option(mode,indexed_argument(+,+)).
270 :- chr_option(type_declaration,indexed_argument(constraint,int)).
272 :- chr_constraint is_indexed_argument/2.
273 :- chr_option(mode,is_indexed_argument(+,+)).
274 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
276 :- chr_constraint constraint_mode/2.
277 :- chr_option(mode,constraint_mode(+,+)).
278 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
280 :- chr_constraint get_constraint_mode/2.
281 :- chr_option(mode,get_constraint_mode(+,-)).
282 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
284 :- chr_constraint may_trigger/1.
285 :- chr_option(mode,may_trigger(+)).
286 :- chr_option(type_declaration,may_trigger(constraint)).
288 :- chr_constraint only_ground_indexed_arguments/1.
289 :- chr_option(mode,only_ground_indexed_arguments(+)).
290 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
292 :- chr_constraint none_suspended_on_variables/0.
294 :- chr_constraint are_none_suspended_on_variables/0.
296 :- chr_constraint store_type/2.
297 :- chr_option(mode,store_type(+,+)).
298 :- chr_option(type_declaration,store_type(constraint,store_type)).
300 :- chr_constraint get_store_type/2.
301 :- chr_option(mode,get_store_type(+,?)).
302 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
304 :- chr_constraint update_store_type/2.
305 :- chr_option(mode,update_store_type(+,+)).
306 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
308 :- chr_constraint actual_store_types/2.
309 :- chr_option(mode,actual_store_types(+,+)).
310 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
312 :- chr_constraint assumed_store_type/2.
313 :- chr_option(mode,assumed_store_type(+,+)).
314 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
316 :- chr_constraint validate_store_type_assumption/1.
317 :- chr_option(mode,validate_store_type_assumption(+)).
318 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
320 :- chr_constraint rule_count/1.
321 :- chr_option(mode,rule_count(+)).
322 :- chr_option(type_declaration,rule_count(natural)).
324 :- chr_constraint inc_rule_count/1.
325 :- chr_option(mode,inc_rule_count(-)).
326 :- chr_option(type_declaration,inc_rule_count(natural)).
328 rule_count(_) \ rule_count(_)
329 <=> true.
330 rule_count(C), inc_rule_count(NC)
331 <=> NC is C + 1, rule_count(NC).
332 inc_rule_count(NC)
333 <=> NC = 1, rule_count(NC).
335 :- chr_constraint passive/2.
336 :- chr_option(mode,passive(+,+)).
338 :- chr_constraint is_passive/2.
339 :- chr_option(mode,is_passive(+,+)).
341 :- chr_constraint any_passive_head/1.
342 :- chr_option(mode,any_passive_head(+)).
344 :- chr_constraint new_occurrence/4.
345 :- chr_option(mode,new_occurrence(+,+,+,+)).
347 :- chr_constraint occurrence/5.
348 :- chr_option(mode,occurrence(+,+,+,+,+)).
349 :- chr_type occurrence_type ---> simplification ; propagation.
350 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
352 :- chr_constraint get_occurrence/4.
353 :- chr_option(mode,get_occurrence(+,+,-,-)).
355 :- chr_constraint get_occurrence_from_id/4.
356 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
358 :- chr_constraint max_occurrence/2.
359 :- chr_option(mode,max_occurrence(+,+)).
361 :- chr_constraint get_max_occurrence/2.
362 :- chr_option(mode,get_max_occurrence(+,-)).
364 :- chr_constraint allocation_occurrence/2.
365 :- chr_option(mode,allocation_occurrence(+,+)).
367 :- chr_constraint get_allocation_occurrence/2.
368 :- chr_option(mode,get_allocation_occurrence(+,-)).
370 :- chr_constraint rule/2.
371 :- chr_option(mode,rule(+,+)).
372 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
374 :- chr_constraint get_rule/2.
375 :- chr_option(mode,get_rule(+,-)).
376 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
378 :- chr_constraint least_occurrence/2.
379 :- chr_option(mode,least_occurrence(+,+)).
380 :- chr_option(type_declaration,least_occurrence(any,list)).
382 :- chr_constraint is_least_occurrence/1.
383 :- chr_option(mode,is_least_occurrence(+)).
386 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
387 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
388 is_indexed_argument(_,_) <=> fail.
390 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
392 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
393 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
394 Q = Mode.
395 get_constraint_mode(FA,Q) <=>
396 FA = _ / N,
397 replicate(N,(?),Q).
399 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
402 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
403 nth1(I,Mode,M),
404 M \== (+) |
405 is_stored(FA).
406 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
408 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
409 <=>
410 nth1(I,Mode,M),
411 M \== (+)
412 |
413 fail.
414 only_ground_indexed_arguments(_) <=>
415 true.
417 none_suspended_on_variables \ none_suspended_on_variables <=> true.
418 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
419 are_none_suspended_on_variables <=> fail.
420 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
421 % STORE TYPES
422 %
423 % The functionality for inspecting and deciding on the different types of constraint
424 % store / indexes for constraints.
426 store_type(FA,StoreType)
427 ==> chr_pp_flag(verbose,on)
428 |
429 format('The indexes for ~w are:\n',[FA]),
430 format_storetype(StoreType).
431 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
433 format_storetype(multi_store(StoreTypes)) :- !,
434 forall(member(StoreType,StoreTypes), format_storetype(StoreType)).
435 format_storetype(atomic_constants(Index,Constants,_)) :-
436 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
437 format_storetype(ground_constants(Index,Constants)) :-
438 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
439 format_storetype(StoreType) :-
440 format('\t* ~w\n',[StoreType]).
443 % 1. Inspection
444 % ~~~~~~~~~~~~~
445 %
446 %
448 get_store_type_normal @
449 store_type(FA,Store) \ get_store_type(FA,Query)
450 <=> Query = Store.
452 get_store_type_assumed @
453 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
454 <=> Query = Store.
456 get_store_type_default @
457 get_store_type(_,Query)
458 <=> Query = default.
460 % 2. Store type registration
461 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
463 actual_store_types(C,STs) \ update_store_type(C,ST)
464 <=> member(ST,STs) | true.
465 update_store_type(C,ST), actual_store_types(C,STs)
466 <=>
467 actual_store_types(C,[ST|STs]).
468 update_store_type(C,ST)
469 <=>
470 actual_store_types(C,[ST]).
472 % 3. Final decision on store types
473 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
476 <=>
477 chr_pp_flag(experiment,on)
478 |
479 delete(STs,multi_hash([Index]),STs0),
480 Index = [IndexPos],
481 ( get_constraint_type(C,Types),
482 nth1(IndexPos,Types,Type),
483 enumerated_atomic_type(Type,Atoms),
484 sort(Atoms,Keys) ->
485 Completeness = complete
486 ;
487 Completeness = incomplete
488 ),
489 actual_store_types(C,[atomic_constants(Index,Keys,Completeness)|STs0]).
490 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Keys)
491 <=>
492 chr_pp_flag(experiment,on)
493 |
494 delete(STs,multi_hash([Index]),STs0),
495 actual_store_types(C,[ground_constants(Index,Keys)|STs0]).
496 validate_store_type_assumption(C) \ actual_store_types(C,STs)
497 <=>
498 chr_pp_flag(experiment,on),
499 memberchk(multi_hash([[Index]]),STs),
500 get_constraint_type(C,Types),
501 nth1(Index,Types,Type),
502 enumerated_atomic_type(Type,Atoms)
503 |
504 delete(STs,multi_hash([[Index]]),STs0),
505 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
506 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
507 <=>
508 ( chr_pp_flag(experiment,on), forall(member(ST,STs), partial_store(ST)) ->
509 store_type(C,multi_store([global_ground|STs]))
510 ;
511 store_type(C,multi_store(STs))
512 ).
513 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
514 <=>
515 store_type(C,multi_store(STs)).
516 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
517 <=>
518 chr_pp_flag(debugable,on)
519 |
520 store_type(C,default).
521 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
522 <=> store_type(C,global_ground).
523 validate_store_type_assumption(C)
524 <=> true.
526 partial_store(ground_constants(_,_)).
527 partial_store(atomic_constants(_,_,incomplete)).
529 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
530 passive(R,ID) \ passive(R,ID) <=> true.
532 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
533 is_passive(_,_) <=> fail.
535 passive(RuleNb,_) \ any_passive_head(RuleNb)
536 <=> true.
537 any_passive_head(_)
538 <=> fail.
539 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
541 max_occurrence(C,N) \ max_occurrence(C,M)
542 <=> N >= M | true.
544 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
545 NO is MO + 1,
546 occurrence(C,NO,RuleNb,ID,Type),
547 max_occurrence(C,NO).
548 new_occurrence(C,RuleNb,ID,_) <=>
549 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
551 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
552 <=> Q = MON.
553 get_max_occurrence(C,Q)
554 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
556 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
557 <=> Rule = QRule, ID = QID.
558 get_occurrence(C,O,_,_)
559 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
561 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
562 <=> QC = C, QON = ON.
563 get_occurrence_from_id(C,O,_,_)
564 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
566 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
567 % Late allocation
569 late_allocation_analysis(Cs) :-
570 ( chr_pp_flag(late_allocation,on) ->
571 maplist(late_allocation, Cs)
572 ;
573 true
574 ).
576 late_allocation(C) :- late_allocation(C,0).
577 late_allocation(C,O) :- allocation_occurrence(C,O), !.
578 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
580 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
582 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
584 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
585 \+ is_passive(RuleNb,Id),
586 Type == propagation,
587 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
588 true
589 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
590 is_observed(C,O)
591 ; is_least_occurrence(RuleNb) -> % propagation rule
592 is_observed(C,O)
593 ;
594 true
595 ).
597 stored_in_guard_before_next_kept_occurrence(C,O) :-
598 chr_pp_flag(store_in_guards, on),
599 NO is O + 1,
600 stored_in_guard_lookahead(C,NO).
602 :- chr_constraint stored_in_guard_lookahead/2.
603 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
605 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
606 NO is O + 1, stored_in_guard_lookahead(C,NO).
607 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
608 Type == simplification,
609 ( is_stored_in_guard(C,RuleNb) ->
610 true
611 ;
612 NO is O + 1, stored_in_guard_lookahead(C,NO)
613 ).
614 stored_in_guard_lookahead(_,_) <=> fail.
617 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
618 \ least_occurrence(RuleNb,[ID|IDs])
619 <=> AO >= O, \+ may_trigger(C) |
620 least_occurrence(RuleNb,IDs).
621 rule(RuleNb,Rule), passive(RuleNb,ID)
622 \ least_occurrence(RuleNb,[ID|IDs])
623 <=> least_occurrence(RuleNb,IDs).
625 rule(RuleNb,Rule)
626 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
627 least_occurrence(RuleNb,IDs).
629 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
630 <=> true.
631 is_least_occurrence(_)
632 <=> fail.
634 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
635 <=> Q = O.
636 get_allocation_occurrence(_,Q)
637 <=> chr_pp_flag(late_allocation,off), Q=0.
638 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
640 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
641 <=> Q = Rule.
642 get_rule(_,_)
643 <=> fail.
645 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
647 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
648 %
649 % Default store constraint index assignment.
651 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
652 :- chr_option(mode,constraint_index(+,+)).
653 :- chr_option(type_declaration,constraint_index(constraint,int)).
655 :- chr_constraint get_constraint_index/2.
656 :- chr_option(mode,get_constraint_index(+,-)).
657 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
659 :- chr_constraint get_indexed_constraint/2.
660 :- chr_option(mode,get_indexed_constraint(+,-)).
661 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
663 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
664 :- chr_option(mode,max_constraint_index(+)).
665 :- chr_option(type_declaration,max_constraint_index(int)).
667 :- chr_constraint get_max_constraint_index/1.
668 :- chr_option(mode,get_max_constraint_index(-)).
669 :- chr_option(type_declaration,get_max_constraint_index(int)).
671 constraint_index(C,Index) \ get_constraint_index(C,Query)
672 <=> Query = Index.
673 get_constraint_index(C,Query)
674 <=> fail.
676 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
677 <=> Q = C.
678 get_indexed_constraint(Index,Q)
679 <=> fail.
681 max_constraint_index(Index) \ get_max_constraint_index(Query)
682 <=> Query = Index.
683 get_max_constraint_index(Query)
684 <=> Query = 0.
686 set_constraint_indices(Constraints) :-
687 set_constraint_indices(Constraints,1).
688 set_constraint_indices([],M) :-
689 N is M - 1,
690 max_constraint_index(N).
691 set_constraint_indices([C|Cs],N) :-
692 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
693 ; get_store_type(C,var_assoc_store(_,_))) ->
694 constraint_index(C,N),
695 M is N + 1,
696 set_constraint_indices(Cs,M)
697 ;
698 set_constraint_indices(Cs,N)
699 ).
701 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
702 % Identifier Indexes
704 :- chr_constraint identifier_size/1.
705 :- chr_option(mode,identifier_size(+)).
706 :- chr_option(type_declaration,identifier_size(natural)).
708 identifier_size(_) \ identifier_size(_)
709 <=>
710 true.
712 :- chr_constraint get_identifier_size/1.
713 :- chr_option(mode,get_identifier_size(-)).
714 :- chr_option(type_declaration,get_identifier_size(natural)).
716 identifier_size(Size) \ get_identifier_size(Q)
717 <=>
718 Q = Size.
720 get_identifier_size(Q)
721 <=>
722 Q = 1.
724 :- chr_constraint identifier_index/3.
725 :- chr_option(mode,identifier_index(+,+,+)).
726 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
728 identifier_index(C,I,_) \ identifier_index(C,I,_)
729 <=>
730 true.
732 :- chr_constraint get_identifier_index/3.
733 :- chr_option(mode,get_identifier_index(+,+,-)).
734 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
736 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
737 <=>
738 Q = II.
739 identifier_size(Size), get_identifier_index(C,I,Q)
740 <=>
741 NSize is Size + 1,
742 identifier_index(C,I,NSize),
743 identifier_size(NSize),
744 Q = NSize.
745 get_identifier_index(C,I,Q)
746 <=>
747 identifier_index(C,I,2),
748 identifier_size(2),
749 Q = 2.
751 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
752 % Type Indexed Identifier Indexes
754 :- chr_constraint type_indexed_identifier_size/2.
755 :- chr_option(mode,type_indexed_identifier_size(+,+)).
756 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
758 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
759 <=>
760 true.
762 :- chr_constraint get_type_indexed_identifier_size/2.
763 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
764 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
766 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
767 <=>
768 Q = Size.
770 get_type_indexed_identifier_size(IndexType,Q)
771 <=>
772 Q = 1.
774 :- chr_constraint type_indexed_identifier_index/4.
775 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
776 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
778 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
779 <=>
780 true.
782 :- chr_constraint get_type_indexed_identifier_index/4.
783 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
784 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
786 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
787 <=>
788 Q = II.
789 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
790 <=>
791 NSize is Size + 1,
792 type_indexed_identifier_index(IndexType,C,I,NSize),
793 type_indexed_identifier_size(IndexType,NSize),
794 Q = NSize.
795 get_type_indexed_identifier_index(IndexType,C,I,Q)
796 <=>
797 type_indexed_identifier_index(IndexType,C,I,2),
798 type_indexed_identifier_size(IndexType,2),
799 Q = 2.
801 type_indexed_identifier_structure(IndexType,Structure) :-
802 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
803 get_type_indexed_identifier_size(IndexType,Arity),
804 functor(Structure,Functor,Arity).
805 type_indexed_identifier_name(IndexType,Prefix,Name) :-
806 ( atom(IndexType) ->
807 IndexTypeName = IndexType
808 ;
809 term_to_atom(IndexType,IndexTypeName)
810 ),
811 atom_concat_list([Prefix,'_',IndexTypeName],Name).
813 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
818 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
819 %%
820 %% Translation
822 chr_translate(Declarations,NewDeclarations) :-
823 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
825 chr_translate_line_info(Declarations,File,NewDeclarations) :-
826 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',[]),
827 init_chr_pp_flags,
828 chr_source_file(File),
829 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
830 chr_compiler_options:sanity_check,
831 check_declared_constraints(Constraints0),
832 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
833 add_constraints(Constraints),
834 add_rules(Rules1),
835 generate_never_stored_rules(Constraints,NewRules),
836 add_rules(NewRules),
837 append(Rules1,NewRules,Rules),
838 % start analysis
839 check_rules(Rules,Constraints),
840 time('type checking',chr_translate:static_type_check),
841 add_occurrences(Rules),
842 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
843 time('set semantics',chr_translate:set_semantics_rules(Rules)),
844 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
845 time('guard simplification',chr_translate:guard_simplification),
846 time('late storage',chr_translate:storage_analysis(Constraints)),
847 time('observation',chr_translate:observation_analysis(Constraints)),
848 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
849 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
850 partial_wake_analysis,
851 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
852 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
853 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
854 % end analysis
855 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
856 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
857 phase_end(validate_store_type_assumptions),
858 used_states_known,
859 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
860 insert_declarations(OtherClauses, Clauses0),
861 chr_module_declaration(CHRModuleDeclaration),
862 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
863 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
864 append([Clauses0,GeneratedClauses], NewDeclarations).
866 store_management_preds(Constraints,Clauses) :-
867 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
868 generate_attr_unify_hook(AttrUnifyHookClauses),
869 generate_attach_increment(AttachIncrementClauses),
870 generate_extra_clauses(Constraints,ExtraClauses),
871 generate_insert_delete_constraints(Constraints,DeleteClauses),
872 generate_attach_code(Constraints,StoreClauses),
873 generate_counter_code(CounterClauses),
874 generate_dynamic_type_check_clauses(TypeCheckClauses),
875 append([AttachAConstraintClauses
876 ,AttachIncrementClauses
877 ,AttrUnifyHookClauses
878 ,ExtraClauses
879 ,DeleteClauses
880 ,StoreClauses
881 ,CounterClauses
882 ,TypeCheckClauses
883 ]
884 ,Clauses).
887 insert_declarations(Clauses0, Clauses) :-
888 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
889 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
891 auxiliary_module(chr_hashtable_store).
892 auxiliary_module(chr_integertable_store).
893 auxiliary_module(chr_assoc_store).
895 generate_counter_code(Clauses) :-
896 ( chr_pp_flag(store_counter,on) ->
897 Clauses = [
898 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
899 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
900 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
901 (:- '$counter_init'('$insert_counter')),
902 (:- '$counter_init'('$delete_counter')),
903 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
904 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
905 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
906 ]
907 ;
908 Clauses = []
909 ).
911 % for systems with multifile declaration
912 chr_module_declaration(CHRModuleDeclaration) :-
913 get_target_module(Mod),
914 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
915 CHRModuleDeclaration = [
916 (:- multifile chr:'$chr_module'/1),
917 chr:'$chr_module'(Mod)
918 ]
919 ;
920 CHRModuleDeclaration = []
921 ).
924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
925 %%
926 %% Partitioning of clauses into constraint declarations, chr rules and other
927 %% clauses
929 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
930 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
931 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
932 partition_clauses([],[],[],[]).
933 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
934 ( parse_rule(Clause,Rule) ->
935 ConstraintDeclarations = RestConstraintDeclarations,
936 Rules = [Rule|RestRules],
937 OtherClauses = RestOtherClauses
938 ; is_declaration(Clause,ConstraintDeclaration) ->
939 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
940 Rules = RestRules,
941 OtherClauses = RestOtherClauses
942 ; is_module_declaration(Clause,Mod) ->
943 target_module(Mod),
944 ConstraintDeclarations = RestConstraintDeclarations,
945 Rules = RestRules,
946 OtherClauses = [Clause|RestOtherClauses]
947 ; is_type_definition(Clause) ->
948 ConstraintDeclarations = RestConstraintDeclarations,
949 Rules = RestRules,
950 OtherClauses = RestOtherClauses
951 ; Clause = (handler _) ->
952 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
953 ConstraintDeclarations = RestConstraintDeclarations,
954 Rules = RestRules,
955 OtherClauses = RestOtherClauses
956 ; Clause = (rules _) ->
957 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
958 ConstraintDeclarations = RestConstraintDeclarations,
959 Rules = RestRules,
960 OtherClauses = RestOtherClauses
961 ; Clause = option(OptionName,OptionValue) ->
962 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
963 handle_option(OptionName,OptionValue),
964 ConstraintDeclarations = RestConstraintDeclarations,
965 Rules = RestRules,
966 OtherClauses = RestOtherClauses
967 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
968 handle_option(OptionName,OptionValue),
969 ConstraintDeclarations = RestConstraintDeclarations,
970 Rules = RestRules,
971 OtherClauses = RestOtherClauses
972 ; Clause = ('$chr_compiled_with_version'(_)) ->
973 ConstraintDeclarations = RestConstraintDeclarations,
974 Rules = RestRules,
975 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
976 ; ConstraintDeclarations = RestConstraintDeclarations,
977 Rules = RestRules,
978 OtherClauses = [Clause|RestOtherClauses]
979 ),
980 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
982 '$chr_compiled_with_version'(2).
984 is_declaration(D, Constraints) :- %% constraint declaration
985 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
986 conj2list(Cs,Constraints0)
987 ;
988 ( D = (:- Decl) ->
989 Decl =.. [constraints,Cs]
990 ;
991 D =.. [constraints,Cs]
992 ),
993 conj2list(Cs,Constraints0),
994 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
995 ),
996 extract_type_mode(Constraints0,Constraints).
998 extract_type_mode([],[]).
999 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1000 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1001 ( C0 = C # Annotation ->
1002 functor(C,F,A),
1003 extract_annotation(Annotation,F/A)
1004 ;
1005 C0 = C,
1006 functor(C,F,A)
1007 ),
1008 ConstraintSymbol = F/A,
1009 C =.. [_|Args],
1010 extract_types_and_modes(Args,ArgTypes,ArgModes),
1011 assert_constraint_type(ConstraintSymbol,ArgTypes),
1012 constraint_mode(ConstraintSymbol,ArgModes),
1013 extract_type_mode(R,R2).
1015 extract_annotation(stored,Symbol) :-
1016 stored_assertion(Symbol).
1017 extract_annotation(default(Goal),Symbol) :-
1018 never_stored_default(Symbol,Goal).
1020 extract_types_and_modes([],[],[]).
1021 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1022 extract_type_and_mode(X,T,M),
1023 extract_types_and_modes(R,R2,R3).
1025 extract_type_and_mode(+(T),T,(+)) :- !.
1026 extract_type_and_mode(?(T),T,(?)) :- !.
1027 extract_type_and_mode(-(T),T,(-)) :- !.
1028 extract_type_and_mode((+),any,(+)) :- !.
1029 extract_type_and_mode((?),any,(?)) :- !.
1030 extract_type_and_mode((-),any,(-)) :- !.
1031 extract_type_and_mode(Illegal,_,_) :-
1032 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1034 is_type_definition(Declaration) :-
1035 ( Declaration = (:- TDef) ->
1036 true
1037 ;
1038 Declaration = TDef
1039 ),
1040 TDef =.. [chr_type,TypeDef],
1041 ( TypeDef = (Name ---> Def) ->
1042 tdisj2list(Def,DefList),
1043 type_definition(Name,DefList)
1044 ; TypeDef = (Alias == Name) ->
1045 type_alias(Alias,Name)
1046 ;
1047 type_definition(TypeDef,[]),
1048 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1049 ).
1051 %% tdisj2list(+Goal,-ListOfGoals) is det.
1052 %
1053 % no removal of fails, e.g. :- type bool ---> true ; fail.
1054 tdisj2list(Conj,L) :-
1055 tdisj2list(Conj,L,[]).
1057 tdisj2list(Conj,L,T) :-
1058 Conj = (G1;G2), !,
1059 tdisj2list(G1,L,T1),
1060 tdisj2list(G2,T1,T).
1061 tdisj2list(G,[G | T],T).
1064 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1065 %% parse_rule(+term,-pragma_rule) is semidet.
1066 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1067 parse_rule(RI,R) :- %% name @ rule
1068 RI = (Name @ RI2), !,
1069 rule(RI2,yes(Name),R).
1070 parse_rule(RI,R) :-
1071 rule(RI,no,R).
1073 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1074 %% parse_rule(+term,-pragma_rule) is semidet.
1075 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1076 rule(RI,Name,R) :-
1077 RI = (RI2 pragma P), !, %% pragmas
1078 ( var(P) ->
1079 Ps = [_] % intercept variable
1080 ;
1081 conj2list(P,Ps)
1082 ),
1083 inc_rule_count(RuleCount),
1084 R = pragma(R1,IDs,Ps,Name,RuleCount),
1085 is_rule(RI2,R1,IDs,R).
1086 rule(RI,Name,R) :-
1087 inc_rule_count(RuleCount),
1088 R = pragma(R1,IDs,[],Name,RuleCount),
1089 is_rule(RI,R1,IDs,R).
1091 is_rule(RI,R,IDs,RC) :- %% propagation rule
1092 RI = (H ==> B), !,
1093 conj2list(H,Head2i),
1094 get_ids(Head2i,IDs2,Head2,RC),
1095 IDs = ids([],IDs2),
1096 ( B = (G | RB) ->
1097 R = rule([],Head2,G,RB)
1098 ;
1099 R = rule([],Head2,true,B)
1100 ).
1101 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1102 RI = (H <=> B), !,
1103 ( B = (G | RB) ->
1104 Guard = G,
1105 Body = RB
1106 ; Guard = true,
1107 Body = B
1108 ),
1109 ( H = (H1 \ H2) ->
1110 conj2list(H1,Head2i),
1111 conj2list(H2,Head1i),
1112 get_ids(Head2i,IDs2,Head2,0,N,RC),
1113 get_ids(Head1i,IDs1,Head1,N,_,RC),
1114 IDs = ids(IDs1,IDs2)
1115 ; conj2list(H,Head1i),
1116 Head2 = [],
1117 get_ids(Head1i,IDs1,Head1,RC),
1118 IDs = ids(IDs1,[])
1119 ),
1120 R = rule(Head1,Head2,Guard,Body).
1122 get_ids(Cs,IDs,NCs,RC) :-
1123 get_ids(Cs,IDs,NCs,0,_,RC).
1125 get_ids([],[],[],N,N,_).
1126 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1127 ( C = (NC # N1) ->
1128 ( var(N1) ->
1129 N1 = N
1130 ;
1131 check_direct_pragma(N1,N,RC)
1132 )
1133 ;
1134 NC = C
1135 ),
1136 M is N + 1,
1137 get_ids(Cs,IDs,NCs, M,NN,RC).
1139 check_direct_pragma(passive,Id,PragmaRule) :- !,
1140 PragmaRule = pragma(_,_,_,_,RuleNb),
1141 passive(RuleNb,Id).
1142 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1143 ( direct_pragma(FullPragma),
1144 atom_concat(Abbrev,Remainder,FullPragma) ->
1145 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1146 ;
1147 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1148 ).
1150 direct_pragma(passive).
1152 is_module_declaration((:- module(Mod)),Mod).
1153 is_module_declaration((:- module(Mod,_)),Mod).
1155 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1157 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1158 % Add constraints
1159 add_constraints([]).
1160 add_constraints([C|Cs]) :-
1161 max_occurrence(C,0),
1162 C = _/A,
1163 length(Mode,A),
1164 set_elems(Mode,?),
1165 constraint_mode(C,Mode),
1166 add_constraints(Cs).
1168 % Add rules
1169 add_rules([]).
1170 add_rules([Rule|Rules]) :-
1171 Rule = pragma(_,_,_,_,RuleNb),
1172 rule(RuleNb,Rule),
1173 add_rules(Rules).
1175 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1177 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1178 %% Some input verification:
1180 check_declared_constraints(Constraints) :-
1181 check_declared_constraints(Constraints,[]).
1183 check_declared_constraints([],_).
1184 check_declared_constraints([C|Cs],Acc) :-
1185 ( memberchk_eq(C,Acc) ->
1186 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1187 ;
1188 true
1189 ),
1190 check_declared_constraints(Cs,[C|Acc]).
1192 %% - all constraints in heads are declared constraints
1193 %% - all passive pragmas refer to actual head constraints
1195 check_rules([],_).
1196 check_rules([PragmaRule|Rest],Decls) :-
1197 check_rule(PragmaRule,Decls),
1198 check_rules(Rest,Decls).
1200 check_rule(PragmaRule,Decls) :-
1201 check_rule_indexing(PragmaRule),
1202 check_trivial_propagation_rule(PragmaRule),
1203 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1204 Rule = rule(H1,H2,_,_),
1205 append(H1,H2,HeadConstraints),
1206 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1207 check_pragmas(Pragmas,PragmaRule).
1209 % Make all heads passive in trivial propagation rule
1210 % ... ==> ... | true.
1211 check_trivial_propagation_rule(PragmaRule) :-
1212 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1213 ( Rule = rule([],_,_,true) ->
1214 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1215 set_all_passive(RuleNb)
1216 ;
1217 true
1218 ).
1220 check_head_constraints([],_,_).
1221 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1222 functor(Constr,F,A),
1223 ( member(F/A,Decls) ->
1224 check_head_constraints(Rest,Decls,PragmaRule)
1225 ;
1226 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1227 ).
1229 check_pragmas([],_).
1230 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1231 check_pragma(Pragma,PragmaRule),
1232 check_pragmas(Pragmas,PragmaRule).
1234 check_pragma(Pragma,PragmaRule) :-
1235 var(Pragma), !,
1236 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1237 check_pragma(passive(ID), PragmaRule) :-
1238 !,
1239 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1240 ( memberchk_eq(ID,IDs1) ->
1241 true
1242 ; memberchk_eq(ID,IDs2) ->
1243 true
1244 ;
1245 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1246 ),
1247 passive(RuleNb,ID).
1249 check_pragma(mpassive(IDs), PragmaRule) :-
1250 !,
1251 PragmaRule = pragma(_,_,_,_,RuleNb),
1252 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1253 maplist(passive(RuleNb),IDs).
1255 check_pragma(Pragma, PragmaRule) :-
1256 Pragma = already_in_heads,
1257 !,
1258 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1260 check_pragma(Pragma, PragmaRule) :-
1261 Pragma = already_in_head(_),
1262 !,
1263 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1265 check_pragma(Pragma, PragmaRule) :-
1266 Pragma = no_history,
1267 !,
1268 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1269 PragmaRule = pragma(_,_,_,_,N),
1270 no_history(N).
1272 check_pragma(Pragma, PragmaRule) :-
1273 Pragma = history(HistoryName,IDs),
1274 !,
1275 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1276 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1277 ( IDs1 \== [] ->
1278 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1279 ; \+ atom(HistoryName) ->
1280 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1281 ; \+ is_set(IDs) ->
1282 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1283 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1284 history(RuleNb,HistoryName,IDs)
1285 ;
1286 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1287 ).
1288 check_pragma(Pragma,PragmaRule) :-
1289 Pragma = line_number(LineNumber),
1290 !,
1291 PragmaRule = pragma(_,_,_,_,RuleNb),
1292 line_number(RuleNb,LineNumber).
1294 check_history_pragma_ids([], _, _).
1295 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1296 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1297 check_history_pragma_ids(IDs,IDs1,IDs2).
1299 check_pragma(Pragma,PragmaRule) :-
1300 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1302 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1303 %% no_history(+RuleNb) is det.
1304 :- chr_constraint no_history/1.
1305 :- chr_option(mode,no_history(+)).
1306 :- chr_option(type_declaration,no_history(int)).
1308 %% has_no_history(+RuleNb) is semidet.
1309 :- chr_constraint has_no_history/1.
1310 :- chr_option(mode,has_no_history(+)).
1311 :- chr_option(type_declaration,has_no_history(int)).
1313 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1314 has_no_history(_) <=> fail.
1316 :- chr_constraint history/3.
1317 :- chr_option(mode,history(+,+,+)).
1318 :- chr_option(type_declaration,history(any,any,list)).
1320 :- chr_constraint named_history/3.
1322 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1323 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1325 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1326 length(IDs1,L1), length(IDs2,L2),
1327 ( L1 \== L2 ->
1328 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1329 ;
1330 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1331 ).
1333 test_named_history_id_pairs(_, [], _, []).
1334 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1335 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1336 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1338 :- chr_constraint test_named_history_id_pair/4.
1339 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1341 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1342 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1343 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1344 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1346 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1347 named_history(_,_,_) <=> fail.
1349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1352 format_rule(PragmaRule) :-
1353 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1354 ( MaybeName = yes(Name) ->
1355 write('rule '), write(Name)
1356 ;
1357 write('rule number '), write(RuleNumber)
1358 ),
1359 get_line_number(RuleNumber,LineNumber),
1360 write(' (line '),
1361 write(LineNumber),
1362 write(')').
1364 check_rule_indexing(PragmaRule) :-
1365 PragmaRule = pragma(Rule,_,_,_,_),
1366 Rule = rule(H1,H2,G,_),
1367 term_variables(H1-H2,HeadVars),
1368 remove_anti_monotonic_guards(G,HeadVars,NG),
1369 check_indexing(H1,NG-H2),
1370 check_indexing(H2,NG-H1),
1371 % EXPERIMENT
1372 ( chr_pp_flag(term_indexing,on) ->
1373 term_variables(NG,GuardVariables),
1374 append(H1,H2,Heads),
1375 check_specs_indexing(Heads,GuardVariables,Specs)
1376 ;
1377 true
1378 ).
1380 :- chr_constraint indexing_spec/2.
1381 :- chr_option(mode,indexing_spec(+,+)).
1383 :- chr_constraint get_indexing_spec/2.
1384 :- chr_option(mode,get_indexing_spec(+,-)).
1387 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1388 get_indexing_spec(_,Spec) <=> Spec = [].
1390 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1391 <=>
1392 append(Specs1,Specs2,Specs),
1393 indexing_spec(FA,Specs).
1395 remove_anti_monotonic_guards(G,Vars,NG) :-
1396 conj2list(G,GL),
1397 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1398 list2conj(NGL,NG).
1400 remove_anti_monotonic_guard_list([],_,[]).
1401 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1402 ( G = var(X), memberchk_eq(X,Vars) ->
1403 NGs = RGs
1404 % TODO: this is not correct
1405 % ; G = functor(Term,Functor,Arity), % isotonic
1406 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1407 % NGs = RGs
1408 ;
1409 NGs = [G|RGs]
1410 ),
1411 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1413 check_indexing([],_).
1414 check_indexing([Head|Heads],Other) :-
1415 functor(Head,F,A),
1416 Head =.. [_|Args],
1417 term_variables(Heads-Other,OtherVars),
1418 check_indexing(Args,1,F/A,OtherVars),
1419 check_indexing(Heads,[Head|Other]).
1421 check_indexing([],_,_,_).
1422 check_indexing([Arg|Args],I,FA,OtherVars) :-
1423 ( is_indexed_argument(FA,I) ->
1424 true
1425 ; nonvar(Arg) ->
1426 indexed_argument(FA,I)
1427 ; % var(Arg) ->
1428 term_variables(Args,ArgsVars),
1429 append(ArgsVars,OtherVars,RestVars),
1430 ( memberchk_eq(Arg,RestVars) ->
1431 indexed_argument(FA,I)
1432 ;
1433 true
1434 )
1435 ),
1436 J is I + 1,
1437 term_variables(Arg,NVars),
1438 append(NVars,OtherVars,NOtherVars),
1439 check_indexing(Args,J,FA,NOtherVars).
1441 check_specs_indexing([],_,[]).
1442 check_specs_indexing([Head|Heads],Variables,Specs) :-
1443 Specs = [Spec|RSpecs],
1444 term_variables(Heads,OtherVariables,Variables),
1445 check_spec_indexing(Head,OtherVariables,Spec),
1446 term_variables(Head,NVariables,Variables),
1447 check_specs_indexing(Heads,NVariables,RSpecs).
1449 check_spec_indexing(Head,OtherVariables,Spec) :-
1450 functor(Head,F,A),
1451 Spec = spec(F,A,ArgSpecs),
1452 Head =.. [_|Args],
1453 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1454 indexing_spec(F/A,[ArgSpecs]).
1456 check_args_spec_indexing([],_,_,[]).
1457 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1458 term_variables(Args,Variables,OtherVariables),
1459 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1460 ArgSpecs = [ArgSpec|RArgSpecs]
1461 ;
1462 ArgSpecs = RArgSpecs
1463 ),
1464 J is I + 1,
1465 term_variables(Arg,NOtherVariables,OtherVariables),
1466 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1468 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1469 ( var(Arg) ->
1470 memberchk_eq(Arg,Variables),
1471 ArgSpec = specinfo(I,any,[])
1472 ;
1473 functor(Arg,F,A),
1474 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1475 Arg =.. [_|Args],
1476 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1477 ).
1479 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1481 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1482 % Occurrences
1484 add_occurrences([]).
1485 add_occurrences([Rule|Rules]) :-
1486 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1487 add_occurrences(H1,IDs1,simplification,Nb),
1488 add_occurrences(H2,IDs2,propagation,Nb),
1489 add_occurrences(Rules).
1491 add_occurrences([],[],_,_).
1492 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1493 functor(H,F,A),
1494 FA = F/A,
1495 new_occurrence(FA,RuleNb,ID,Type),
1496 add_occurrences(Hs,IDs,Type,RuleNb).
1498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1500 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1501 % Observation Analysis
1502 %
1503 % CLASSIFICATION
1504 %
1505 %
1506 %
1507 %
1508 %
1509 %
1511 :- chr_constraint observation_analysis/1.
1512 :- chr_option(mode, observation_analysis(+)).
1514 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1515 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1516 ( chr_pp_flag(store_in_guards, on) ->
1517 observation_analysis(RuleNb, Guard, guard, Cs)
1518 ;
1519 true
1520 ),
1521 observation_analysis(RuleNb, Body, body, Cs)
1523 pragma passive(Id).
1524 observation_analysis(_) <=> true.
1526 observation_analysis(RuleNb, Term, GB, Cs) :-
1527 ( all_spawned(RuleNb,GB) ->
1528 true
1529 ; var(Term) ->
1530 spawns_all(RuleNb,GB)
1531 ; Term = true ->
1532 true
1533 ; Term = fail ->
1534 true
1535 ; Term = '!' ->
1536 true
1537 ; Term = (T1,T2) ->
1538 observation_analysis(RuleNb,T1,GB,Cs),
1539 observation_analysis(RuleNb,T2,GB,Cs)
1540 ; Term = (T1;T2) ->
1541 observation_analysis(RuleNb,T1,GB,Cs),
1542 observation_analysis(RuleNb,T2,GB,Cs)
1543 ; Term = (T1->T2) ->
1544 observation_analysis(RuleNb,T1,GB,Cs),
1545 observation_analysis(RuleNb,T2,GB,Cs)
1546 ; Term = (\+ T) ->
1547 observation_analysis(RuleNb,T,GB,Cs)
1548 ; functor(Term,F,A), member(F/A,Cs) ->
1549 spawns(RuleNb,GB,F/A)
1550 ; Term = (_ = _) ->
1551 spawns_all_triggers(RuleNb,GB)
1552 ; Term = (_ is _) ->
1553 spawns_all_triggers(RuleNb,GB)
1554 ; builtin_binds_b(Term,Vars) ->
1555 ( Vars == [] ->
1556 true
1557 ;
1558 spawns_all_triggers(RuleNb,GB)
1559 )
1560 ;
1561 spawns_all(RuleNb,GB)
1562 ).
1564 :- chr_constraint spawns/3.
1565 :- chr_option(mode, spawns(+,+,+)).
1566 :- chr_type spawns_type ---> guard ; body.
1567 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1569 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1570 :- chr_option(mode, spawns_all(+,+)).
1571 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1572 :- chr_option(mode, spawns_all_triggers(+,+)).
1573 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1575 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1576 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1577 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1578 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1579 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1580 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1582 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1583 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1584 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1585 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1587 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1588 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1590 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1591 \
1592 spawns(RuleNb1,GB,C1)
1593 <=>
1594 \+ is_passive(RuleNb2,O)
1595 |
1596 spawns_all(RuleNb1,GB)
1597 pragma
1598 passive(Id).
1600 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1601 ==>
1602 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1603 \+ is_passive(RuleNb2,O), may_trigger(C1)
1604 |
1605 spawns_all_triggers_implies_spawns_all
1606 pragma
1607 passive(Id).
1609 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1610 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1611 spawns_all_triggers_implies_spawns_all \
1612 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1614 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1615 \
1616 spawns(RuleNb1,GB,C1)
1617 <=>
1618 may_trigger(C1),
1619 \+ is_passive(RuleNb2,O)
1620 |
1621 spawns_all_triggers(RuleNb1,GB)
1622 pragma
1623 passive(Id).
1625 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1626 spawns(RuleNb1,GB,C1)
1627 ==>
1628 \+ may_trigger(C1),
1629 \+ is_passive(RuleNb2,O)
1630 |
1631 spawns_all_triggers(RuleNb1,GB)
1632 pragma
1633 passive(Id).
1635 % a bit dangerous this rule: could start propagating too much too soon?
1636 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1637 spawns(RuleNb1,GB,C1)
1638 ==>
1639 RuleNb1 \== RuleNb2, C1 \== C2,
1640 \+ is_passive(RuleNb2,O)
1641 |
1642 spawns(RuleNb1,GB,C2)
1643 pragma
1644 passive(Id).
1646 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1647 spawns_all_triggers(RuleNb1,GB)
1648 ==>
1649 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1650 |
1651 spawns(RuleNb1,GB,C2)
1652 pragma
1653 passive(Id).
1656 :- chr_constraint all_spawned/2.
1657 :- chr_option(mode, all_spawned(+,+)).
1658 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1659 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1660 all_spawned(RuleNb,GB) <=> fail.
1663 % Overview of the supported queries:
1664 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1665 % only succeeds if the occurrence is observed by the
1666 % guard resp. body (depending on the last argument) of its rule
1667 % is_observed(+functor/artiy, +occurrence_number, -)
1668 % succeeds if the occurrence is observed by either the guard or
1669 % the body of its rule
1670 % NOTE: the last argument is NOT bound by this query
1671 %
1672 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1673 % succeeds if the given constraint is observed by the given
1674 % guard resp. body
1675 % do_is_observed(+functor/artiy,+rule_number)
1676 % succeeds if the given constraint is observed by the given
1677 % rule (either its guard or its body)
1680 is_observed(C,O) :-
1681 is_observed(C,O,_),
1682 ai_is_observed(C,O).
1684 is_stored_in_guard(C,RuleNb) :-
1685 chr_pp_flag(store_in_guards, on),
1686 do_is_observed(C,RuleNb,guard).
1688 :- chr_constraint is_observed/3.
1689 :- chr_option(mode, is_observed(+,+,+)).
1690 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1691 is_observed(_,_,_) <=> fail. % this will not happen in practice
1694 :- chr_constraint do_is_observed/3.
1695 :- chr_option(mode, do_is_observed(+,+,+)).
1696 :- chr_constraint do_is_observed/2.
1697 :- chr_option(mode, do_is_observed(+,+)).
1699 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1701 % (1) spawns_all
1702 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1703 % and some non-passive occurrence of some (possibly other) constraint
1704 % exists in a rule (could be same rule) with at least one occurrence of C
1706 spawns_all(RuleNb,GB),
1707 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1708 \
1709 do_is_observed(C,RuleNb,GB)
1710 <=>
1711 \+ is_passive(RuleNb2,O)
1712 |
1713 true.
1715 spawns_all(RuleNb,_),
1716 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1717 \
1718 do_is_observed(C,RuleNb)
1719 <=>
1720 \+ is_passive(RuleNb2,O)
1721 |
1722 true.
1724 % (2) spawns
1725 % a constraint C is observed if the GB of the rule it occurs in spawns a
1726 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1727 % as an occurrence of C
1729 spawns(RuleNb,GB,C2),
1730 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1731 \
1732 do_is_observed(C,RuleNb,GB)
1733 <=>
1734 \+ is_passive(RuleNb2,O)
1735 |
1736 true.
1738 spawns(RuleNb,_,C2),
1739 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1740 \
1741 do_is_observed(C,RuleNb)
1742 <=>
1743 \+ is_passive(RuleNb2,O)
1744 |
1745 true.
1747 % (3) spawns_all_triggers
1748 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1749 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1750 % exists in a rule (could be same rule) with at least one occurrence of C
1752 spawns_all_triggers(RuleNb,GB),
1753 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1754 \
1755 do_is_observed(C,RuleNb,GB)
1756 <=>
1757 \+ is_passive(RuleNb2,O), may_trigger(C2)
1758 |
1759 true.
1761 spawns_all_triggers(RuleNb,_),
1762 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1763 \
1764 do_is_observed(C,RuleNb)
1765 <=>
1766 \+ is_passive(RuleNb2,O), may_trigger(C2)
1767 |
1768 true.
1770 % (4) conservativeness
1771 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1772 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1775 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1777 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1779 %%
1780 %% Generated predicates
1781 %% attach_$CONSTRAINT
1782 %% attach_increment
1783 %% detach_$CONSTRAINT
1784 %% attr_unify_hook
1786 %% attach_$CONSTRAINT
1787 generate_attach_detach_a_constraint_all([],[]).
1788 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1789 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1790 generate_attach_a_constraint(Constraint,Clauses1),
1791 generate_detach_a_constraint(Constraint,Clauses2)
1792 ;
1793 Clauses1 = [],
1794 Clauses2 = []
1795 ),
1796 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1797 append([Clauses1,Clauses2,Clauses3],Clauses).
1799 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1800 generate_attach_a_constraint_nil(Constraint,Clause1),
1801 generate_attach_a_constraint_cons(Constraint,Clause2).
1803 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1804 make_name('attach_',FA,Name),
1805 Atom =.. [Name,Vars,Susp].
1807 generate_attach_a_constraint_nil(FA,Clause) :-
1808 Clause = (Head :- true),
1809 attach_constraint_atom(FA,[],_,Head).
1811 generate_attach_a_constraint_cons(FA,Clause) :-
1812 Clause = (Head :- Body),
1813 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1814 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1815 Body = ( AttachBody, Subscribe, RecursiveCall ),
1816 get_max_constraint_index(N),
1817 ( N == 1 ->
1818 generate_attach_body_1(FA,Var,Susp,AttachBody)
1819 ;
1820 generate_attach_body_n(FA,Var,Susp,AttachBody)
1821 ),
1822 % SWI-Prolog specific code
1823 chr_pp_flag(solver_events,NMod),
1824 ( NMod \== none ->
1825 Args = [[Var|_],Susp],
1826 get_target_module(Mod),
1827 use_auxiliary_predicate(run_suspensions),
1828 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1829 ;
1830 Subscribe = true
1831 ).
1833 generate_attach_body_1(FA,Var,Susp,Body) :-
1834 get_target_module(Mod),
1835 Body =
1836 ( get_attr(Var, Mod, Susps) ->
1837 put_attr(Var, Mod, [Susp|Susps])
1838 ;
1839 put_attr(Var, Mod, [Susp])
1840 ).
1842 generate_attach_body_n(F/A,Var,Susp,Body) :-
1843 get_constraint_index(F/A,Position),
1844 get_max_constraint_index(Total),
1845 get_target_module(Mod),
1846 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1847 singleton_attr(Total,Susp,Position,NewAttr3),
1848 Body =
1849 ( get_attr(Var,Mod,TAttr) ->
1850 AddGoal,
1851 put_attr(Var,Mod,NTAttr)
1852 ;
1853 put_attr(Var,Mod,NewAttr3)
1854 ), !.
1856 %% detach_$CONSTRAINT
1857 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1858 generate_detach_a_constraint_nil(Constraint,Clause1),
1859 generate_detach_a_constraint_cons(Constraint,Clause2).
1861 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1862 make_name('detach_',FA,Name),
1863 Atom =.. [Name,Vars,Susp].
1865 generate_detach_a_constraint_nil(FA,Clause) :-
1866 Clause = ( Head :- true),
1867 detach_constraint_atom(FA,[],_,Head).
1869 generate_detach_a_constraint_cons(FA,Clause) :-
1870 Clause = (Head :- Body),
1871 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1872 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1873 Body = ( DetachBody, RecursiveCall ),
1874 get_max_constraint_index(N),
1875 ( N == 1 ->
1876 generate_detach_body_1(FA,Var,Susp,DetachBody)
1877 ;
1878 generate_detach_body_n(FA,Var,Susp,DetachBody)
1879 ).
1881 generate_detach_body_1(FA,Var,Susp,Body) :-
1882 get_target_module(Mod),
1883 Body =
1884 ( get_attr(Var,Mod,Susps) ->
1885 'chr sbag_del_element'(Susps,Susp,NewSusps),
1886 ( NewSusps == [] ->
1887 del_attr(Var,Mod)
1888 ;
1889 put_attr(Var,Mod,NewSusps)
1890 )
1891 ;
1892 true
1893 ).
1895 generate_detach_body_n(F/A,Var,Susp,Body) :-
1896 get_constraint_index(F/A,Position),
1897 get_max_constraint_index(Total),
1898 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1899 get_target_module(Mod),
1900 Body =
1901 ( get_attr(Var,Mod,TAttr) ->
1902 RemGoal
1903 ;
1904 true
1905 ), !.
1907 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1908 %-------------------------------------------------------------------------------
1909 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1910 :- chr_constraint generate_indexed_variables_body/4.
1911 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1912 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1913 %-------------------------------------------------------------------------------
1914 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1915 get_indexing_spec(F/A,Specs),
1916 ( chr_pp_flag(term_indexing,on) ->
1917 spectermvars(Specs,Args,F,A,Body,Vars)
1918 ;
1919 get_constraint_type_det(F/A,ArgTypes),
1920 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1921 ( MaybeBody == empty ->
1922 Body = true,
1923 Vars = []
1924 ; N == 0 ->
1925 ( Args = [Term] ->
1926 true
1927 ;
1928 Term =.. [term|Args]
1929 ),
1930 Body = term_variables(Term,Vars)
1931 ;
1932 MaybeBody = Body
1933 )
1934 ).
1935 generate_indexed_variables_body(FA,_,_,_) <=>
1936 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1937 %===============================================================================
1939 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1940 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1941 J is I + 1,
1942 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1943 ( Mode == (?),
1944 is_indexed_argument(FA,I) ->
1945 ( atomic_type(Type) ->
1946 Body =
1947 (
1948 ( var(V) ->
1949 Vars = [V|Tail]
1950 ;
1951 Vars = Tail
1952 ),
1953 Continuation
1954 ),
1955 ( RBody == empty ->
1956 Continuation = true, Tail = []
1957 ;
1958 Continuation = RBody
1959 )
1960 ;
1961 ( RBody == empty ->
1962 Body = term_variables(V,Vars)
1963 ;
1964 Body = (term_variables(V,Vars,Tail),RBody)
1965 )
1966 ),
1967 N = M
1968 ; Mode == (-), is_indexed_argument(FA,I) ->
1969 ( RBody == empty ->
1970 Body = (Vars = [V])
1971 ;
1972 Body = (Vars = [V|Tail],RBody)
1973 ),
1974 N is M + 1
1975 ;
1976 Vars = Tail,
1977 Body = RBody,
1978 N is M + 1
1979 ).
1980 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1981 % EXPERIMENTAL
1982 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1983 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1985 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1986 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1987 Goal = (ArgGoal,RGoal),
1988 argspecs(Specs,I,TempArgSpecs,RSpecs),
1989 merge_argspecs(TempArgSpecs,ArgSpecs),
1990 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1991 J is I + 1,
1992 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1994 argspecs([],_,[],[]).
1995 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1996 argspecs(Rest,I,ArgSpecs,RestSpecs).
1997 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1998 ( I == J ->
1999 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2000 ( Specs = [] ->
2001 RRestSpecs = RestSpecs
2002 ;
2003 RestSpecs = [Specs|RRestSpecs]
2004 )
2005 ;
2006 ArgSpecs = RArgSpecs,
2007 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2008 ),
2009 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2011 merge_argspecs(In,Out) :-
2012 sort(In,Sorted),
2013 merge_argspecs_(Sorted,Out).
2015 merge_argspecs_([],[]).
2016 merge_argspecs_([X],R) :- !, R = [X].
2017 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2018 ( (F1 == any ; F2 == any) ->
2019 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2020 ; F1 == F2 ->
2021 append(A1,A2,A),
2022 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2023 ;
2024 R = [specinfo(I,F1,A1)|RR],
2025 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2026 ).
2028 arggoal(List,Arg,Goal,L,T) :-
2029 ( List == [] ->
2030 L = T,
2031 Goal = true
2032 ; List = [specinfo(_,any,_)] ->
2033 Goal = term_variables(Arg,L,T)
2034 ;
2035 Goal =
2036 ( var(Arg) ->
2037 L = [Arg|T]
2038 ;
2039 Cases
2040 ),
2041 arggoal_cases(List,Arg,L,T,Cases)
2042 ).
2044 arggoal_cases([],_,L,T,L=T).
2045 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2046 ( ArgSpecs == [] ->
2047 Cases = RCases
2048 ; ArgSpecs == [[]] ->
2049 Cases = RCases
2050 ; FA = F/A ->
2051 Cases = (Case ; RCases),
2052 functor(Term,F,A),
2053 Term =.. [_|Args],
2054 Case = (Arg = Term -> ArgsGoal),
2055 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2056 ),
2057 arggoal_cases(Rest,Arg,L,T,RCases).
2058 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2060 generate_extra_clauses(Constraints,List) :-
2061 generate_activate_clauses(Constraints,List,Tail0),
2062 generate_remove_clauses(Constraints,Tail0,Tail1),
2063 generate_allocate_clauses(Constraints,Tail1,Tail2),
2064 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2065 generate_novel_production(Tail3,Tail4),
2066 generate_extend_history(Tail4,Tail5),
2067 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2068 generate_empty_named_history_initialisations(Tail6,Tail7),
2069 Tail7 = [].
2071 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2072 % remove_constraint_internal/[1/3]
2074 generate_remove_clauses([],List,List).
2075 generate_remove_clauses([C|Cs],List,Tail) :-
2076 generate_remove_clause(C,List,List1),
2077 generate_remove_clauses(Cs,List1,Tail).
2079 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2080 uses_state(Constraint,removed),
2081 ( chr_pp_flag(inline_insertremove,off) ->
2082 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2083 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2084 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2085 ;
2086 delay_phase_end(validate_store_type_assumptions,
2087 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2088 )
2089 ).
2091 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2092 make_name('$remove_constraint_internal_',Constraint,Name),
2093 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2094 Goal =.. [Name, Susp,Delete]
2095 ;
2096 Goal =.. [Name,Susp,Agenda,Delete]
2097 ).
2099 generate_remove_clause(Constraint,List,Tail) :-
2100 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2101 List = [RemoveClause|Tail],
2102 RemoveClause = (Head :- RemoveBody),
2103 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2104 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2105 ;
2106 List = Tail
2107 ).
2109 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2110 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2111 ( Role == active ->
2112 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2113 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2114 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2115 ; Role == partner ->
2116 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2117 GetStateValue = true,
2118 MaybeDelete = DeleteYes
2119 ),
2120 RemoveBody =
2121 (
2122 GetState,
2123 GetStateValue,
2124 UpdateState,
2125 MaybeDelete
2126 )
2127 ;
2128 static_suspension_term(Constraint,Susp2),
2129 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2130 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2131 ( chr_pp_flag(debugable,on) ->
2132 Constraint = Functor / _,
2133 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2134 ;
2135 true
2136 ),
2137 ( Role == active ->
2138 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2139 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2140 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2141 ; Role == partner ->
2142 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2143 GetStateValue = true,
2144 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2145 ),
2146 RemoveBody =
2147 (
2148 Susp = Susp2,
2149 GetStateValue,
2150 UpdateState,
2151 MaybeDelete
2152 )
2153 ).
2155 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2156 % activate_constraint/4
2158 generate_activate_clauses([],List,List).
2159 generate_activate_clauses([C|Cs],List,Tail) :-
2160 generate_activate_clause(C,List,List1),
2161 generate_activate_clauses(Cs,List1,Tail).
2163 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2164 ( chr_pp_flag(inline_insertremove,off) ->
2165 use_auxiliary_predicate(activate_constraint,Constraint),
2166 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2167 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2168 ;
2169 delay_phase_end(validate_store_type_assumptions,
2170 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2171 )
2172 ).
2174 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2175 make_name('$activate_constraint_',Constraint,Name),
2176 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2177 Goal =.. [Name,Store, Susp]
2178 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2179 Goal =.. [Name,Store, Susp, Generation]
2180 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2181 Goal =.. [Name,Store, Vars, Susp, Generation]
2182 ;
2183 Goal =.. [Name,Store, Vars, Susp]
2184 ).
2186 generate_activate_clause(Constraint,List,Tail) :-
2187 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2188 List = [Clause|Tail],
2189 Clause = (Head :- Body),
2190 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2191 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2192 ;
2193 List = Tail
2194 ).
2196 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2197 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2198 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2199 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2200 ;
2201 GenerationHandling = true
2202 ),
2203 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2204 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2205 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2206 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2207 ;
2208 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2209 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2210 ( chr_pp_flag(guard_locks,off) ->
2211 NoneLocked = true
2212 ;
2213 NoneLocked = 'chr none_locked'( Vars)
2214 ),
2215 if_used_state(Constraint,not_stored_yet,
2216 ( State == not_stored_yet ->
2217 ArgumentsGoal,
2218 IndexedVariablesBody,
2219 NoneLocked,
2220 StoreYes
2221 ;
2222 % Vars = [],
2223 StoreNo
2224 ),
2225 % (Vars = [],StoreNo),StoreVarsGoal)
2226 StoreNo,StoreVarsGoal)
2227 ),
2228 Body =
2229 (
2230 GetState,
2231 GetStateValue,
2232 UpdateState,
2233 GenerationHandling,
2234 StoreVarsGoal
2235 ).
2236 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2237 % allocate_constraint/4
2239 generate_allocate_clauses([],List,List).
2240 generate_allocate_clauses([C|Cs],List,Tail) :-
2241 generate_allocate_clause(C,List,List1),
2242 generate_allocate_clauses(Cs,List1,Tail).
2244 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2245 uses_state(Constraint,not_stored_yet),
2246 ( chr_pp_flag(inline_insertremove,off) ->
2247 use_auxiliary_predicate(allocate_constraint,Constraint),
2248 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2249 ;
2250 Goal = (Susp = Suspension, Goal0),
2251 delay_phase_end(validate_store_type_assumptions,
2252 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2253 )
2254 ).
2256 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2257 make_name('$allocate_constraint_',Constraint,Name),
2258 Goal =.. [Name,Susp|Args].
2260 generate_allocate_clause(Constraint,List,Tail) :-
2261 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2262 List = [Clause|Tail],
2263 Clause = (Head :- Body),
2264 Constraint = _/A,
2265 length(Args,A),
2266 allocate_constraint_atom(Constraint,Susp,Args,Head),
2267 allocate_constraint_body(Constraint,Susp,Args,Body)
2268 ;
2269 List = Tail
2270 ).
2272 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2273 static_suspension_term(Constraint,Suspension),
2274 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2275 ( chr_pp_flag(debugable,on) ->
2276 Constraint = Functor / _,
2277 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2278 ;
2279 true
2280 ),
2281 ( chr_pp_flag(debugable,on) ->
2282 ( may_trigger(Constraint) ->
2283 append(Args,[Susp],VarsSusp),
2284 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2285 get_target_module(Mod),
2286 Continuation = Mod : ContinuationGoal
2287 ;
2288 Continuation = true
2289 ),
2290 Init = (Susp = Suspension),
2291 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2292 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2293 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2294 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2295 Susp = Suspension, Init = true, CreateContinuation = true
2296 ;
2297 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2298 ),
2299 ( uses_history(Constraint) ->
2300 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2301 ;
2302 CreateHistory = true
2303 ),
2304 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2305 ( has_suspension_field(Constraint,id) ->
2306 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2307 GenID = 'chr gen_id'(Id)
2308 ;
2309 GenID = true
2310 ),
2311 Body =
2312 (
2313 Init,
2314 CreateContinuation,
2315 CreateGeneration,
2316 CreateHistory,
2317 CreateState,
2318 GenID
2319 ).
2321 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2322 % insert_constraint_internal
2324 generate_insert_constraint_internal_clauses([],List,List).
2325 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2326 generate_insert_constraint_internal_clause(C,List,List1),
2327 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2329 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2330 ( chr_pp_flag(inline_insertremove,off) ->
2331 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2332 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2333 ;
2334 delay_phase_end(validate_store_type_assumptions,
2335 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2336 )
2337 ).
2340 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2341 insert_constraint_internal_constraint_name(Constraint,Name),
2342 ( chr_pp_flag(debugable,on) ->
2343 Goal =.. [Name, Vars, Self, Closure | Args]
2344 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2345 Goal =.. [Name,Self | Args]
2346 ;
2347 Goal =.. [Name,Vars, Self | Args]
2348 ).
2350 insert_constraint_internal_constraint_name(Constraint,Name) :-
2351 make_name('$insert_constraint_internal_',Constraint,Name).
2353 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2354 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2355 List = [Clause|Tail],
2356 Clause = (Head :- Body),
2357 Constraint = _/A,
2358 length(Args,A),
2359 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2360 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2361 ;
2362 List = Tail
2363 ).
2366 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2367 static_suspension_term(Constraint,Suspension),
2368 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2369 ( chr_pp_flag(debugable,on) ->
2370 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2371 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2372 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2373 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2374 ;
2375 CreateGeneration = true
2376 ),
2377 ( chr_pp_flag(debugable,on) ->
2378 Constraint = Functor / _,
2379 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2380 ;
2381 true
2382 ),
2383 ( uses_history(Constraint) ->
2384 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2385 ;
2386 CreateHistory = true
2387 ),
2388 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2389 List = [Clause|Tail],
2390 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2391 suspension_term_base_fields(Constraint,BaseFields),
2392 ( has_suspension_field(Constraint,id) ->
2393 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2394 GenID = 'chr gen_id'(Id)
2395 ;
2396 GenID = true
2397 ),
2398 Body =
2399 (
2400 Susp = Suspension,
2401 CreateState,
2402 CreateGeneration,
2403 CreateHistory,
2404 GenID
2405 )
2406 ;
2407 ( has_suspension_field(Constraint,id) ->
2408 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2409 GenID = 'chr gen_id'(Id)
2410 ;
2411 GenID = true
2412 ),
2413 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2414 ( chr_pp_flag(guard_locks,off) ->
2415 NoneLocked = true
2416 ;
2417 NoneLocked = 'chr none_locked'( Vars)
2418 ),
2419 Body =
2420 (
2421 Susp = Suspension,
2422 IndexedVariablesBody,
2423 NoneLocked,
2424 CreateState,
2425 CreateGeneration,
2426 CreateHistory,
2427 GenID
2428 )
2429 ).
2431 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2432 % novel_production/2
2434 generate_novel_production(List,Tail) :-
2435 ( is_used_auxiliary_predicate(novel_production) ->
2436 List = [Clause|Tail],
2437 Clause =
2438 (
2439 '$novel_production'( Self, Tuple) :-
2440 % arg( 3, Self, Ref), % ARGXXX
2441 % 'chr get_mutable'( History, Ref),
2442 arg( 3, Self, History), % ARGXXX
2443 ( hprolog:get_ds( Tuple, History, _) ->
2444 fail
2445 ;
2446 true
2447 )
2448 )
2449 ;
2450 List = Tail
2451 ).
2453 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2454 % extend_history/2
2456 generate_extend_history(List,Tail) :-
2457 ( is_used_auxiliary_predicate(extend_history) ->
2458 List = [Clause|Tail],
2459 Clause =
2460 (
2461 '$extend_history'( Self, Tuple) :-
2462 % arg( 3, Self, Ref), % ARGXXX
2463 % 'chr get_mutable'( History, Ref),
2464 arg( 3, Self, History), % ARGXXX
2465 hprolog:put_ds( Tuple, History, x, NewHistory),
2466 setarg( 3, Self, NewHistory) % ARGXXX
2467 )
2468 ;
2469 List = Tail
2470 ).
2472 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2473 %
2474 :- chr_constraint
2475 empty_named_history_initialisations/2,
2476 generate_empty_named_history_initialisation/1,
2477 find_empty_named_histories/0.
2479 generate_empty_named_history_initialisations(List, Tail) :-
2480 empty_named_history_initialisations(List, Tail),
2481 find_empty_named_histories.
2483 find_empty_named_histories, history(_, Name, []) ==>
2484 generate_empty_named_history_initialisation(Name).
2486 generate_empty_named_history_initialisation(Name) \
2487 generate_empty_named_history_initialisation(Name) <=> true.
2488 generate_empty_named_history_initialisation(Name) \
2489 empty_named_history_initialisations(List, Tail) # Passive
2490 <=>
2491 empty_named_history_global_variable(Name, GlobalVariable),
2492 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2493 empty_named_history_initialisations(Rest, Tail)
2494 pragma passive(Passive).
2496 find_empty_named_histories \
2497 generate_empty_named_history_initialisation(_) # Passive <=> true
2498 pragma passive(Passive).
2500 find_empty_named_histories,
2501 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2502 pragma passive(Passive).
2504 find_empty_named_histories <=>
2505 chr_error(internal, 'find_empty_named_histories was not removed', []).
2508 empty_named_history_global_variable(Name, GlobalVariable) :-
2509 atom_concat('chr empty named history ', Name, GlobalVariable).
2511 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2512 empty_named_history_global_variable(Name, GlobalVariable).
2514 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2515 empty_named_history_global_variable(Name, GlobalVariable).
2518 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2519 % run_suspensions/2
2521 generate_run_suspensions_clauses([],List,List).
2522 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2523 generate_run_suspensions_clause(C,List,List1),
2524 generate_run_suspensions_clauses(Cs,List1,Tail).
2526 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2527 make_name('$run_suspensions_',Constraint,Name),
2528 Goal =.. [Name,Suspensions].
2530 generate_run_suspensions_clause(Constraint,List,Tail) :-
2531 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2532 List = [Clause1,Clause2|Tail],
2533 run_suspensions_goal(Constraint,[],Clause1),
2534 ( chr_pp_flag(debugable,on) ->
2535 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2536 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2537 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2538 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2539 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2540 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2541 Clause2 =
2542 (
2543 Clause2Head :-
2544 GetState,
2545 GetStateValue,
2546 ( State==active ->
2547 UpdateState,
2548 GetGeneration,
2549 GetGenerationValue,
2550 Generation is Gen+1,
2551 UpdateGeneration,
2552 GetContinuation,
2553 (
2554 'chr debug_event'(wake(Suspension)),
2555 call(Continuation)
2556 ;
2557 'chr debug_event'(fail(Suspension)), !,
2558 fail
2559 ),
2560 (
2561 'chr debug_event'(exit(Suspension))
2562 ;
2563 'chr debug_event'(redo(Suspension)),
2564 fail
2565 ),
2566 GetPost,
2567 GetPostValue,
2568 ( Post==triggered ->
2569 UpdatePost % catching constraints that did not do anything
2570 ;
2571 true
2572 )
2573 ;
2574 true
2575 ),
2576 Clause2Recursion
2577 )
2578 ;
2579 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2580 static_suspension_term(Constraint,SuspensionTerm),
2581 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2582 append(Arguments,[Suspension],VarsSusp),
2583 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2584 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2585 ( uses_field(Constraint,generation) ->
2586 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2587 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2588 ;
2589 GenerationHandling = true
2590 ),
2591 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2592 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2593 if_used_state(Constraint,removed,
2594 ( GetState,
2595 ( State==active
2596 -> ReactivateConstraint
2597 ; true)
2598 ),ReactivateConstraint,CondReactivate),
2599 ReactivateConstraint =
2600 (
2601 UpdateState,
2602 GenerationHandling,
2603 Continuation,
2604 GetPostState,
2605 ( Post==triggered ->
2606 UpdatePostState % catching constraints that did not do anything
2607 ;
2608 true
2609 )
2610 ),
2611 Clause2 =
2612 (
2613 Clause2Head :-
2614 Suspension = SuspensionTerm,
2615 CondReactivate,
2616 Clause2Recursion
2617 )
2618 )
2619 ;
2620 List = Tail
2621 ).
2623 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2625 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2626 generate_attach_increment(Clauses) :-
2627 get_max_constraint_index(N),
2628 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2629 Clauses = [Clause1,Clause2],
2630 generate_attach_increment_empty(Clause1),
2631 ( N == 1 ->
2632 generate_attach_increment_one(Clause2)
2633 ;
2634 generate_attach_increment_many(N,Clause2)
2635 )
2636 ;
2637 Clauses = []
2638 ).
2640 generate_attach_increment_empty((attach_increment([],_) :- true)).
2642 generate_attach_increment_one(Clause) :-
2643 Head = attach_increment([Var|Vars],Susps),
2644 get_target_module(Mod),
2645 ( chr_pp_flag(guard_locks,off) ->
2646 NotLocked = true
2647 ;
2648 NotLocked = 'chr not_locked'( Var)
2649 ),
2650 Body =
2651 (
2652 NotLocked,
2653 ( get_attr(Var,Mod,VarSusps) ->
2654 sort(VarSusps,SortedVarSusps),
2655 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2656 put_attr(Var,Mod,MergedSusps)
2657 ;
2658 put_attr(Var,Mod,Susps)
2659 ),
2660 attach_increment(Vars,Susps)
2661 ),
2662 Clause = (Head :- Body).
2664 generate_attach_increment_many(N,Clause) :-
2665 Head = attach_increment([Var|Vars],TAttr1),
2666 % writeln(merge_attributes_1_before),
2667 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2668 % writeln(merge_attributes_1_after),
2669 get_target_module(Mod),
2670 ( chr_pp_flag(guard_locks,off) ->
2671 NotLocked = true
2672 ;
2673 NotLocked = 'chr not_locked'( Var)
2674 ),
2675 Body =
2676 (
2677 NotLocked,
2678 ( get_attr(Var,Mod,TAttr2) ->
2679 MergeGoal,
2680 put_attr(Var,Mod,Attr)
2681 ;
2682 put_attr(Var,Mod,TAttr1)
2683 ),
2684 attach_increment(Vars,TAttr1)
2685 ),
2686 Clause = (Head :- Body).
2688 %% attr_unify_hook
2689 generate_attr_unify_hook(Clauses) :-
2690 get_max_constraint_index(N),
2691 ( N == 0 ->
2692 Clauses = []
2693 ;
2694 ( N == 1 ->
2695 generate_attr_unify_hook_one(Clauses)
2696 ;
2697 generate_attr_unify_hook_many(N,Clauses)
2698 )
2699 ).
2701 generate_attr_unify_hook_one([Clause]) :-
2702 Head = attr_unify_hook(Susps,Other),
2703 get_target_module(Mod),
2704 get_indexed_constraint(1,C),
2705 ( get_store_type(C,ST),
2706 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2707 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2708 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2709 ( atomic_types_suspended_constraint(C) ->
2710 SortGoal1 = true,
2711 SortedSusps = Susps,
2712 SortGoal2 = true,
2713 SortedOtherSusps = OtherSusps,
2714 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2715 NonvarBody = true
2716 ;
2717 SortGoal1 = sort(Susps, SortedSusps),
2718 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2719 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2720 use_auxiliary_predicate(attach_increment),
2721 NonvarBody =
2722 ( compound(Other) ->
2723 term_variables(Other,OtherVars),
2724 attach_increment(OtherVars, SortedSusps)
2725 ;
2726 true
2727 )
2728 ),
2729 Body =
2730 (
2731 SortGoal1,
2732 ( var(Other) ->
2733 ( get_attr(Other,Mod,OtherSusps) ->
2734 SortGoal2,
2735 MergeGoal,
2736 put_attr(Other,Mod,NewSusps),
2737 WakeNewSusps
2738 ;
2739 put_attr(Other,Mod,SortedSusps),
2740 WakeSusps
2741 )
2742 ;
2743 NonvarBody,
2744 WakeSusps
2745 )
2746 ),
2747 Clause = (Head :- Body)
2748 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2749 make_run_suspensions(List,List,WakeNewSusps),
2750 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2751 Body =
2752 ( get_attr(Other,Mod,OtherSusps) ->
2753 MergeGoal,
2754 WakeNewSusps
2755 ;
2756 put_attr(Other,Mod,Susps)
2757 ),
2758 Clause = (Head :- Body)
2759 ).
2762 generate_attr_unify_hook_many(N,[Clause]) :-
2763 chr_pp_flag(dynattr,off), !,
2764 Head = attr_unify_hook(Attr,Other),
2765 get_target_module(Mod),
2766 make_attr(N,Mask,SuspsList,Attr),
2767 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2768 list2conj(SortGoalList,SortGoals),
2769 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2770 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2771 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2772 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2773 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2774 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2775 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2776 NonvarBody = true
2777 ;
2778 use_auxiliary_predicate(attach_increment),
2779 NonvarBody =
2780 ( compound(Other) ->
2781 term_variables(Other,OtherVars),
2782 attach_increment(OtherVars,SortedAttr)
2783 ;
2784 true
2785 )
2786 ),
2787 Body =
2788 (
2789 SortGoals,
2790 ( var(Other) ->
2791 ( get_attr(Other,Mod,TOtherAttr) ->
2792 MergeGoal,
2793 put_attr(Other,Mod,MergedAttr),
2794 WakeMergedSusps
2795 ;
2796 put_attr(Other,Mod,SortedAttr),
2797 WakeSortedSusps
2798 )
2799 ;
2800 NonvarBody,
2801 WakeSortedSusps
2802 )
2803 ),
2804 Clause = (Head :- Body).
2806 % NEW
2807 generate_attr_unify_hook_many(N,Clauses) :-
2808 Head = attr_unify_hook(Attr,Other),
2809 get_target_module(Mod),
2810 normalize_attr(Attr,NormalGoal,NormalAttr),
2811 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2812 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2813 make_run_suspensions(N),
2814 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2815 NonvarBody = true
2816 ;
2817 use_auxiliary_predicate(attach_increment),
2818 NonvarBody =
2819 ( compound(Other) ->
2820 term_variables(Other,OtherVars),
2821 attach_increment(OtherVars,NormalAttr)
2822 ;
2823 true
2824 )
2825 ),
2826 Body =
2827 (
2828 NormalGoal,
2829 ( var(Other) ->
2830 ( get_attr(Other,Mod,OtherAttr) ->
2831 NormalOtherGoal,
2832 MergeGoal,
2833 put_attr(Other,Mod,MergedAttr),
2834 '$dispatch_run_suspensions'(MergedAttr)
2835 ;
2836 put_attr(Other,Mod,NormalAttr),
2837 '$dispatch_run_suspensions'(NormalAttr)
2838 )
2839 ;
2840 NonvarBody,
2841 '$dispatch_run_suspensions'(NormalAttr)
2842 )
2843 ),
2844 Clause = (Head :- Body),
2845 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2846 DispatchList1 = ('$dispatch_run_suspensions'([])),
2847 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2848 run_suspensions_dispatchers(N,[],Dispatchers).
2850 % NEW
2851 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2852 ( N > 0 ->
2853 get_indexed_constraint(N,C),
2854 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2855 ( may_trigger(C) ->
2856 run_suspensions_goal(C,List,Body)
2857 ;
2858 Body = true
2859 ),
2860 M is N - 1,
2861 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2862 ;
2863 Dispatchers = Acc
2864 ).
2866 % NEW
2867 make_run_suspensions(N) :-
2868 ( N > 0 ->
2869 ( get_indexed_constraint(N,C),
2870 may_trigger(C) ->
2871 use_auxiliary_predicate(run_suspensions,C)
2872 ;
2873 true
2874 ),
2875 M is N - 1,
2876 make_run_suspensions(M)
2877 ;
2878 true
2879 ).
2881 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2882 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2884 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2885 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2886 use_auxiliary_predicate(run_suspensions,C),
2887 ( wakes_partially(C) ->
2888 run_suspensions_goal(C,OneSusps,Goal)
2889 ;
2890 run_suspensions_goal(C,AllSusps,Goal)
2891 )
2892 ;
2893 Goal = true
2894 ).
2896 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2897 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2899 make_run_suspensions_loop([],[],_,true).
2900 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2901 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2902 J is I + 1,
2903 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2905 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2906 % $insert_in_store_F/A
2907 % $delete_from_store_F/A
2909 generate_insert_delete_constraints([],[]).
2910 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2911 ( is_stored(FA) ->
2912 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2913 ;
2914 Clauses = RestClauses
2915 ),
2916 generate_insert_delete_constraints(Rest,RestClauses).
2918 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2919 insert_constraint_clause(FA,Clauses,RestClauses1),
2920 delete_constraint_clause(FA,RestClauses1,RestClauses).
2922 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2923 % insert_in_store
2925 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2926 ( chr_pp_flag(inline_insertremove,off) ->
2927 use_auxiliary_predicate(insert_in_store,FA),
2928 insert_constraint_atom(FA,Susp,Goal)
2929 ;
2930 delay_phase_end(validate_store_type_assumptions,
2931 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2932 insert_constraint_direct_used_vars(UsedVars,Vars)
2933 )
2934 )
2935 ).
2937 insert_constraint_direct_used_vars([],_).
2938 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2939 nth1(Index,Vars,Var),
2940 insert_constraint_direct_used_vars(Rest,Vars).
2942 insert_constraint_atom(FA,Susp,Call) :-
2943 make_name('$insert_in_store_',FA,Functor),
2944 Call =.. [Functor,Susp].
2946 insert_constraint_clause(C,Clauses,RestClauses) :-
2947 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2948 Clauses = [Clause|RestClauses],
2949 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2950 insert_constraint_atom(C,Susp,Head),
2951 insert_constraint_body(C,Susp,UsedVars,Body),
2952 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2953 ( chr_pp_flag(store_counter,on) ->
2954 InsertCounterInc = '$insert_counter_inc'
2955 ;
2956 InsertCounterInc = true
2957 )
2958 ;
2959 Clauses = RestClauses
2960 ).
2962 insert_constraint_used_vars([],_,_,true).
2963 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2964 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2965 insert_constraint_used_vars(Rest,C,Susp,Goals).
2967 insert_constraint_body(C,Susp,UsedVars,Body) :-
2968 get_store_type(C,StoreType),
2969 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2971 insert_constraint_body(default,C,Susp,[],Body) :-
2972 global_list_store_name(C,StoreName),
2973 make_get_store_goal(StoreName,Store,GetStoreGoal),
2974 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2975 ( chr_pp_flag(debugable,on) ->
2976 Cell = [Susp|Store],
2977 Body =
2978 (
2979 GetStoreGoal,
2980 UpdateStoreGoal
2981 )
2982 ;
2983 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2984 Body =
2985 (
2986 GetStoreGoal,
2987 Cell = [Susp|Store],
2988 UpdateStoreGoal,
2989 ( Store = [NextSusp|_] ->
2990 SetGoal
2991 ;
2992 true
2993 )
2994 )
2995 ).
2996 % get_target_module(Mod),
2997 % get_max_constraint_index(Total),
2998 % ( Total == 1 ->
2999 % generate_attach_body_1(C,Store,Susp,AttachBody)
3000 % ;
3001 % generate_attach_body_n(C,Store,Susp,AttachBody)
3002 % ),
3003 % Body =
3004 % (
3005 % 'chr default_store'(Store),
3006 % AttachBody
3007 % ).
3008 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3009 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3010 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3011 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3012 sort_out_used_vars(MixedUsedVars,UsedVars).
3013 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3014 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3015 constants_store_index_name(C,Index,IndexName),
3016 IndexLookup =.. [IndexName,Key,StoreName],
3017 Body =
3018 ( IndexLookup ->
3019 nb_getval(StoreName,Store),
3020 b_setval(StoreName,[Susp|Store])
3021 ;
3022 true
3023 ).
3024 insert_constraint_body(ground_constants(Index,_),C,Susp,UsedVars,Body) :-
3025 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3026 constants_store_index_name(C,Index,IndexName),
3027 IndexLookup =.. [IndexName,Key,StoreName],
3028 Body =
3029 ( IndexLookup ->
3030 nb_getval(StoreName,Store),
3031 b_setval(StoreName,[Susp|Store])
3032 ;
3033 true
3034 ).
3035 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3036 global_ground_store_name(C,StoreName),
3037 make_get_store_goal(StoreName,Store,GetStoreGoal),
3038 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3039 ( chr_pp_flag(debugable,on) ->
3040 Cell = [Susp|Store],
3041 Body =
3042 (
3043 GetStoreGoal,
3044 UpdateStoreGoal
3045 )
3046 ;
3047 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3048 Body =
3049 (
3050 GetStoreGoal,
3051 Cell = [Susp|Store],
3052 UpdateStoreGoal,
3053 ( Store = [NextSusp|_] ->
3054 SetGoal
3055 ;
3056 true
3057 )
3058 )
3059 ).
3060 % global_ground_store_name(C,StoreName),
3061 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3062 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3063 % Body =
3064 % (
3065 % GetStoreGoal, % nb_getval(StoreName,Store),
3066 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3067 % ).
3068 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3069 % TODO: generalize to more than one !!!
3070 get_target_module(Module),
3071 Body = ( get_attr(Variable,Module,AssocStore) ->
3072 insert_assoc_store(AssocStore,Key,Susp)
3073 ;
3074 new_assoc_store(AssocStore),
3075 put_attr(Variable,Module,AssocStore),
3076 insert_assoc_store(AssocStore,Key,Susp)
3077 ).
3079 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3080 global_singleton_store_name(C,StoreName),
3081 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3082 Body =
3083 (
3084 UpdateStoreGoal
3085 ).
3086 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3087 find_with_var_identity(
3088 B-UV,
3089 [Susp],
3090 (
3091 member(ST,StoreTypes),
3092 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
3093 ),
3094 BodiesUsedVars
3095 ),
3096 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
3097 list2conj(Bodies,Body),
3098 sort_out_used_vars(NestedUsedVars,UsedVars).
3099 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3100 UsedVars = [Index-Var],
3101 get_identifier_size(ISize),
3102 functor(Struct,struct,ISize),
3103 get_identifier_index(C,Index,IIndex),
3104 arg(IIndex,Struct,Susps),
3105 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3106 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3107 UsedVars = [Index-Var],
3108 type_indexed_identifier_structure(IndexType,Struct),
3109 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3110 arg(IIndex,Struct,Susps),
3111 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3113 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3114 flatten(NestedUsedVars,FlatUsedVars),
3115 sort(FlatUsedVars,SortedFlatUsedVars),
3116 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3118 sort_out_used_vars1([],[]).
3119 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3120 sort_out_used_vars1([I-X,J-Y|R],L) :-
3121 ( I == J ->
3122 X = Y,
3123 sort_out_used_vars1([I-X|R],L)
3124 ;
3125 L = [I-X|T],
3126 sort_out_used_vars1([J-Y|R],T)
3127 ).
3129 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3130 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3131 multi_hash_store_name(FA,Index,StoreName),
3132 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3133 Body =
3134 (
3135 KeyBody,
3136 nb_getval(StoreName,Store),
3137 insert_iht(Store,Key,Susp)
3138 ),
3139 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3141 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3142 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3143 multi_hash_store_name(FA,Index,StoreName),
3144 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3145 make_get_store_goal(StoreName,Store,GetStoreGoal),
3146 ( chr_pp_flag(ht_removal,on)
3147 -> ht_prev_field(Index,PrevField),
3148 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3149 SetGoal),
3150 Body =
3151 (
3152 GetStoreGoal,
3153 insert_ht(Store,Key,Susp,Result),
3154 ( Result = [_,NextSusp|_]
3155 -> SetGoal
3156 ; true
3157 )
3158 )
3159 ; Body =
3160 (
3161 GetStoreGoal,
3162 insert_ht(Store,Key,Susp)
3163 )
3164 ),
3165 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3167 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3168 % Delete
3170 delete_constraint_clause(C,Clauses,RestClauses) :-
3171 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3172 Clauses = [Clause|RestClauses],
3173 Clause = (Head :- Body),
3174 delete_constraint_atom(C,Susp,Head),
3175 C = F/A,
3176 functor(Head,F,A),
3177 delete_constraint_body(C,Head,Susp,[],Body)
3178 ;
3179 Clauses = RestClauses
3180 ).
3182 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3183 functor(Head,F,A),
3184 C = F/A,
3185 ( chr_pp_flag(inline_insertremove,off) ->
3186 use_auxiliary_predicate(delete_from_store,C),
3187 delete_constraint_atom(C,Susp,Goal)
3188 ;
3189 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3190 ).
3192 delete_constraint_atom(C,Susp,Atom) :-
3193 make_name('$delete_from_store_',C,Functor),
3194 Atom =.. [Functor,Susp].
3197 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3198 Body = (CounterBody,DeleteBody),
3199 ( chr_pp_flag(store_counter,on) ->
3200 CounterBody = '$delete_counter_inc'
3201 ;
3202 CounterBody = true
3203 ),
3204 get_store_type(C,StoreType),
3205 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3207 delete_constraint_body(default,C,_,Susp,_,Body) :-
3208 ( chr_pp_flag(debugable,on) ->
3209 global_list_store_name(C,StoreName),
3210 make_get_store_goal(StoreName,Store,GetStoreGoal),
3211 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3212 Body =
3213 (
3214 GetStoreGoal, % nb_getval(StoreName,Store),
3215 'chr sbag_del_element'(Store,Susp,NStore),
3216 UpdateStoreGoal % b_setval(StoreName,NStore)
3217 )
3218 ;
3219 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3220 global_list_store_name(C,StoreName),
3221 make_get_store_goal(StoreName,Store,GetStoreGoal),
3222 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3223 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3224 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3225 Body =
3226 (
3227 GetGoal,
3228 ( var(PredCell) ->
3229 GetStoreGoal, % nb_getval(StoreName,Store),
3230 Store = [_|Tail],
3231 UpdateStoreGoal,
3232 ( Tail = [NextSusp|_] ->
3233 SetGoal1
3234 ;
3235 true
3236 )
3237 ;
3238 PredCell = [_,_|Tail],
3239 setarg(2,PredCell,Tail),
3240 ( Tail = [NextSusp|_] ->
3241 SetGoal2
3242 ;
3243 true
3244 )
3245 )
3246 )
3247 ).
3248 % get_target_module(Mod),
3249 % get_max_constraint_index(Total),
3250 % ( Total == 1 ->
3251 % generate_detach_body_1(C,Store,Susp,DetachBody),
3252 % Body =
3253 % (
3254 % 'chr default_store'(Store),
3255 % DetachBody
3256 % )
3257 % ;
3258 % generate_detach_body_n(C,Store,Susp,DetachBody),
3259 % Body =
3260 % (
3261 % 'chr default_store'(Store),
3262 % DetachBody
3263 % )
3264 % ).
3265 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3266 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3267 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3268 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3269 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3270 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3271 constants_store_index_name(C,Index,IndexName),
3272 IndexLookup =.. [IndexName,Key,StoreName],
3273 Body =
3274 ( KeyBody,
3275 ( IndexLookup ->
3276 nb_getval(StoreName,Store),
3277 'chr sbag_del_element'(Store,Susp,NStore),
3278 b_setval(StoreName,NStore)
3279 ;
3280 true
3281 )).
3282 delete_constraint_body(ground_constants(Index,_),C,Head,Susp,VarDict,Body) :-
3283 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3284 constants_store_index_name(C,Index,IndexName),
3285 IndexLookup =.. [IndexName,Key,StoreName],
3286 Body =
3287 ( KeyBody,
3288 ( IndexLookup ->
3289 nb_getval(StoreName,Store),
3290 'chr sbag_del_element'(Store,Susp,NStore),
3291 b_setval(StoreName,NStore)
3292 ;
3293 true
3294 )).
3295 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3296 ( chr_pp_flag(debugable,on) ->
3297 global_ground_store_name(C,StoreName),
3298 make_get_store_goal(StoreName,Store,GetStoreGoal),
3299 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3300 Body =
3301 (
3302 GetStoreGoal, % nb_getval(StoreName,Store),
3303 'chr sbag_del_element'(Store,Susp,NStore),
3304 UpdateStoreGoal % b_setval(StoreName,NStore)
3305 )
3306 ;
3307 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3308 global_ground_store_name(C,StoreName),
3309 make_get_store_goal(StoreName,Store,GetStoreGoal),
3310 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3311 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3312 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3313 Body =
3314 (
3315 GetGoal,
3316 ( var(PredCell) ->
3317 GetStoreGoal, % nb_getval(StoreName,Store),
3318 Store = [_|Tail],
3319 UpdateStoreGoal,
3320 ( Tail = [NextSusp|_] ->
3321 SetGoal1
3322 ;
3323 true
3324 )
3325 ;
3326 PredCell = [_,_|Tail],
3327 setarg(2,PredCell,Tail),
3328 ( Tail = [NextSusp|_] ->
3329 SetGoal2
3330 ;
3331 true
3332 )
3333 )
3334 )
3335 ).
3336 % global_ground_store_name(C,StoreName),
3337 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3338 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3339 % Body =
3340 % (
3341 % GetStoreGoal, % nb_getval(StoreName,Store),
3342 % 'chr sbag_del_element'(Store,Susp,NStore),
3343 % UpdateStoreGoal % b_setval(StoreName,NStore)
3344 % ).
3345 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3346 get_target_module(Module),
3347 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3348 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3349 Body = (
3350 VariableGoal,
3351 get_attr(Variable,Module,AssocStore),
3352 KeyGoal,
3353 delete_assoc_store(AssocStore,Key,Susp)
3354 ).
3355 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3356 global_singleton_store_name(C,StoreName),
3357 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3358 Body =
3359 (
3360 UpdateStoreGoal % b_setval(StoreName,[])
3361 ).
3362 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3363 find_with_var_identity(
3364 B,
3365 [Susp/VarDict/Head],
3366 (
3367 member(ST,StoreTypes),
3368 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3369 ),
3370 Bodies
3371 ),
3372 list2conj(Bodies,Body).
3373 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3374 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3375 get_identifier_size(ISize),
3376 functor(Struct,struct,ISize),
3377 get_identifier_index(C,Index,IIndex),
3378 arg(IIndex,Struct,Susps),
3379 Body = (
3380 VariableGoal,
3381 Variable = Struct,
3382 'chr sbag_del_element'(Susps,Susp,NSusps),
3383 setarg(IIndex,Variable,NSusps)
3384 ).
3385 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3386 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3387 type_indexed_identifier_structure(IndexType,Struct),
3388 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3389 arg(IIndex,Struct,Susps),
3390 Body = (
3391 VariableGoal,
3392 Variable = Struct,
3393 'chr sbag_del_element'(Susps,Susp,NSusps),
3394 setarg(IIndex,Variable,NSusps)
3395 ).
3397 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3398 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3399 multi_hash_store_name(FA,Index,StoreName),
3400 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3401 Body =
3402 (
3403 KeyBody,
3404 nb_getval(StoreName,Store),
3405 delete_iht(Store,Key,Susp)
3406 ),
3407 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3408 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3409 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3410 multi_hash_store_name(C,Index,StoreName),
3411 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3412 make_get_store_goal(StoreName,Store,GetStoreGoal),
3413 ( chr_pp_flag(ht_removal,on)
3414 -> ht_prev_field(Index,PrevField),
3415 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3416 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3417 SetGoal1),
3418 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3419 SetGoal2),
3420 Body =
3421 (
3422 GetGoal,
3423 ( var(Prev)
3424 -> GetStoreGoal,
3425 KeyBody,
3426 delete_first_ht(Store,Key,Values),
3427 ( Values = [NextSusp|_]
3428 -> SetGoal1
3429 ; true
3430 )
3431 ; Prev = [_,_|Values],
3432 setarg(2,Prev,Values),
3433 ( Values = [NextSusp|_]
3434 -> SetGoal2
3435 ; true
3436 )
3437 )
3438 )
3439 ; Body =
3440 (
3441 KeyBody,
3442 GetStoreGoal, % nb_getval(StoreName,Store),
3443 delete_ht(Store,Key,Susp)
3444 )
3445 ),
3446 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3448 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3450 :- chr_constraint
3451 module_initializer/1,
3452 module_initializers/1.
3454 module_initializers(G), module_initializer(Initializer) <=>
3455 G = (Initializer,Initializers),
3456 module_initializers(Initializers).
3458 module_initializers(G) <=>
3459 G = true.
3461 generate_attach_code(Constraints,[Enumerate|L]) :-
3462 enumerate_stores_code(Constraints,Enumerate),
3463 generate_attach_code(Constraints,L,T),
3464 module_initializers(Initializers),
3465 prolog_global_variables_code(PrologGlobalVariables),
3466 % Do not rename or the 'chr_initialization' predicate
3467 % without warning SSS
3468 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3470 generate_attach_code([],L,L).
3471 generate_attach_code([C|Cs],L,T) :-
3472 get_store_type(C,StoreType),
3473 generate_attach_code(StoreType,C,L,L1),
3474 generate_attach_code(Cs,L1,T).
3476 generate_attach_code(default,C,L,T) :-
3477 global_list_store_initialisation(C,L,T).
3478 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3479 multi_inthash_store_initialisations(Indexes,C,L,L1),
3480 multi_inthash_via_lookups(Indexes,C,L1,T).
3481 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3482 multi_hash_store_initialisations(Indexes,C,L,L1),
3483 multi_hash_lookups(Indexes,C,L1,T).
3484 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3485 constants_initializers(C,Index,Constants),
3486 atomic_constants_code(C,Index,Constants,L,T).
3487 generate_attach_code(ground_constants(Index,Constants),C,L,T) :-
3488 constants_initializers(C,Index,Constants),
3489 ground_constants_code(C,Index,Constants,L,T).
3490 generate_attach_code(global_ground,C,L,T) :-
3491 global_ground_store_initialisation(C,L,T).
3492 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3493 use_auxiliary_module(chr_assoc_store).
3494 generate_attach_code(global_singleton,C,L,T) :-
3495 global_singleton_store_initialisation(C,L,T).
3496 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3497 multi_store_generate_attach_code(StoreTypes,C,L,T).
3498 generate_attach_code(identifier_store(Index),C,L,T) :-
3499 get_identifier_index(C,Index,IIndex),
3500 ( IIndex == 2 ->
3501 get_identifier_size(ISize),
3502 functor(Struct,struct,ISize),
3503 Struct =.. [_,Label|Stores],
3504 set_elems(Stores,[]),
3505 Clause1 = new_identifier(Label,Struct),
3506 functor(Struct2,struct,ISize),
3507 arg(1,Struct2,Label2),
3508 Clause2 =
3509 ( user:portray(Struct2) :-
3510 write('<id:'),
3511 print(Label2),
3512 write('>')
3513 ),
3514 functor(Struct3,struct,ISize),
3515 arg(1,Struct3,Label3),
3516 Clause3 = identifier_label(Struct3,Label3),
3517 L = [Clause1,Clause2,Clause3|T]
3518 ;
3519 L = T
3520 ).
3521 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3522 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3523 ( IIndex == 2 ->
3524 identifier_store_initialization(IndexType,L,L1),
3525 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3526 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3527 get_type_indexed_identifier_size(IndexType,ISize),
3528 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3529 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3530 type_indexed_identifier_structure(IndexType,Struct),
3531 Struct =.. [_,Label|Stores],
3532 set_elems(Stores,[]),
3533 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3534 Clause1 =.. [Name1,Label,Struct],
3535 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3536 Goal1 =.. [Name1,Label1b,S1b],
3537 type_indexed_identifier_structure(IndexType,Struct1b),
3538 Struct1b =.. [_,Label1b|Stores1b],
3539 set_elems(Stores1b,[]),
3540 Expansion1 = (S1b = Struct1b),
3541 Clause1b = user:goal_expansion(Goal1,Expansion1),
3542 % writeln(Clause1-Clause1b),
3543 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3544 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3545 type_indexed_identifier_structure(IndexType,Struct2),
3546 arg(1,Struct2,Label2),
3547 Clause2 =
3548 ( user:portray(Struct2) :-
3549 write('<id:'),
3550 print(Label2),
3551 write('>')
3552 ),
3553 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3554 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3555 type_indexed_identifier_structure(IndexType,Struct3),
3556 arg(1,Struct3,Label3),
3557 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3558 Clause3 =.. [Name3,Struct3,Label3],
3559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3560 Goal3b =.. [Name3,S3b,L3b],
3561 type_indexed_identifier_structure(IndexType,Struct3b),
3562 arg(1,Struct3b,L3b),
3563 Expansion3b = (S3 = Struct3b),
3564 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3565 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3566 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3567 identifier_store_name(IndexType,GlobalVariable),
3568 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3569 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3570 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3571 Clause4 =
3572 ( LookupAtom :-
3573 nb_getval(GlobalVariable,HT),
3574 ( lookup_ht(HT,X,[IX]) ->
3575 true
3576 ;
3577 NewIdentifierGoal,
3578 insert_ht(HT,X,IX)
3579 )
3580 ),
3581 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3582 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3583 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3584 ;
3585 L = T
3586 ).
3588 constants_initializers(C,Index,Constants) :-
3589 maplist(constants_store_name(C,Index),Constants,StoreNames),
3590 findall(Initializer,
3591 ( member(StoreName,StoreNames),
3592 Initializer = nb_setval(StoreName,[])
3593 ),
3594 Initializers),
3595 maplist(module_initializer,Initializers).
3597 lookup_identifier_atom(Key,X,IX,Atom) :-
3598 atom_concat('lookup_identifier_',Key,LookupFunctor),
3599 Atom =.. [LookupFunctor,X,IX].
3601 identifier_label_atom(IndexType,IX,X,Atom) :-
3602 type_indexed_identifier_name(IndexType,identifier_label,Name),
3603 Atom =.. [Name,IX,X].
3605 multi_store_generate_attach_code([],_,L,L).
3606 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3607 generate_attach_code(ST,C,L,L1),
3608 multi_store_generate_attach_code(STs,C,L1,T).
3610 multi_inthash_store_initialisations([],_,L,L).
3611 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3612 use_auxiliary_module(chr_integertable_store),
3613 multi_hash_store_name(FA,Index,StoreName),
3614 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3615 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3616 L1 = L,
3617 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3618 multi_hash_store_initialisations([],_,L,L).
3619 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3620 use_auxiliary_module(chr_hashtable_store),
3621 multi_hash_store_name(FA,Index,StoreName),
3622 prolog_global_variable(StoreName),
3623 make_init_store_goal(StoreName,HT,InitStoreGoal),
3624 module_initializer((new_ht(HT),InitStoreGoal)),
3625 L1 = L,
3626 multi_hash_store_initialisations(Indexes,FA,L1,T).
3628 global_list_store_initialisation(C,L,T) :-
3629 ( is_stored(C) ->
3630 global_list_store_name(C,StoreName),
3631 prolog_global_variable(StoreName),
3632 make_init_store_goal(StoreName,[],InitStoreGoal),
3633 module_initializer(InitStoreGoal)
3634 ;
3635 true
3636 ),
3637 L = T.
3638 global_ground_store_initialisation(C,L,T) :-
3639 global_ground_store_name(C,StoreName),
3640 prolog_global_variable(StoreName),
3641 make_init_store_goal(StoreName,[],InitStoreGoal),
3642 module_initializer(InitStoreGoal),
3643 L = T.
3644 global_singleton_store_initialisation(C,L,T) :-
3645 global_singleton_store_name(C,StoreName),
3646 prolog_global_variable(StoreName),
3647 make_init_store_goal(StoreName,[],InitStoreGoal),
3648 module_initializer(InitStoreGoal),
3649 L = T.
3650 identifier_store_initialization(IndexType,L,T) :-
3651 use_auxiliary_module(chr_hashtable_store),
3652 identifier_store_name(IndexType,StoreName),
3653 prolog_global_variable(StoreName),
3654 make_init_store_goal(StoreName,HT,InitStoreGoal),
3655 module_initializer((new_ht(HT),InitStoreGoal)),
3656 L = T.
3659 multi_inthash_via_lookups([],_,L,L).
3660 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3661 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3662 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3663 L = [(Head :- Body)|L1],
3664 multi_inthash_via_lookups(Indexes,C,L1,T).
3665 multi_hash_lookups([],_,L,L).
3666 multi_hash_lookups([Index|Indexes],C,L,T) :-
3667 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3668 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3669 L = [(Head :- Body)|L1],
3670 multi_hash_lookups(Indexes,C,L1,T).
3672 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3673 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3674 Head =.. [Name,Key,SuspsList].
3676 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3677 %
3678 % Returns goal that performs hash table lookup.
3679 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3680 % INLINED:
3681 ( get_store_type(ConstraintSymbol,multi_store(Stores)),
3682 memberchk(atomic_constants(Index,Constants,_),Stores) ->
3683 ( ground(Key) ->
3684 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3685 Goal = nb_getval(StoreName,SuspsList)
3686 ;
3687 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3688 Lookup =.. [IndexName,Key,StoreName],
3689 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3690 )
3691 ; get_store_type(ConstraintSymbol,multi_store(Stores)),
3692 memberchk(ground_constants(Index,Constants),Stores) ->
3693 ( ground(Key) ->
3694 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3695 Goal = nb_getval(StoreName,SuspsList)
3696 ;
3697 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3698 Lookup =.. [IndexName,Key,StoreName],
3699 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3700 )
3701 ;
3702 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3703 make_get_store_goal(StoreName,HT,GetStoreGoal),
3704 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3705 Goal =
3706 (
3707 GetStoreGoal, % nb_getval(StoreName,HT),
3708 HashCall, % hash_term(Key,Hash),
3709 lookup_ht1(HT,Hash,Key,SuspsList)
3710 )
3711 ;
3712 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3713 Goal =
3714 (
3715 GetStoreGoal, % nb_getval(StoreName,HT),
3716 hash_term(Key,Hash),
3717 Lookup
3718 )
3719 )
3720 ).
3723 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3724 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3726 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3727 ( ground(Key) ->
3728 % This is based on a property of SWI-Prolog's
3729 % hash_term/2 predicate:
3730 % the hash value is stable over repeated invocations
3731 % of SWI-Prolog
3732 hash_term(Key,Hash),
3733 Call = true
3734 ; Index = [IndexPos],
3735 get_constraint_type(Constraint,ArgTypes),
3736 nth1(IndexPos,ArgTypes,Type),
3737 unalias_type(Type,NormalType),
3738 memberchk_eq(NormalType,[int,natural]) ->
3739 ( NormalType == int ->
3740 Hash = abs(Key),
3741 Call = true
3742 ;
3743 Hash = Key,
3744 Call = true
3745 )
3746 ;
3747 nonvar(Key),
3748 specialize_hash_term(Key,NewKey),
3749 NewKey \== Key,
3750 Call = hash_term(NewKey,Hash)
3751 ).
3753 specialize_hash_term(Term,NewTerm) :-
3754 ( ground(Term) ->
3755 hash_term(Term,NewTerm)
3756 ; var(Term) ->
3757 NewTerm = Term
3758 ;
3759 Term =.. [F|Args],
3760 maplist(specialize_hash_term,Args,NewArgs),
3761 NewTerm =.. [F|NewArgs]
3762 ).
3764 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3765 ( /* chr_pp_flag(experiment,off) ->
3766 true
3767 ; */ atomic(Key) ->
3768 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3769 ; ground(Key) ->
3770 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3771 ;
3772 actual_non_atomic_multi_hash_key(ConstraintSymbol,Index)
3773 ),
3774 delay_phase_end(validate_store_type_assumptions,
3775 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3777 :- chr_constraint actual_atomic_multi_hash_keys/3.
3778 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3780 :- chr_constraint actual_ground_multi_hash_keys/3.
3781 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3783 :- chr_constraint actual_non_atomic_multi_hash_key/2.
3784 :- chr_option(mode,actual_non_atomic_multi_hash_key(+,+)).
3786 /*
3787 actual_atomic_multi_hash_keys(C,Index,Keys)
3788 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3790 actual_ground_multi_hash_keys(C,Index,Keys)
3791 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3793 actual_non_atomic_multi_hash_key(C,Index)
3794 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3795 */
3796 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3797 <=> append(Keys1,Keys2,Keys0),
3798 sort(Keys0,Keys),
3799 actual_atomic_multi_hash_keys(C,Index,Keys).
3801 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3802 <=> append(Keys1,Keys2,Keys0),
3803 sort(Keys0,Keys),
3804 actual_ground_multi_hash_keys(C,Index,Keys).
3806 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3807 <=> append(Keys1,Keys2,Keys0),
3808 sort(Keys0,Keys),
3809 actual_ground_multi_hash_keys(C,Index,Keys).
3811 actual_non_atomic_multi_hash_key(C,Index) \ actual_non_atomic_multi_hash_key(C,Index)
3812 <=> true.
3814 actual_non_atomic_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3815 <=> true.
3817 actual_non_atomic_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3818 <=> true.
3820 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3821 %
3822 % Returns predicate name of hash table lookup predicate.
3823 multi_hash_lookup_name(F/A,Index,Name) :-
3824 ( integer(Index) ->
3825 IndexName = Index
3826 ; is_list(Index) ->
3827 atom_concat_list(Index,IndexName)
3828 ),
3829 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3831 multi_hash_store_name(F/A,Index,Name) :-
3832 get_target_module(Mod),
3833 ( integer(Index) ->
3834 IndexName = Index
3835 ; is_list(Index) ->
3836 atom_concat_list(Index,IndexName)
3837 ),
3838 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3840 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3841 ( ( integer(Index) ->
3842 I = Index
3843 ;
3844 Index = [I]
3845 ) ->
3846 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3847 ; is_list(Index) ->
3848 sort(Index,Indexes),
3849 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3850 once(pairup(Bodies,Keys,ArgKeyPairs)),
3851 Key =.. [k|Keys],
3852 list2conj(Bodies,KeyBody)
3853 ).
3855 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3856 ( ( integer(Index) ->
3857 I = Index
3858 ;
3859 Index = [I]
3860 ) ->
3861 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3862 ; is_list(Index) ->
3863 sort(Index,Indexes),
3864 find_with_var_identity(
3865 Goal-KeyI,
3866 [Susp/Head/VarDict],
3867 (
3868 member(I,Indexes),
3869 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3870 ),
3871 ArgKeyPairs
3872 ),
3873 once(pairup(Bodies,Keys,ArgKeyPairs)),
3874 Key =.. [k|Keys],
3875 list2conj(Bodies,KeyBody)
3876 ).
3878 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3879 arg(Index,Head,OriginalArg),
3880 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3881 Goal = true
3882 ;
3883 functor(Head,F,A),
3884 C = F/A,
3885 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3886 ).
3888 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3889 ( ( integer(Index) ->
3890 I = Index
3891 ;
3892 Index = [I]
3893 ) ->
3894 UsedVars = [I-Key]
3895 ; is_list(Index) ->
3896 sort(Index,Indexes),
3897 pairup(Indexes,Keys,UsedVars),
3898 Key =.. [k|Keys]
3899 ).
3901 multi_hash_key_args(Index,Head,KeyArgs) :-
3902 ( integer(Index) ->
3903 arg(Index,Head,Arg),
3904 KeyArgs = [Arg]
3905 ; is_list(Index) ->
3906 sort(Index,Indexes),
3907 term_variables(Head,Vars),
3908 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3909 ).
3912 %-------------------------------------------------------------------------------
3913 atomic_constants_code(C,Index,Constants,L,T) :-
3914 constants_store_index_name(C,Index,IndexName),
3915 findall(Clause,
3916 ( member(Constant,Constants),
3917 constants_store_name(C,Index,Constant,StoreName),
3918 Clause =.. [IndexName,Constant,StoreName]
3919 ),
3920 Clauses),
3921 append(Clauses,T,L).
3923 %-------------------------------------------------------------------------------
3924 ground_constants_code(C,Index,Terms,L,T) :-
3925 constants_store_index_name(C,Index,IndexName),
3926 findall(StoreName,
3927 ( member(Constant,Terms),
3928 constants_store_name(C,Index,Constant,StoreName)
3929 ),
3930 StoreNames),
3931 length(Terms,N),
3932 replicate(N,[],More),
3933 trie_index([Terms|More],StoreNames,IndexName,L,T).
3935 constants_store_name(F/A,Index,Term,Name) :-
3936 get_target_module(Mod),
3937 term_to_atom(Term,Constant),
3938 term_to_atom(Index,IndexAtom),
3939 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3941 constants_store_index_name(F/A,Index,Name) :-
3942 get_target_module(Mod),
3943 term_to_atom(Index,IndexAtom),
3944 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3946 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3947 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3949 trie_step([],_,_,[],[],L,L) :- !.
3950 % length MorePatterns == length Patterns == length Results
3951 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3952 MorePatterns = [List|_],
3953 length(List,N),
3954 findall(F/A,
3955 ( member(Pattern,Patterns),
3956 functor(Pattern,F,A)
3957 ),
3958 FAs0),
3959 sort(FAs0,FAs),
3960 N1 is N + 1,
3961 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3963 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3964 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3965 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3966 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3968 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3969 Clause = (Head :- Body),
3970 N1 is N + 1,
3971 functor(Head,Symbol,N1),
3972 arg(N1,Head,Result),
3973 functor(IndexPattern,F,A),
3974 arg(1,Head,IndexPattern),
3975 Head =.. [_,_|RestArgs],
3976 IndexPattern =.. [_|Args],
3977 append(Args,RestArgs,RecArgs),
3978 ( RecArgs == [Result] ->
3979 List = Tail,
3980 Body = true,
3981 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
3982 MoreResults = [Result]
3983 ;
3984 gensym(Prefix,RSymbol),
3985 Body =.. [RSymbol|RecArgs],
3986 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
3987 trie_step(Cases,RSymbol,Prefix,MoreCases,MoreResults,List,Tail)
3988 ).
3990 rec_cases([],[],[],_,[],[],[]).
3991 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
3992 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
3993 Cases = [Case|NCases],
3994 MoreCases = [MoreCase|NMoreCases],
3995 MoreResults = [Result|NMoreResults],
3996 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
3997 ;
3998 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
3999 ).
4001 %-------------------------------------------------------------------------------
4002 global_list_store_name(F/A,Name) :-
4003 get_target_module(Mod),
4004 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4005 global_ground_store_name(F/A,Name) :-
4006 get_target_module(Mod),
4007 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4008 global_singleton_store_name(F/A,Name) :-
4009 get_target_module(Mod),
4010 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4012 identifier_store_name(TypeName,Name) :-
4013 get_target_module(Mod),
4014 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4016 :- chr_constraint prolog_global_variable/1.
4017 :- chr_option(mode,prolog_global_variable(+)).
4019 :- chr_constraint prolog_global_variables/1.
4020 :- chr_option(mode,prolog_global_variables(-)).
4022 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4024 prolog_global_variables(List), prolog_global_variable(Name) <=>
4025 List = [Name|Tail],
4026 prolog_global_variables(Tail).
4027 prolog_global_variables(List) <=> List = [].
4029 %% SWI begin
4030 prolog_global_variables_code(Code) :-
4031 prolog_global_variables(Names),
4032 ( Names == [] ->
4033 Code = []
4034 ;
4035 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
4036 Code = [(:- dynamic user:exception/3),
4037 (:- multifile user:exception/3),
4038 (user:exception(undefined_global_variable,Name,retry) :-
4039 (
4040 '$chr_prolog_global_variable'(Name),
4041 '$chr_initialization'
4042 )
4043 )
4044 |
4045 NameDeclarations
4046 ]
4047 ).
4048 %% SWI end
4049 %% SICStus begin
4050 % prolog_global_variables_code([]).
4051 %% SICStus end
4052 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4053 %sbag_member_call(S,L,sysh:mem(S,L)).
4054 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4055 %sbag_member_call(S,L,member(S,L)).
4056 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4057 %update_mutable_call(A,B,setarg(1, B, A)).
4058 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4059 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4061 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4062 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4063 % create_get_mutable(Value,Field,Get1).
4064 %
4065 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4066 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4067 % update_mutable_call(NewValue,Field,Set).
4068 %
4069 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4070 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4071 % create_get_mutable_ref(Value,Field,Get1),
4072 % update_mutable_call(NewValue,Field,Set).
4073 %
4074 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4075 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4076 % create_mutable_call(Value,Field,Create).
4077 %
4078 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4079 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4080 % create_get_mutable(Value,Field,Get).
4081 %
4082 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4083 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4084 % create_get_mutable_ref(Value,Field,Get),
4085 % update_mutable_call(NewValue,Field,Set).
4087 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4088 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4090 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4091 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4093 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4094 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4095 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4097 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4098 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4100 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4101 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4103 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4104 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4105 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4107 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4109 enumerate_stores_code(Constraints,Clause) :-
4110 Head = '$enumerate_constraints'(Constraint),
4111 enumerate_store_bodies(Constraints,Constraint,Bodies),
4112 list2disj(Bodies,Body),
4113 Clause = (Head :- Body).
4115 enumerate_store_bodies([],_,[]).
4116 enumerate_store_bodies([C|Cs],Constraint,L) :-
4117 ( is_stored(C) ->
4118 get_store_type(C,StoreType),
4119 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4120 true
4121 ;
4122 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4123 ),
4124 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4125 C = F/_,
4126 Constraint0 =.. [F|Arguments],
4127 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4128 L = [Body|T]
4129 ;
4130 L = T
4131 ),
4132 enumerate_store_bodies(Cs,Constraint,T).
4134 enumerate_store_body(default,C,Susp,Body) :-
4135 global_list_store_name(C,StoreName),
4136 sbag_member_call(Susp,List,Sbag),
4137 make_get_store_goal(StoreName,List,GetStoreGoal),
4138 Body =
4139 (
4140 GetStoreGoal, % nb_getval(StoreName,List),
4141 Sbag
4142 ).
4143 % get_constraint_index(C,Index),
4144 % get_target_module(Mod),
4145 % get_max_constraint_index(MaxIndex),
4146 % Body1 =
4147 % (
4148 % 'chr default_store'(GlobalStore),
4149 % get_attr(GlobalStore,Mod,Attr)
4150 % ),
4151 % ( MaxIndex > 1 ->
4152 % NIndex is Index + 1,
4153 % sbag_member_call(Susp,List,Sbag),
4154 % Body2 =
4155 % (
4156 % arg(NIndex,Attr,List),
4157 % Sbag
4158 % )
4159 % ;
4160 % sbag_member_call(Susp,Attr,Sbag),
4161 % Body2 = Sbag
4162 % ),
4163 % Body = (Body1,Body2).
4164 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4165 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4166 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4167 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4168 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4169 Completeness == complete, % fail if incomplete
4170 find_with_var_identity(nb_getval(StoreName,Susps),[Susps],
4171 ( member(Constant,Constants),
4172 constants_store_name(C,Index,Constant,StoreName) )
4173 , Disjuncts),
4174 list2disj(Disjuncts, Disjunction),
4175 Body = ( Disjunction, member(Susp,Susps) ).
4176 enumerate_store_body(ground_constants(_,_),_,_,_) :- fail.
4177 enumerate_store_body(global_ground,C,Susp,Body) :-
4178 global_ground_store_name(C,StoreName),
4179 sbag_member_call(Susp,List,Sbag),
4180 make_get_store_goal(StoreName,List,GetStoreGoal),
4181 Body =
4182 (
4183 GetStoreGoal, % nb_getval(StoreName,List),
4184 Sbag
4185 ).
4186 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4187 Body = fail.
4188 enumerate_store_body(global_singleton,C,Susp,Body) :-
4189 global_singleton_store_name(C,StoreName),
4190 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4191 Body =
4192 (
4193 GetStoreGoal, % nb_getval(StoreName,Susp),
4194 Susp \== []
4195 ).
4196 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4197 once((
4198 member(ST,STs),
4199 enumerate_store_body(ST,C,Susp,Body)
4200 )).
4201 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4202 Body = fail.
4203 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4204 Body = fail.
4206 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4207 multi_hash_store_name(C,I,StoreName),
4208 B =
4209 (
4210 nb_getval(StoreName,HT),
4211 value_iht(HT,Susp)
4212 ).
4213 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4214 multi_hash_store_name(C,I,StoreName),
4215 make_get_store_goal(StoreName,HT,GetStoreGoal),
4216 B =
4217 (
4218 GetStoreGoal, % nb_getval(StoreName,HT),
4219 value_ht(HT,Susp)
4220 ).
4222 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4225 :- chr_constraint
4226 prev_guard_list/8,
4227 prev_guard_list/6,
4228 simplify_guards/1,
4229 set_all_passive/1.
4231 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4232 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4233 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4234 :- chr_option(mode,simplify_guards(+)).
4235 :- chr_option(mode,set_all_passive(+)).
4237 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4238 % GUARD SIMPLIFICATION
4239 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4240 % If the negation of the guards of earlier rules entails (part of)
4241 % the current guard, the current guard can be simplified. We can only
4242 % use earlier rules with a head that matches if the head of the current
4243 % rule does, and which make it impossible for the current rule to match
4244 % if they fire (i.e. they shouldn't be propagation rules and their
4245 % head constraints must be subsets of those of the current rule).
4246 % At this point, we know for sure that the negation of the guard
4247 % of such a rule has to be true (otherwise the earlier rule would have
4248 % fired, because of the refined operational semantics), so we can use
4249 % that information to simplify the guard by replacing all entailed
4250 % conditions by true/0. As a consequence, the never-stored analysis
4251 % (in a further phase) will detect more cases of never-stored constraints.
4252 %
4253 % e.g. c(X),d(Y) <=> X > 0 | ...
4254 % e(X) <=> X < 0 | ...
4255 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4256 % \____________/
4257 % true
4259 guard_simplification :-
4260 ( chr_pp_flag(guard_simplification,on) ->
4261 precompute_head_matchings,
4262 simplify_guards(1)
4263 ;
4264 true
4265 ).
4267 % for every rule, we create a prev_guard_list where the last argument
4268 % eventually is a list of the negations of earlier guards
4269 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4270 <=>
4271 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4272 append(Head1,Head2,Heads),
4273 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4274 multiple_occ_constraints_checked([]),
4275 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4277 append(IDs1,IDs2,IDs),
4278 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4279 empty_q(EmptyHeap),
4280 insert_list_q(HeapData,EmptyHeap,Heap),
4281 next_prev_rule(Heap,_,Heap1),
4282 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4283 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4284 NextRule is RuleNb+1,
4285 simplify_guards(NextRule).
4287 next_prev_rule(Heap,RuleNb,NHeap) :-
4288 ( find_min_q(Heap,_-Priority) ->
4289 Priority = (-RuleNb),
4290 normalize_heap(Heap,Priority,NHeap)
4291 ;
4292 RuleNb = 0,
4293 NHeap = Heap
4294 ).
4296 normalize_heap(Heap,Priority,NHeap) :-
4297 ( find_min_q(Heap,_-Priority) ->
4298 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4299 ( O > 1 ->
4300 NO is O -1,
4301 get_occurrence(C,NO,RuleNb,_),
4302 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4303 ;
4304 Heap2 = Heap1
4305 ),
4306 normalize_heap(Heap2,Priority,NHeap)
4307 ;
4308 NHeap = Heap
4309 ).
4311 % no more rule
4312 simplify_guards(_)
4313 <=>
4314 true.
4316 % The negation of the guard of a non-propagation rule is added
4317 % if its kept head constraints are a subset of the kept constraints of
4318 % the rule we're working on, and its removed head constraints (at least one)
4319 % are a subset of the removed constraints.
4321 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4322 <=>
4323 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4324 H1 \== [],
4325 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4326 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4327 |
4328 append(H1,H2,Heads),
4329 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4330 append(GuardList,DerivedInfo,GL1),
4331 normalize_conj_list(GL1,GL),
4332 append(GH_New1,GH,GH1),
4333 normalize_conj_list(GH1,GH_New),
4334 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4335 % PrevPrevRuleNb is PrevRuleNb-1,
4336 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4338 % if this isn't the case, we skip this one and try the next rule
4339 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4340 <=>
4341 ( N > 0 ->
4342 next_prev_rule(Heap,N1,NHeap),
4343 % N1 is N-1,
4344 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4345 ;
4346 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4347 ).
4349 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4350 <=>
4351 GH \== []
4352 |
4353 head_types_modes_condition(GH,H,TypeInfo),
4354 conj2list(TypeInfo,TI),
4355 term_variables(H,HeadVars),
4356 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4357 normalize_conj_list(Info,InfoL),
4358 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4360 head_types_modes_condition([],H,true).
4361 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4362 types_modes_condition(H,GH,TI1),
4363 head_types_modes_condition(GHs,H,TI2).
4365 %%
4366 %
4367 % when all earlier guards are added or skipped, we simplify the guard.
4368 % if it's different from the original one, we change the rule
4370 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4371 <=>
4372 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4373 G \== true, % let's not try to simplify this ;)
4374 append(M,GuardList,Info),
4375 simplify_guard(G,B,Info,SimpleGuard,NB),
4376 G \== SimpleGuard
4377 |
4378 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4379 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4381 %% normalize_conj_list(+List,-NormalList) is det.
4382 %
4383 % Removes =true= elements and flattens out conjunctions.
4385 normalize_conj_list(List,NormalList) :-
4386 list2conj(List,Conj),
4387 conj2list(Conj,NormalList).
4389 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4390 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4391 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4393 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4394 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4395 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4396 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4397 append(Renaming1,ExtraRenaming,Renaming2),
4398 list2conj(PrevMatchings,Match),
4399 negate_b(Match,HeadsDontMatch),
4400 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4401 list2conj(HeadsMatch,HeadsMatchBut),
4402 term_variables(Renaming2,RenVars),
4403 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4404 new_vars(MGVars,RenVars,ExtraRenaming2),
4405 append(Renaming2,ExtraRenaming2,Renaming),
4406 ( PrevGuard == true -> % true can't fail
4407 Info_ = HeadsDontMatch
4408 ;
4409 negate_b(PrevGuard,TheGuardFailed),
4410 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4411 ),
4412 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4413 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4414 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4415 list2conj(RenamedMatchings_,RenamedMatchings),
4416 apply_guard_wrt_term(H,RenamedG2,GH2),
4417 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4418 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4420 simplify_guard(G,B,Info,SG,NB) :-
4421 conj2list(G,LG),
4422 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4423 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4424 list2conj(SGL,SG).
4427 new_vars([],_,[]).
4428 new_vars([A|As],RV,ER) :-
4429 ( memberchk_eq(A,RV) ->
4430 new_vars(As,RV,ER)
4431 ;
4432 ER = [A-NewA,NewA-A|ER2],
4433 new_vars(As,RV,ER2)
4434 ).
4436 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4437 %
4438 % check if a list of constraints is a subset of another list of constraints
4439 % (multiset-subset), meanwhile computing a variable renaming to convert
4440 % one into the other.
4441 head_subset(H,Head,Renaming) :-
4442 head_subset(H,Head,Renaming,[],_).
4444 head_subset([],Remainder,Renaming,Renaming,Remainder).
4445 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4446 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4447 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4449 % check if A is in the list, remove it from Headleft
4450 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4451 ( variable_replacement(A,X,Acc,Renaming),
4452 Remainder = Xs
4453 ;
4454 Remainder = [X|RRemainder],
4455 head_member(Xs,A,Renaming,Acc,RRemainder)
4456 ).
4457 %-------------------------------------------------------------------------------%
4458 % memoing code to speed up repeated computation
4460 :- chr_constraint precompute_head_matchings/0.
4462 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4463 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4464 append(H1,H2,Heads),
4465 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4466 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4467 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4469 precompute_head_matchings <=> true.
4471 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4472 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4474 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4475 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4477 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4478 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4479 <=>
4480 Q1 = NHeads,
4481 Q2 = Matchings.
4482 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4484 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4485 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4486 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4487 %-------------------------------------------------------------------------------%
4489 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4490 extract_arguments(Heads,Arguments),
4491 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4492 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4494 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4495 extract_arguments(Heads,Arguments),
4496 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4497 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4499 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4500 extract_arguments(Heads,Arguments1),
4501 extract_arguments(MatchingFreeHeads,Arguments2),
4502 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4504 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4505 %
4506 % Returns list of arguments of given list of constraints.
4507 extract_arguments([],[]).
4508 extract_arguments([Constraint|Constraints],AllArguments) :-
4509 Constraint =.. [_|Arguments],
4510 append(Arguments,RestArguments,AllArguments),
4511 extract_arguments(Constraints,RestArguments).
4513 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4514 %
4515 % Substitutes arguments of constraints with those in the given list.
4517 substitute_arguments([],[],[]).
4518 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4519 functor(Constraint,F,N),
4520 split_at(N,Variables,Arguments,RestVariables),
4521 NConstraint =.. [F|Arguments],
4522 substitute_arguments(Constraints,RestVariables,NConstraints).
4524 make_matchings_explicit([],[],_,MC,MC,[]).
4525 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4526 ( var(Arg) ->
4527 ( memberchk_eq(Arg,VarAcc) ->
4528 list2disj(MatchingCondition,MatchingCondition_disj),
4529 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4530 NVarAcc = VarAcc
4531 ;
4532 Matchings = RestMatchings,
4533 NewVar = Arg,
4534 NVarAcc = [Arg|VarAcc]
4535 ),
4536 MatchingCondition2 = MatchingCondition
4537 ;
4538 functor(Arg,F,A),
4539 Arg =.. [F|RecArgs],
4540 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4541 FlatArg =.. [F|RecVars],
4542 ( RecMatchings == [] ->
4543 Matchings = [functor(NewVar,F,A)|RestMatchings]
4544 ;
4545 list2conj(RecMatchings,ArgM_conj),
4546 list2disj(MatchingCondition,MatchingCondition_disj),
4547 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4548 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4549 ),
4550 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4551 term_variables(Args,ArgVars),
4552 append(ArgVars,VarAcc,NVarAcc)
4553 ),
4554 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4557 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4558 %
4559 % Returns list of new variables and list of pairwise unifications between given list and variables.
4561 make_matchings_explicit_not_negated([],[],[]).
4562 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4563 Matchings = [Var = X|RMatchings],
4564 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4566 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4567 %
4568 % (Partially) applies substitutions of =Goal= to given list.
4570 apply_guard_wrt_term([],_Guard,[]).
4571 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4572 ( var(Term) ->
4573 apply_guard_wrt_variable(Guard,Term,NTerm)
4574 ;
4575 Term =.. [F|HArgs],
4576 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4577 NTerm =.. [F|NewHArgs]
4578 ),
4579 apply_guard_wrt_term(RH,Guard,RGH).
4581 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4582 %
4583 % (Partially) applies goal =Guard= wrt variable.
4585 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4586 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4587 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4588 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4589 ( Guard = (X = Y), Variable == X ->
4590 NVariable = Y
4591 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4592 functor(NVariable,Functor,Arity)
4593 ;
4594 NVariable = Variable
4595 ).
4597 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4598 % ALWAYS FAILING HEADS
4599 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4601 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4602 <=>
4603 chr_pp_flag(check_impossible_rules,on),
4604 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4605 append(M,GuardList,Info),
4606 guard_entailment:entails_guard(Info,fail)
4607 |
4608 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4609 set_all_passive(RuleNb).
4611 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4612 % HEAD SIMPLIFICATION
4613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4615 % now we check the head matchings (guard may have been simplified meanwhile)
4616 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4617 <=>
4618 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4619 simplify_heads(M,GuardList,G,B,NewM,NewB),
4620 NewM \== [],
4621 extract_arguments(Head1,VH1),
4622 extract_arguments(Head2,VH2),
4623 extract_arguments(H,VH),
4624 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4625 substitute_arguments(Head1,H1,NewH1),
4626 substitute_arguments(Head2,H2,NewH2),
4627 append(NewB,NewB_,NewBody),
4628 list2conj(NewBody,BodyMatchings),
4629 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4630 (Head1 \== NewH1 ; Head2 \== NewH2 )
4631 |
4632 rule(RuleNb,NewRule).
4634 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4635 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4636 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4638 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4639 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4640 ( NH == M ->
4641 H2_ = M,
4642 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4643 ;
4644 (M = functor(X,F,A), NH == X ->
4645 length(A_args,A),
4646 (var(H2) ->
4647 NewB1 = [],
4648 H2_ =.. [F|A_args]
4649 ;
4650 H2 =.. [F|OrigArgs],
4651 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4652 H2_ =.. [F|A_args_]
4653 ),
4654 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4655 append(NewB1,NewB2,NewB)
4656 ;
4657 H2_ = H2,
4658 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4659 )
4660 ).
4662 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4663 ( NH == M ->
4664 H1_ = M,
4665 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4666 ;
4667 (M = functor(X,F,A), NH == X ->
4668 length(A_args,A),
4669 (var(H1) ->
4670 NewB1 = [],
4671 H1_ =.. [F|A_args]
4672 ;
4673 H1 =.. [F|OrigArgs],
4674 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4675 H1_ =.. [F|A_args_]
4676 ),
4677 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4678 append(NewB1,NewB2,NewB)
4679 ;
4680 H1_ = H1,
4681 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4682 )
4683 ).
4685 use_same_args([],[],[],_,_,[]).
4686 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4687 var(OA),!,
4688 Out = OA,
4689 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4690 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4691 nonvar(OA),!,
4692 ( common_variables(OA,Body) ->
4693 NewB = [NA = OA|NextB]
4694 ;
4695 NewB = NextB
4696 ),
4697 Out = NA,
4698 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4701 simplify_heads([],_GuardList,_G,_Body,[],[]).
4702 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4703 M = (A = B),
4704 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4705 guard_entailment:entails_guard(GuardList,(A=B)) ->
4706 ( common_variables(B,G-RM-GuardList) ->
4707 NewB = NextB,
4708 NewM = NextM
4709 ;
4710 ( common_variables(B,Body) ->
4711 NewB = [A = B|NextB]
4712 ;
4713 NewB = NextB
4714 ),
4715 NewM = [A|NextM]
4716 )
4717 ;
4718 ( nonvar(B), functor(B,BFu,BAr),
4719 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4720 NewB = NextB,
4721 ( common_variables(B,G-RM-GuardList) ->
4722 NewM = NextM
4723 ;
4724 NewM = [functor(A,BFu,BAr)|NextM]
4725 )
4726 ;
4727 NewM = NextM,
4728 NewB = NextB
4729 )
4730 ),
4731 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4733 common_variables(B,G) :-
4734 term_variables(B,BVars),
4735 term_variables(G,GVars),
4736 intersect_eq(BVars,GVars,L),
4737 L \== [].
4740 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4741 % ALWAYS FAILING GUARDS
4742 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4744 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4745 set_all_passive(_) <=> true.
4747 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4748 ==>
4749 chr_pp_flag(check_impossible_rules,on),
4750 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4751 conj2list(G,GL),
4752 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4753 guard_entailment:entails_guard(GL,fail)
4754 |
4755 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4756 set_all_passive(RuleNb).
4760 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4761 % OCCURRENCE SUBSUMPTION
4762 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4764 :- chr_constraint
4765 first_occ_in_rule/4,
4766 next_occ_in_rule/6.
4768 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4769 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4771 :- chr_constraint multiple_occ_constraints_checked/1.
4772 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4774 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4775 occurrence(C,O,RuleNb,ID,_),
4776 occurrence(C,O2,RuleNb,ID2,_),
4777 rule(RuleNb,Rule)
4778 \
4779 multiple_occ_constraints_checked(Done)
4780 <=>
4781 O < O2,
4782 chr_pp_flag(occurrence_subsumption,on),
4783 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4784 H1 \== [],
4785 \+ memberchk_eq(C,Done)
4786 |
4787 first_occ_in_rule(RuleNb,C,O,ID),
4788 multiple_occ_constraints_checked([C|Done]).
4790 % Find first occurrence of constraint =C= in rule =RuleNb=
4791 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4792 <=>
4793 O < O2
4794 |
4795 first_occ_in_rule(RuleNb,C,O,ID).
4797 first_occ_in_rule(RuleNb,C,O,ID_o1)
4798 <=>
4799 C = F/A,
4800 functor(FreshHead,F,A),
4801 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4803 % Skip passive occurrences.
4804 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4805 <=>
4806 O2 is O+1
4807 |
4808 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4810 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)
4811 <=>
4812 O2 is O+1,
4813 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4814 |
4815 append(H1,H2,Heads),
4816 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4817 ( ExtraCond == [chr_pp_void_info] ->
4818 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4819 ;
4820 append(ExtraCond,Cond,NewCond),
4821 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4822 copy_term(GuardList,FGuardList),
4823 variable_replacement(GuardList,FGuardList,GLRepl),
4824 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4825 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4826 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4827 append(NewCond,GuardList2,BigCond),
4828 append(BigCond,GuardList3,BigCond2),
4829 copy_with_variable_replacement(M,M2,Repl),
4830 copy_with_variable_replacement(M,M3,Repl2),
4831 append(M3,BigCond2,BigCond3),
4832 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4833 list2conj(CheckCond,OccSubsum),
4834 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4835 ( OccSubsum \= chr_pp_void_info ->
4836 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4837 passive(RuleNb,ID_o2)
4838 ;
4839 true
4840 )
4841 ;
4842 true
4843 ),!,
4844 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4845 ).
4848 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4849 <=>
4850 true.
4852 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4853 <=>
4854 true.
4856 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4857 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4858 append(ID2,ID1,IDs),
4859 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4860 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4861 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4862 copy_with_variable_replacement(G,FG,Repl),
4863 extract_explicit_matchings(FG,FG2),
4864 negate_b(FG2,NotFG),
4865 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4866 ( safely_unifiable(FH,FH2), FH=FH2 ->
4867 FailCond = [(NotFG;FMPCond)]
4868 ;
4869 % in this case, not much can be done
4870 % e.g. c(f(...)), c(g(...)) <=> ...
4871 FailCond = [chr_pp_void_info]
4872 ).
4874 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4875 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4876 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4877 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4878 Cond = (chr_pp_not_in_store(H);Cond1),
4879 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4881 extract_explicit_matchings((A,B),D) :- !,
4882 ( extract_explicit_matchings(A) ->
4883 extract_explicit_matchings(B,D)
4884 ;
4885 D = (A,E),
4886 extract_explicit_matchings(B,E)
4887 ).
4888 extract_explicit_matchings(A,D) :- !,
4889 ( extract_explicit_matchings(A) ->
4890 D = true
4891 ;
4892 D = A
4893 ).
4895 extract_explicit_matchings(A=B) :-
4896 var(A), var(B), !, A=B.
4897 extract_explicit_matchings(A==B) :-
4898 var(A), var(B), !, A=B.
4900 safely_unifiable(H,I) :- var(H), !.
4901 safely_unifiable([],[]) :- !.
4902 safely_unifiable([H|Hs],[I|Is]) :- !,
4903 safely_unifiable(H,I),
4904 safely_unifiable(Hs,Is).
4905 safely_unifiable(H,I) :-
4906 nonvar(H),
4907 nonvar(I),
4908 H =.. [F|HA],
4909 I =.. [F|IA],
4910 safely_unifiable(HA,IA).
4914 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4915 % TYPE INFORMATION
4916 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4918 :- chr_constraint
4919 type_definition/2,
4920 type_alias/2,
4921 constraint_type/2,
4922 get_type_definition/2,
4923 get_constraint_type/2.
4926 :- chr_option(mode,type_definition(?,?)).
4927 :- chr_option(mode,get_type_definition(?,?)).
4928 :- chr_option(mode,type_alias(?,?)).
4929 :- chr_option(mode,constraint_type(+,+)).
4930 :- chr_option(mode,get_constraint_type(+,-)).
4932 assert_constraint_type(Constraint,ArgTypes) :-
4933 ( ground(ArgTypes) ->
4934 constraint_type(Constraint,ArgTypes)
4935 ;
4936 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
4937 ).
4939 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4940 % Consistency checks of type aliases
4942 type_alias(T,T2) <=>
4943 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4944 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4945 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4947 type_alias(T1,A1), type_alias(T2,A2) <=>
4948 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4949 \+ (T1\=T2) |
4950 copy_term_nat(T1,T1_),
4951 copy_term_nat(T2,T2_),
4952 T1_ = T2_,
4953 chr_error(type_error,
4954 '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_]).
4956 type_alias(T,B) \ type_alias(X,T2) <=>
4957 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4958 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4959 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4960 type_alias(X2,D1).
4962 oneway_unification(X,Y) :-
4963 term_variables(X,XVars),
4964 chr_runtime:lockv(XVars),
4965 X=Y,
4966 chr_runtime:unlockv(XVars).
4968 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4969 % Consistency checks of type definitions
4971 type_definition(T1,_), type_definition(T2,_)
4972 <=>
4973 functor(T1,F,A), functor(T2,F,A)
4974 |
4975 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
4977 type_definition(T1,_), type_alias(T2,_)
4978 <=>
4979 functor(T1,F,A), functor(T2,F,A)
4980 |
4981 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
4983 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4984 %% get_type_definition(+Type,-Definition) is semidet.
4985 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4987 get_type_definition(T,Def)
4988 <=>
4989 \+ ground(T)
4990 |
4991 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
4993 type_alias(T,D) \ get_type_definition(T2,Def)
4994 <=>
4995 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4996 copy_term_nat((T,D),(T1,D1)),T1=T2
4997 |
4998 ( get_type_definition(D1,Def) ->
4999 true
5000 ;
5001 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5002 ).
5004 type_definition(T,D) \ get_type_definition(T2,Def)
5005 <=>
5006 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5007 copy_term_nat((T,D),(T1,D1)),T1=T2
5008 |
5009 Def = D1.
5011 get_type_definition(Type,Def)
5012 <=>
5013 atomic_builtin_type(Type,_,_)
5014 |
5015 Def = [Type].
5017 get_type_definition(Type,Def)
5018 <=>
5019 compound_builtin_type(Type,_,_)
5020 |
5021 Def = [Type].
5023 get_type_definition(X,Y) <=> fail.
5025 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5026 %% get_type_definition_det(+Type,-Definition) is det.
5027 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5028 get_type_definition_det(Type,Definition) :-
5029 ( get_type_definition(Type,Definition) ->
5030 true
5031 ;
5032 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5033 ).
5035 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5036 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5037 %
5038 % Return argument types of =ConstraintSymbol=, but fails if none where
5039 % declared.
5040 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5041 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5042 get_constraint_type(_,_) <=> fail.
5044 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5045 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5046 %
5047 % Like =get_constraint_type/2=, but returns list of =any= types when
5048 % no types are declared.
5049 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5050 get_constraint_type_det(ConstraintSymbol,Types) :-
5051 ( get_constraint_type(ConstraintSymbol,Types) ->
5052 true
5053 ;
5054 ConstraintSymbol = _ / N,
5055 replicate(N,any,Types)
5056 ).
5057 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5058 %% unalias_type(+Alias,-Type) is det.
5059 %
5060 % Follows alias chain until base type is reached.
5061 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5062 :- chr_constraint unalias_type/2.
5064 unalias_var @
5065 unalias_type(Alias,BaseType)
5066 <=>
5067 var(Alias)
5068 |
5069 BaseType = Alias.
5071 unalias_alias @
5072 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5073 <=>
5074 nonvar(AliasProtoType),
5075 nonvar(Alias),
5076 functor(AliasProtoType,F,A),
5077 functor(Alias,F,A),
5078 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5079 Alias = AliasInstance
5080 |
5081 unalias_type(Type,BaseType).
5083 unalias_type_definition @
5084 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5085 <=>
5086 nonvar(ProtoType),
5087 nonvar(Alias),
5088 functor(ProtoType,F,A),
5089 functor(Alias,F,A)
5090 |
5091 BaseType = Alias.
5093 unalias_atomic_builtin @
5094 unalias_type(Alias,BaseType)
5095 <=>
5096 atomic_builtin_type(Alias,_,_)
5097 |
5098 BaseType = Alias.
5100 unalias_compound_builtin @
5101 unalias_type(Alias,BaseType)
5102 <=>
5103 compound_builtin_type(Alias,_,_)
5104 |
5105 BaseType = Alias.
5107 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5108 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5109 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5110 :- chr_constraint types_modes_condition/3.
5111 :- chr_option(mode,types_modes_condition(+,+,?)).
5112 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5114 types_modes_condition([],[],T) <=> T=true.
5116 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5117 <=>
5118 functor(Head,F,A)
5119 |
5120 Head =.. [_|Args],
5121 Condition = (ModesCondition, TypesCondition, RestCondition),
5122 modes_condition(Modes,Args,ModesCondition),
5123 get_constraint_type_det(F/A,Types),
5124 UnrollHead =.. [_|RealArgs],
5125 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5126 types_modes_condition(Heads,UnrollHeads,RestCondition).
5128 types_modes_condition([Head|_],_,_)
5129 <=>
5130 functor(Head,F,A),
5131 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5134 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5135 %% modes_condition(+Modes,+Args,-Condition) is det.
5136 %
5137 % Return =Condition= on =Args= that checks =Modes=.
5138 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5139 modes_condition([],[],true).
5140 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5141 ( Mode == (+) ->
5142 Condition = ( ground(Arg) , RCondition )
5143 ; Mode == (-) ->
5144 Condition = ( var(Arg) , RCondition )
5145 ;
5146 Condition = RCondition
5147 ),
5148 modes_condition(Modes,Args,RCondition).
5150 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5151 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5152 %
5153 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5154 % =UnrollArgs= controls the depth of type definition unrolling.
5155 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5156 types_condition([],[],[],[],true).
5157 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5158 ( Mode == (-) ->
5159 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5160 ;
5161 get_type_definition_det(Type,Def),
5162 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5163 ( Mode == (+) ->
5164 TypeConditionList = TypeConditionList1
5165 ;
5166 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5167 )
5168 ),
5169 list2disj(TypeConditionList,DisjTypeConditionList),
5170 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5172 type_condition([],_,_,_,[]).
5173 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5174 ( var(DefCase) ->
5175 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5176 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5177 true
5178 ; compound_builtin_type(DefCase,Arg,Condition) ->
5179 true
5180 ;
5181 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5182 ),
5183 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5185 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5186 :- chr_type atomic_builtin_type ---> any
5187 ; number
5188 ; float
5189 ; int
5190 ; natural
5191 ; dense_int
5192 ; chr_identifier
5193 ; chr_identifier(any).
5194 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5196 atomic_builtin_type(any,_Arg,true).
5197 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5198 atomic_builtin_type(int,Arg,integer(Arg)).
5199 atomic_builtin_type(number,Arg,number(Arg)).
5200 atomic_builtin_type(float,Arg,float(Arg)).
5201 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5202 atomic_builtin_type(chr_identifier,_Arg,true).
5204 compound_builtin_type(chr_identifier(_),_Arg,true).
5206 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5207 ( nonvar(DefCase) ->
5208 functor(DefCase,F,A),
5209 ( A == 0 ->
5210 Condition = (Arg = DefCase)
5211 ; var(UnrollArg) ->
5212 Condition = functor(Arg,F,A)
5213 ; functor(UnrollArg,F,A) ->
5214 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5215 DefCase =.. [_|ArgTypes],
5216 UnrollArg =.. [_|UnrollArgs],
5217 functor(Template,F,A),
5218 Template =.. [_|TemplateArgs],
5219 replicate(A,Mode,ArgModes),
5220 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5221 ;
5222 Condition = functor(Arg,F,A)
5223 )
5224 ;
5225 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5226 ).
5229 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5230 % STATIC TYPE CHECKING
5231 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5232 % Checks head constraints and CHR constraint calls in bodies.
5233 %
5234 % TODO:
5235 % - type clashes involving built-in types
5236 % - Prolog built-ins in guard and body
5237 % - indicate position in terms in error messages
5238 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5239 :- chr_constraint
5240 static_type_check/0.
5243 % 1. Check the declared types
5245 constraint_type(Constraint,ArgTypes), static_type_check
5246 ==>
5247 forall(
5248 ( member(ArgType,ArgTypes), forsubterm(ArgType,Type) ),
5249 ( get_type_definition(Type,_) ->
5250 true
5251 ;
5252 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5253 )
5254 ).
5257 forsubterm(Term,SubTerm) :-
5258 (
5259 SubTerm = Term
5260 ;
5261 Term =.. [_|Args],
5262 member(Arg,Args),
5263 forsubterm(Arg,SubTerm)
5264 ).
5267 % 2. Check the rules
5269 :- chr_type type_error_src ---> head(any) ; body(any).
5271 rule(_,Rule), static_type_check
5272 ==>
5273 copy_term_nat(Rule,RuleCopy),
5274 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5275 (
5276 catch(
5277 ( static_type_check_heads(Head1),
5278 static_type_check_heads(Head2),
5279 conj2list(Body,GoalList),
5280 static_type_check_body(GoalList)
5281 ),
5282 type_error(Error),
5283 ( Error = invalid_functor(Src,Term,Type) ->
5284 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5285 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5286 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5287 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5288 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5289 )
5290 ),
5291 fail % cleanup constraints
5292 ;
5293 true
5294 ).
5297 static_type_check <=> true.
5299 static_type_check_heads([]).
5300 static_type_check_heads([Head|Heads]) :-
5301 static_type_check_head(Head),
5302 static_type_check_heads(Heads).
5304 static_type_check_head(Head) :-
5305 functor(Head,F,A),
5306 get_constraint_type_det(F/A,Types),
5307 Head =..[_|Args],
5308 maplist(static_type_check_term(head(Head)),Args,Types).
5310 static_type_check_body([]).
5311 static_type_check_body([Goal|Goals]) :-
5312 functor(Goal,F,A),
5313 get_constraint_type_det(F/A,Types),
5314 Goal =..[_|Args],
5315 maplist(static_type_check_term(body(Goal)),Args,Types),
5316 static_type_check_body(Goals).
5318 :- chr_constraint static_type_check_term/3.
5319 :- chr_option(mode,static_type_check_term(?,?,?)).
5320 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5322 static_type_check_term(Src,Term,Type)
5323 <=>
5324 var(Term)
5325 |
5326 static_type_check_var(Src,Term,Type).
5327 static_type_check_term(Src,Term,Type)
5328 <=>
5329 atomic_builtin_type(Type,Term,Goal)
5330 |
5331 ( call(Goal) ->
5332 true
5333 ;
5334 throw(type_error(invalid_functor(Src,Term,Type)))
5335 ).
5336 static_type_check_term(Src,Term,Type)
5337 <=>
5338 compound_builtin_type(Type,Term,Goal)
5339 |
5340 ( call(Goal) ->
5341 true
5342 ;
5343 throw(type_error(invalid_functor(Src,Term,Type)))
5344 ).
5345 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5346 <=>
5347 functor(Type,F,A),
5348 functor(AType,F,A)
5349 |
5350 copy_term_nat(AType-ADef,Type-Def),
5351 static_type_check_term(Src,Term,Def).
5353 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5354 <=>
5355 functor(Type,F,A),
5356 functor(AType,F,A)
5357 |
5358 copy_term_nat(AType-ADef,Type-Variants),
5359 functor(Term,TF,TA),
5360 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5361 Term =.. [_|Args],
5362 Variant =.. [_|Types],
5363 maplist(static_type_check_term(Src),Args,Types)
5364 ;
5365 throw(type_error(invalid_functor(Src,Term,Type)))
5366 ).
5368 static_type_check_term(Src,Term,Type)
5369 <=>
5370 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5372 :- chr_constraint static_type_check_var/3.
5373 :- chr_option(mode,static_type_check_var(?,-,?)).
5374 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5376 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5377 <=>
5378 functor(AType,F,A),
5379 functor(Type,F,A)
5380 |
5381 copy_term_nat(AType-ADef,Type-Def),
5382 static_type_check_var(Src,Var,Def).
5384 static_type_check_var(Src,Var,Type)
5385 <=>
5386 atomic_builtin_type(Type,_,_)
5387 |
5388 static_atomic_builtin_type_check_var(Src,Var,Type).
5390 static_type_check_var(Src,Var,Type)
5391 <=>
5392 compound_builtin_type(Type,_,_)
5393 |
5394 true.
5397 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5398 <=>
5399 Type1 \== Type2
5400 |
5401 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5403 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5404 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5405 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5406 :- chr_constraint static_atomic_builtin_type_check_var/3.
5407 :- chr_option(mode,static_type_check_var(?,-,+)).
5408 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5410 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5411 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5412 <=>
5413 true.
5414 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5415 <=>
5416 true.
5417 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5418 <=>
5419 true.
5420 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5421 <=>
5422 true.
5423 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5424 <=>
5425 true.
5426 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5427 <=>
5428 true.
5429 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5430 <=>
5431 true.
5432 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5433 <=>
5434 true.
5435 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5436 <=>
5437 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5439 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5440 %% format_src(+type_error_src) is det.
5441 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5442 format_src(head(Head)) :- format('head ~w',[Head]).
5443 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5445 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5446 % Dynamic type checking
5447 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5449 :- chr_constraint
5450 dynamic_type_check/0,
5451 dynamic_type_check_clauses/1,
5452 get_dynamic_type_check_clauses/1.
5454 generate_dynamic_type_check_clauses(Clauses) :-
5455 ( chr_pp_flag(debugable,on) ->
5456 dynamic_type_check,
5457 get_dynamic_type_check_clauses(Clauses0),
5458 append(Clauses0,
5459 [('$dynamic_type_check'(Type,Term) :-
5460 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5461 )],
5462 Clauses)
5463 ;
5464 Clauses = []
5465 ).
5467 type_definition(T,D), dynamic_type_check
5468 ==>
5469 copy_term_nat(T-D,Type-Definition),
5470 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5471 dynamic_type_check_clauses(DynamicChecks).
5472 type_alias(A,B), dynamic_type_check
5473 ==>
5474 copy_term_nat(A-B,Alias-Body),
5475 dynamic_type_check_alias_clause(Alias,Body,Clause),
5476 dynamic_type_check_clauses([Clause]).
5478 dynamic_type_check <=>
5479 findall(
5480 ('$dynamic_type_check'(Type,Term) :- Goal),
5481 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
5482 BuiltinChecks
5483 ),
5484 dynamic_type_check_clauses(BuiltinChecks).
5486 dynamic_type_check_clause(T,DC,Clause) :-
5487 copy_term(T-DC,Type-DefinitionClause),
5488 functor(DefinitionClause,F,A),
5489 functor(Term,F,A),
5490 DefinitionClause =.. [_|DCArgs],
5491 Term =.. [_|TermArgs],
5492 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5493 list2conj(RecursiveCallList,RecursiveCalls),
5494 Clause = (
5495 '$dynamic_type_check'(Type,Term) :-
5496 RecursiveCalls
5497 ).
5499 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5500 Clause = (
5501 '$dynamic_type_check'(Alias,Term) :-
5502 '$dynamic_type_check'(Body,Term)
5503 ).
5505 dynamic_type_check_call(Type,Term,Call) :-
5506 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5507 % Call = when(nonvar(Term),Goal)
5508 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5509 % Call = when(nonvar(Term),Goal)
5510 % ;
5511 ( Type == any ->
5512 Call = true
5513 ;
5514 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5515 )
5516 % )
5517 .
5519 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5520 <=>
5521 append(C1,C2,C),
5522 dynamic_type_check_clauses(C).
5524 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5525 <=>
5526 Q = C.
5527 get_dynamic_type_check_clauses(Q)
5528 <=>
5529 Q = [].
5531 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5532 % Atomic Types
5533 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5534 % Some optimizations can be applied for atomic types...
5535 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5537 atomic_types_suspended_constraint(C) :-
5538 C = _/N,
5539 get_constraint_type(C,ArgTypes),
5540 get_constraint_mode(C,ArgModes),
5541 findall(I,between(1,N,I),Indexes),
5542 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5544 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5545 ( is_indexed_argument(C,Index) ->
5546 ( Mode == (?) ->
5547 atomic_type(Type)
5548 ;
5549 true
5550 )
5551 ;
5552 true
5553 ).
5555 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5556 %% atomic_type(+Type) is semidet.
5557 %
5558 % Succeeds when all values of =Type= are atomic.
5559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5560 :- chr_constraint atomic_type/1.
5562 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5564 type_definition(TypePat,Def) \ atomic_type(Type)
5565 <=>
5566 functor(Type,F,A), functor(TypePat,F,A)
5567 |
5568 forall(member(Term,Def),atomic(Term)).
5570 type_alias(TypePat,Alias) \ atomic_type(Type)
5571 <=>
5572 functor(Type,F,A), functor(TypePat,F,A)
5573 |
5574 atomic(Alias),
5575 copy_term_nat(TypePat-Alias,Type-NType),
5576 atomic_type(NType).
5578 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5579 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5580 %
5581 % Succeeds when all values of =Type= are atomic
5582 % and the atom values are finitely enumerable.
5583 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5584 :- chr_constraint enumerated_atomic_type/2.
5586 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5588 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5589 <=>
5590 functor(Type,F,A), functor(TypePat,F,A)
5591 |
5592 forall(member(Term,Def),atomic(Term)),
5593 Atoms = Def.
5595 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5596 <=>
5597 functor(Type,F,A), functor(TypePat,F,A)
5598 |
5599 atomic(Alias),
5600 copy_term_nat(TypePat-Alias,Type-NType),
5601 enumerated_atomic_type(NType,Atoms).
5602 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5604 :- chr_constraint
5605 stored/3, % constraint,occurrence,(yes/no/maybe)
5606 stored_completing/3,
5607 stored_complete/3,
5608 is_stored/1,
5609 is_finally_stored/1,
5610 check_all_passive/2.
5612 :- chr_option(mode,stored(+,+,+)).
5613 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5614 :- chr_type storedinfo ---> yes ; no ; maybe.
5615 :- chr_option(mode,stored_complete(+,+,+)).
5616 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5617 :- chr_option(mode,guard_list(+,+,+,+)).
5618 :- chr_option(mode,check_all_passive(+,+)).
5619 :- chr_option(type_declaration,check_all_passive(any,list)).
5621 % change yes in maybe when yes becomes passive
5622 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5623 stored(C,O,yes), stored_complete(C,RO,Yesses)
5624 <=> O < RO | NYesses is Yesses - 1,
5625 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5626 % change yes in maybe when not observed
5627 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5628 <=> O < RO |
5629 NYesses is Yesses - 1,
5630 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5632 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5633 ==> RO =< MO2 | % C2 is never stored
5634 passive(RuleNb,ID).
5639 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5641 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5642 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5643 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5645 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5646 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5647 check_all_passive(RuleNb,IDs2).
5649 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5650 check_all_passive(RuleNb,IDs).
5652 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5653 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5655 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5657 % collect the storage information
5658 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5659 <=> NO is O + 1, NYesses is Yesses + 1,
5660 stored_completing(C,NO,NYesses).
5661 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5662 <=> NO is O + 1,
5663 stored_completing(C,NO,Yesses).
5665 stored(C,O,no) \ stored_completing(C,O,Yesses)
5666 <=> stored_complete(C,O,Yesses).
5667 stored_completing(C,O,Yesses)
5668 <=> stored_complete(C,O,Yesses).
5670 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5671 O2 > O | passive(RuleNb,Id).
5673 % decide whether a constraint is stored
5674 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5675 <=> RO =< MO | fail.
5676 is_stored(C) <=> true.
5678 % decide whether a constraint is suspends after occurrences
5679 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5680 <=> RO =< MO | fail.
5681 is_finally_stored(C) <=> true.
5683 storage_analysis(Constraints) :-
5684 ( chr_pp_flag(storage_analysis,on) ->
5685 check_constraint_storages(Constraints)
5686 ;
5687 true
5688 ).
5690 check_constraint_storages([]).
5691 check_constraint_storages([C|Cs]) :-
5692 check_constraint_storage(C),
5693 check_constraint_storages(Cs).
5695 check_constraint_storage(C) :-
5696 get_max_occurrence(C,MO),
5697 check_occurrences_storage(C,1,MO).
5699 check_occurrences_storage(C,O,MO) :-
5700 ( O > MO ->
5701 stored_completing(C,1,0)
5702 ;
5703 check_occurrence_storage(C,O),
5704 NO is O + 1,
5705 check_occurrences_storage(C,NO,MO)
5706 ).
5708 check_occurrence_storage(C,O) :-
5709 get_occurrence(C,O,RuleNb,ID),
5710 ( is_passive(RuleNb,ID) ->
5711 stored(C,O,maybe)
5712 ;
5713 get_rule(RuleNb,PragmaRule),
5714 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5715 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5716 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5717 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5718 check_storage_head2(Head2,O,Heads1,Body)
5719 )
5720 ).
5722 check_storage_head1(Head,O,H1,H2,G) :-
5723 functor(Head,F,A),
5724 C = F/A,
5725 ( H1 == [Head],
5726 H2 == [],
5727 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5728 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5729 Head =.. [_|L],
5730 no_matching(L,[]) ->
5731 stored(C,O,no)
5732 ;
5733 stored(C,O,maybe)
5734 ).
5736 no_matching([],_).
5737 no_matching([X|Xs],Prev) :-
5738 var(X),
5739 \+ memberchk_eq(X,Prev),
5740 no_matching(Xs,[X|Prev]).
5742 check_storage_head2(Head,O,H1,B) :-
5743 functor(Head,F,A),
5744 C = F/A,
5745 ( %(
5746 ( H1 \== [], B == true )
5747 %;
5748 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5749 %)
5750 ->
5751 stored(C,O,maybe)
5752 ;
5753 stored(C,O,yes)
5754 ).
5756 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5759 %% ____ _ ____ _ _ _ _
5760 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5761 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5762 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5763 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5764 %% |_|
5766 constraints_code(Constraints,Clauses) :-
5767 (chr_pp_flag(reduced_indexing,on),
5768 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5769 none_suspended_on_variables
5770 ;
5771 true
5772 ),
5773 constraints_code1(Constraints,Clauses,[]).
5775 %===============================================================================
5776 :- chr_constraint constraints_code1/3.
5777 :- chr_option(mode,constraints_code1(+,+,+)).
5778 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5779 %-------------------------------------------------------------------------------
5780 constraints_code1([],L,T) <=> L = T.
5781 constraints_code1([C|RCs],L,T)
5782 <=>
5783 constraint_code(C,L,T1),
5784 constraints_code1(RCs,T1,T).
5785 %===============================================================================
5786 :- chr_constraint constraint_code/3.
5787 :- chr_option(mode,constraint_code(+,+,+)).
5788 %-------------------------------------------------------------------------------
5789 %% Generate code for a single CHR constraint
5790 constraint_code(Constraint, L, T)
5791 <=> true
5792 | ( (chr_pp_flag(debugable,on) ;
5793 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5794 ( may_trigger(Constraint) ;
5795 get_allocation_occurrence(Constraint,AO),
5796 get_max_occurrence(Constraint,MO), MO >= AO ) )
5797 ->
5798 constraint_prelude(Constraint,Clause),
5799 add_dummy_location(Clause,LocatedClause),
5800 L = [LocatedClause | L1]
5801 ;
5802 L = L1
5803 ),
5804 Id = [0],
5805 occurrences_code(Constraint,1,Id,NId,L1,L2),
5806 gen_cond_attach_clause(Constraint,NId,L2,T).
5808 %===============================================================================
5809 %% Generate prelude predicate for a constraint.
5810 %% f(...) :- f/a_0(...,Susp).
5811 constraint_prelude(F/A, Clause) :-
5812 vars_susp(A,Vars,Susp,VarsSusp),
5813 Head =.. [ F | Vars],
5814 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5815 build_head(F,A,[0],VarsSusp,Delegate),
5816 ( chr_pp_flag(debugable,on) ->
5817 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5818 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5819 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5820 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5822 ( get_constraint_type(F/A,ArgTypeList) ->
5823 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5824 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5825 ;
5826 DynamicTypeChecks = true
5827 ),
5829 Clause =
5830 ( Head :-
5831 DynamicTypeChecks,
5832 InsertGoal,
5833 InsertCall,
5834 AttachCall,
5835 Inactive,
5836 'chr debug_event'(insert(Head#Susp)),
5837 (
5838 'chr debug_event'(call(Susp)),
5839 Delegate
5840 ;
5841 'chr debug_event'(fail(Susp)), !,
5842 fail
5843 ),
5844 (
5845 'chr debug_event'(exit(Susp))
5846 ;
5847 'chr debug_event'(redo(Susp)),
5848 fail
5849 )
5850 )
5851 ; get_allocation_occurrence(F/A,0) ->
5852 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5853 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5854 Clause = ( Head :- Goal, Inactive, Delegate )
5855 ;
5856 Clause = ( Head :- Delegate )
5857 ).
5859 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5860 ( may_trigger(F/A) ->
5861 build_head(F,A,[0],VarsSusp,Delegate),
5862 ( chr_pp_flag(debugable,off) ->
5863 Goal = Delegate
5864 ;
5865 get_target_module(Mod),
5866 Goal = Mod:Delegate
5867 )
5868 ;
5869 Goal = true
5870 ).
5872 %===============================================================================
5873 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5874 :- chr_option(mode,has_active_occurrence(+)).
5875 :- chr_option(mode,has_active_occurrence(+,+)).
5876 %-------------------------------------------------------------------------------
5877 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5879 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5880 O > MO | fail.
5881 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5882 has_active_occurrence(C,O) <=>
5883 NO is O + 1,
5884 has_active_occurrence(C,NO).
5885 has_active_occurrence(C,O) <=> true.
5886 %===============================================================================
5888 gen_cond_attach_clause(F/A,Id,L,T) :-
5889 ( is_finally_stored(F/A) ->
5890 get_allocation_occurrence(F/A,AllocationOccurrence),
5891 get_max_occurrence(F/A,MaxOccurrence),
5892 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5893 ( only_ground_indexed_arguments(F/A) ->
5894 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5895 ;
5896 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5897 )
5898 ; vars_susp(A,Args,Susp,AllArgs),
5899 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5900 ),
5901 build_head(F,A,Id,AllArgs,Head),
5902 Clause = ( Head :- Body ),
5903 add_dummy_location(Clause,LocatedClause),
5904 L = [LocatedClause | T]
5905 ;
5906 L = T
5907 ).
5909 :- chr_constraint use_auxiliary_predicate/1.
5910 :- chr_option(mode,use_auxiliary_predicate(+)).
5912 :- chr_constraint use_auxiliary_predicate/2.
5913 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5915 :- chr_constraint is_used_auxiliary_predicate/1.
5916 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5918 :- chr_constraint is_used_auxiliary_predicate/2.
5919 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5922 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5924 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5926 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5928 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5930 is_used_auxiliary_predicate(P) <=> fail.
5932 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5933 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5935 is_used_auxiliary_predicate(P,C) <=> fail.
5937 %------------------------------------------------------------------------------%
5938 % Only generate import statements for actually used modules.
5939 %------------------------------------------------------------------------------%
5941 :- chr_constraint use_auxiliary_module/1.
5942 :- chr_option(mode,use_auxiliary_module(+)).
5944 :- chr_constraint is_used_auxiliary_module/1.
5945 :- chr_option(mode,is_used_auxiliary_module(+)).
5948 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5950 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5952 is_used_auxiliary_module(P) <=> fail.
5954 % only called for constraints with
5955 % at least one
5956 % non-ground indexed argument
5957 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5958 vars_susp(A,Args,Susp,AllArgs),
5959 make_suspension_continuation_goal(F/A,AllArgs,Closure),
5960 ( get_store_type(F/A,var_assoc_store(_,_)) ->
5961 Attach = true
5962 ;
5963 attach_constraint_atom(F/A,Vars,Susp,Attach)
5964 ),
5965 FTerm =.. [F|Args],
5966 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5967 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5968 ( may_trigger(F/A) ->
5969 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
5970 Goal =
5971 (
5972 ( var(Susp) ->
5973 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
5974 InsertCall,
5975 Attach
5976 ;
5977 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
5978 )
5979 )
5980 ;
5981 Goal =
5982 (
5983 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
5984 InsertCall,
5985 Attach
5986 )
5987 ).
5989 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
5990 vars_susp(A,Args,Susp,AllArgs),
5991 make_suspension_continuation_goal(F/A,AllArgs,Cont),
5992 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
5993 attach_constraint_atom(F/A,Vars,Susp,Attach)
5994 ;
5995 Attach = true
5996 ),
5997 FTerm =.. [F|Args],
5998 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5999 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6000 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6001 Goal =
6002 (
6003 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6004 InsertCall
6005 )
6006 ;
6007 Goal =
6008 (
6009 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6010 InsertCall,
6011 Attach
6012 )
6013 ).
6015 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6016 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6017 attach_constraint_atom(FA,Vars,Susp,Attach)
6018 ;
6019 Attach = true
6020 ),
6021 insert_constraint_goal(FA,Susp,Args,InsertCall),
6022 ( chr_pp_flag(late_allocation,on) ->
6023 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6024 ;
6025 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6026 ).
6028 %-------------------------------------------------------------------------------
6029 :- chr_constraint occurrences_code/6.
6030 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6031 %-------------------------------------------------------------------------------
6032 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6033 <=> O > MO
6034 | NId = Id, L = T.
6035 occurrences_code(C,O,Id,NId,L,T)
6036 <=>
6037 occurrence_code(C,O,Id,Id1,L,L1),
6038 NO is O + 1,
6039 occurrences_code(C,NO,Id1,NId,L1,T).
6040 %-------------------------------------------------------------------------------
6041 :- chr_constraint occurrence_code/6.
6042 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6043 %-------------------------------------------------------------------------------
6044 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6045 <=>
6046 ( named_history(RuleNb,_,_) ->
6047 does_use_history(C,O)
6048 ;
6049 true
6050 ),
6051 NId = Id,
6052 L = T.
6053 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6054 <=> true |
6055 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6056 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6057 NId = Id,
6058 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6059 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6060 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6061 inc_id(Id,NId),
6062 ( unconditional_occurrence(C,O) ->
6063 L1 = T
6064 ;
6065 gen_alloc_inc_clause(C,O,Id,L1,T)
6066 )
6067 ).
6069 occurrence_code(C,O,_,_,_,_)
6070 <=>
6071 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6072 %-------------------------------------------------------------------------------
6074 %% Generate code based on one removed head of a CHR rule
6075 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6076 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6077 Rule = rule(_,Head2,_,_),
6078 ( Head2 == [] ->
6079 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6080 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6081 ;
6082 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6083 ).
6085 %% Generate code based on one persistent head of a CHR rule
6086 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6087 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6088 Rule = rule(Head1,_,_,_),
6089 ( Head1 == [] ->
6090 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6091 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6092 ;
6093 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6094 ).
6096 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6097 vars_susp(A,Vars,Susp,VarsSusp),
6098 build_head(F,A,Id,VarsSusp,Head),
6099 inc_id(Id,IncId),
6100 build_head(F,A,IncId,VarsSusp,CallHead),
6101 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6102 Clause =
6103 (
6104 Head :-
6105 ConditionalAlloc,
6106 CallHead
6107 ),
6108 add_dummy_location(Clause,LocatedClause),
6109 L = [LocatedClause|T].
6111 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6112 get_allocation_occurrence(FA,AO),
6113 ( chr_pp_flag(debugable,off), O == AO ->
6114 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6115 ( may_trigger(FA) ->
6116 Goal = (var(Susp) -> Goal0 ; true)
6117 ;
6118 Goal = Goal0
6119 )
6120 ;
6121 Goal = true
6122 ).
6124 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6125 get_allocation_occurrence(FA,AO),
6126 ( chr_pp_flag(debugable,off), O < AO ->
6127 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6128 ( may_trigger(FA) ->
6129 Goal = (var(Susp) -> Goal0 ; true)
6130 ;
6131 Goal = Goal0
6132 )
6133 ;
6134 Goal = true
6135 ).
6137 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6139 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6140 %
6141 % Reorders guard goals with respect to partner constraint retrieval goals and
6142 % active constraint. Returns combined partner retrieval + guard goal.
6144 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6145 ( chr_pp_flag(guard_via_reschedule,on) ->
6146 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6147 list2conj(ScheduleSkeleton,GoalSkeleton)
6148 ;
6149 length(Retrievals,RL), length(LookupSkeleton,RL),
6150 length(GuardList,GL), length(GuardListSkeleton,GL),
6151 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6152 list2conj(GoalListSkeleton,GoalSkeleton)
6153 ).
6154 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6155 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6156 initialize_unit_dictionary(ActiveHead,Dict),
6157 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6158 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6159 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6160 dependency_reorder(Units,NUnits),
6161 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6162 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6163 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6165 wrap_in_functor(Functor,X,Term) :-
6166 Term =.. [Functor,X].
6168 wrappedunits2lists([],[],[],[]).
6169 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6170 Ss = [GoalCopy|TSs],
6171 ( WrappedGoal = lookup(Goal) ->
6172 Ls = [GoalCopy|TLs],
6173 Gs = TGs
6174 ; WrappedGoal = guard(Goal) ->
6175 Gs = [N-GoalCopy|TGs],
6176 Ls = TLs
6177 ),
6178 wrappedunits2lists(Units,TGs,TLs,TSs).
6180 guard_splitting(Rule,SplitGuardList) :-
6181 Rule = rule(H1,H2,Guard,_),
6182 append(H1,H2,Heads),
6183 conj2list(Guard,GuardList),
6184 term_variables(Heads,HeadVars),
6185 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6186 append(GuardPrefix,[RestGuard],SplitGuardList),
6187 term_variables(RestGuardList,GuardVars1),
6188 % variables that are declared to be ground don't need to be locked
6189 ground_vars(Heads,GroundVars),
6190 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6191 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6192 ( chr_pp_flag(guard_locks,on),
6193 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6194 once(pairup(Locks,Unlocks,LocksUnlocks))
6195 ;
6196 Locks = [],
6197 Unlocks = []
6198 ),
6199 list2conj(Locks,LockPhase),
6200 list2conj(Unlocks,UnlockPhase),
6201 list2conj(RestGuardList,RestGuard1),
6202 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6204 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6205 Rule = rule(_,_,_,Body),
6206 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6207 my_term_copy(Body,VarDict2,BodyCopy).
6210 split_off_simple_guard_new([],_,[],[]).
6211 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6212 ( simple_guard_new(G,VarDict) ->
6213 S = [G|Ss],
6214 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6215 ;
6216 S = [],
6217 C = [G|Gs]
6218 ).
6220 % simple guard: cheap and benign (does not bind variables)
6221 simple_guard_new(G,Vars) :-
6222 builtin_binds_b(G,BoundVars),
6223 \+ (( member(V,BoundVars),
6224 memberchk_eq(V,Vars)
6225 )).
6227 dependency_reorder(Units,NUnits) :-
6228 dependency_reorder(Units,[],NUnits).
6230 dependency_reorder([],Acc,Result) :-
6231 reverse(Acc,Result).
6233 dependency_reorder([Unit|Units],Acc,Result) :-
6234 Unit = unit(_GID,_Goal,Type,GIDs),
6235 ( Type == fixed ->
6236 NAcc = [Unit|Acc]
6237 ;
6238 dependency_insert(Acc,Unit,GIDs,NAcc)
6239 ),
6240 dependency_reorder(Units,NAcc,Result).
6242 dependency_insert([],Unit,_,[Unit]).
6243 dependency_insert([X|Xs],Unit,GIDs,L) :-
6244 X = unit(GID,_,_,_),
6245 ( memberchk(GID,GIDs) ->
6246 L = [Unit,X|Xs]
6247 ;
6248 L = [X | T],
6249 dependency_insert(Xs,Unit,GIDs,T)
6250 ).
6252 build_units(Retrievals,Guard,InitialDict,Units) :-
6253 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6254 build_guard_units(Guard,N,Dict,Tail).
6256 build_retrieval_units([],N,N,Dict,Dict,L,L).
6257 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6258 term_variables(U,Vs),
6259 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6260 L = [unit(N,U,fixed,GIDs)|L1],
6261 N1 is N + 1,
6262 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6264 initialize_unit_dictionary(Term,Dict) :-
6265 term_variables(Term,Vars),
6266 pair_all_with(Vars,0,Dict).
6268 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6269 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6270 ( lookup_eq(Dict,V,GID) ->
6271 ( (GID == This ; memberchk(GID,GIDs) ) ->
6272 GIDs1 = GIDs
6273 ;
6274 GIDs1 = [GID|GIDs]
6275 ),
6276 Dict1 = Dict
6277 ;
6278 Dict1 = [V - This|Dict],
6279 GIDs1 = GIDs
6280 ),
6281 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6283 build_guard_units(Guard,N,Dict,Units) :-
6284 ( Guard = [Goal] ->
6285 Units = [unit(N,Goal,fixed,[])]
6286 ; Guard = [Goal|Goals] ->
6287 term_variables(Goal,Vs),
6288 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6289 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6290 N1 is N + 1,
6291 build_guard_units(Goals,N1,NDict,RUnits)
6292 ).
6294 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6295 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6296 ( lookup_eq(Dict,V,GID) ->
6297 ( (GID == This ; memberchk(GID,GIDs) ) ->
6298 GIDs1 = GIDs
6299 ;
6300 GIDs1 = [GID|GIDs]
6301 ),
6302 Dict1 = [V - This|Dict]
6303 ;
6304 Dict1 = [V - This|Dict],
6305 GIDs1 = GIDs
6306 ),
6307 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6309 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6312 %% ____ _ ____ _ _
6313 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6314 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6315 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6316 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6317 %%
6318 %% _ _ _ ___ __
6319 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6320 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6321 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6322 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6323 %% |_|
6324 :- chr_constraint
6325 functional_dependency/4,
6326 get_functional_dependency/4.
6328 :- chr_option(mode,functional_dependency(+,+,?,?)).
6329 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6331 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6332 <=>
6333 RuleNb > 1, AO > O
6334 |
6335 functional_dependency(C,1,Pattern,Key).
6337 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6338 <=>
6339 RuleNb2 >= RuleNb1
6340 |
6341 QPattern = Pattern, QKey = Key.
6342 get_functional_dependency(_,_,_,_)
6343 <=>
6344 fail.
6346 functional_dependency_analysis(Rules) :-
6347 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6348 functional_dependency_analysis_main(Rules)
6349 ;
6350 true
6351 ).
6353 functional_dependency_analysis_main([]).
6354 functional_dependency_analysis_main([PRule|PRules]) :-
6355 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6356 functional_dependency(C,RuleNb,Pattern,Key)
6357 ;
6358 true
6359 ),
6360 functional_dependency_analysis_main(PRules).
6362 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6363 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6364 Rule = rule(H1,H2,Guard,_),
6365 ( H1 = [C1],
6366 H2 = [C2] ->
6367 true
6368 ; H1 = [C1,C2],
6369 H2 == [] ->
6370 true
6371 ),
6372 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6373 term_variables(C1,Vs),
6374 \+ (
6375 member(V1,Vs),
6376 lookup_eq(List,V1,V2),
6377 memberchk_eq(V2,Vs)
6378 ),
6379 select_pragma_unique_variables(Vs,List,Key1),
6380 copy_term_nat(C1-Key1,Pattern-Key),
6381 functor(C1,F,A).
6383 select_pragma_unique_variables([],_,[]).
6384 select_pragma_unique_variables([V|Vs],List,L) :-
6385 ( lookup_eq(List,V,_) ->
6386 L = T
6387 ;
6388 L = [V|T]
6389 ),
6390 select_pragma_unique_variables(Vs,List,T).
6392 % depends on functional dependency analysis
6393 % and shape of rule: C1 \ C2 <=> true.
6394 set_semantics_rules(Rules) :-
6395 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6396 set_semantics_rules_main(Rules)
6397 ;
6398 true
6399 ).
6401 set_semantics_rules_main([]).
6402 set_semantics_rules_main([R|Rs]) :-
6403 set_semantics_rule_main(R),
6404 set_semantics_rules_main(Rs).
6406 set_semantics_rule_main(PragmaRule) :-
6407 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6408 ( Rule = rule([C1],[C2],true,_),
6409 IDs = ids([ID1],[ID2]),
6410 \+ is_passive(RuleNb,ID1),
6411 functor(C1,F,A),
6412 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6413 copy_term_nat(Pattern-Key,C1-Key1),
6414 copy_term_nat(Pattern-Key,C2-Key2),
6415 Key1 == Key2 ->
6416 passive(RuleNb,ID2)
6417 ;
6418 true
6419 ).
6421 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6422 \+ any_passive_head(RuleNb),
6423 variable_replacement(C1-C2,C2-C1,List),
6424 copy_with_variable_replacement(G,OtherG,List),
6425 negate_b(G,NotG),
6426 once(entails_b(NotG,OtherG)).
6428 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6429 % where C1 and C2 are symmteric constraints
6430 symmetry_analysis(Rules) :-
6431 ( chr_pp_flag(check_unnecessary_active,off) ->
6432 true
6433 ;
6434 symmetry_analysis_main(Rules)
6435 ).
6437 symmetry_analysis_main([]).
6438 symmetry_analysis_main([R|Rs]) :-
6439 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6440 Rule = rule(H1,H2,_,_),
6441 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6442 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6443 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6444 ;
6445 true
6446 ),
6447 symmetry_analysis_main(Rs).
6449 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6450 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6451 ( \+ is_passive(RuleNb,ID),
6452 member2(PreHs,PreIDs,PreH-PreID),
6453 \+ is_passive(RuleNb,PreID),
6454 variable_replacement(PreH,H,List),
6455 copy_with_variable_replacement(Rule,Rule2,List),
6456 identical_guarded_rules(Rule,Rule2) ->
6457 passive(RuleNb,ID)
6458 ;
6459 true
6460 ),
6461 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6463 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6464 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6465 ( \+ is_passive(RuleNb,ID),
6466 member2(PreHs,PreIDs,PreH-PreID),
6467 \+ is_passive(RuleNb,PreID),
6468 variable_replacement(PreH,H,List),
6469 copy_with_variable_replacement(Rule,Rule2,List),
6470 identical_rules(Rule,Rule2) ->
6471 passive(RuleNb,ID)
6472 ;
6473 true
6474 ),
6475 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6477 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6479 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6480 %% ____ _ _ _ __ _ _ _
6481 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6482 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6483 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6484 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6485 %% |_|
6487 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6488 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6489 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6490 build_head(F,A,Id,HeadVars,ClauseHead),
6491 get_constraint_mode(F/A,Mode),
6492 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6495 guard_splitting(Rule,GuardList0),
6496 ( is_stored_in_guard(F/A, RuleNb) ->
6497 GuardList = [Hole1|GuardList0]
6498 ;
6499 GuardList = GuardList0
6500 ),
6501 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6503 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6505 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6507 ( is_stored_in_guard(F/A, RuleNb) ->
6508 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6509 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6510 GuardCopyList = [Hole1Copy|_],
6511 Hole1Copy = (Allocation, Attachment)
6512 ;
6513 true
6514 ),
6517 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6518 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6520 ( chr_pp_flag(debugable,on) ->
6521 Rule = rule(_,_,Guard,Body),
6522 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6523 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6524 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6525 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6526 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6527 ;
6528 Cut = ActualCut
6529 ),
6530 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6531 Clause = ( ClauseHead :-
6532 FirstMatching,
6533 RescheduledTest,
6534 Cut,
6535 SuspsDetachments,
6536 SuspDetachment,
6537 BodyCopy
6538 ),
6539 add_location(Clause,RuleNb,LocatedClause),
6540 L = [LocatedClause | T].
6542 add_location(Clause,RuleNb,NClause) :-
6543 ( chr_pp_flag(line_numbers,on) ->
6544 get_chr_source_file(File),
6545 get_line_number(RuleNb,LineNb),
6546 NClause = '$source_location'(File,LineNb):Clause
6547 ;
6548 NClause = Clause
6549 ).
6551 add_dummy_location(Clause,NClause) :-
6552 ( chr_pp_flag(line_numbers,on) ->
6553 get_chr_source_file(File),
6554 NClause = '$source_location'(File,1):Clause
6555 ;
6556 NClause = Clause
6557 ).
6558 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6559 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6560 %
6561 % Return goal matching newly introduced variables with variables in
6562 % previously looked-up heads.
6563 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6564 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6565 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6567 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6568 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6569 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6570 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6571 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6572 list2conj(GoalList,Goal).
6574 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6575 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6576 ( var(Arg) ->
6577 ( lookup_eq(VarDict,Arg,OtherVar) ->
6578 ( Mode = (+) ->
6579 ( memberchk_eq(Arg,GroundVars) ->
6580 GoalList = [Var = OtherVar | RestGoalList],
6581 GroundVars1 = GroundVars
6582 ;
6583 GoalList = [Var == OtherVar | RestGoalList],
6584 GroundVars1 = [Arg|GroundVars]
6585 )
6586 ;
6587 GoalList = [Var == OtherVar | RestGoalList],
6588 GroundVars1 = GroundVars
6589 ),
6590 VarDict1 = VarDict
6591 ;
6592 VarDict1 = [Arg-Var | VarDict],
6593 GoalList = RestGoalList,
6594 ( Mode = (+) ->
6595 GroundVars1 = [Arg|GroundVars]
6596 ;
6597 GroundVars1 = GroundVars
6598 )
6599 ),
6600 Pairs = Rest,
6601 RestModes = Modes
6602 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6603 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6604 GoalList = [Goal|RestGoalList],
6605 VarDict = VarDict1,
6606 GroundVars1 = GroundVars,
6607 Pairs = Rest,
6608 RestModes = Modes
6609 ; atomic(Arg) ->
6610 ( Mode = (+) ->
6611 GoalList = [ Var = Arg | RestGoalList]
6612 ;
6613 GoalList = [ Var == Arg | RestGoalList]
6614 ),
6615 VarDict = VarDict1,
6616 GroundVars1 = GroundVars,
6617 Pairs = Rest,
6618 RestModes = Modes
6619 ; Mode == (+), is_ground(GroundVars,Arg) ->
6620 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6621 GoalList = [ Var = ArgCopy | RestGoalList],
6622 VarDict = VarDict1,
6623 GroundVars1 = GroundVars,
6624 Pairs = Rest,
6625 RestModes = Modes
6626 ; Arg =.. [_|Args],
6627 functor(Arg,Fct,N),
6628 functor(Term,Fct,N),
6629 Term =.. [_|Vars],
6630 ( Mode = (+) ->
6631 GoalList = [ Var = Term | RestGoalList ]
6632 ;
6633 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6634 ),
6635 pairup(Args,Vars,NewPairs),
6636 append(NewPairs,Rest,Pairs),
6637 replicate(N,Mode,NewModes),
6638 append(NewModes,Modes,RestModes),
6639 VarDict1 = VarDict,
6640 GroundVars1 = GroundVars
6641 ),
6642 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6644 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6645 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6646 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6647 add_heads_types([],VarTypes,VarTypes).
6648 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6649 add_head_types(Head,VarTypes,VarTypes1),
6650 add_heads_types(Heads,VarTypes1,NVarTypes).
6652 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6653 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6654 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6655 add_head_types(Head,VarTypes,NVarTypes) :-
6656 functor(Head,F,A),
6657 get_constraint_type_det(F/A,ArgTypes),
6658 Head =.. [_|Args],
6659 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6661 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6662 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6663 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6664 add_args_types([],[],VarTypes,VarTypes).
6665 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6666 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6667 add_args_types(Args,Types,VarTypes1,NVarTypes).
6669 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6670 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6671 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6672 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6673 ( var(Term) ->
6674 ( lookup_eq(VarTypes,Term,_) ->
6675 NVarTypes = VarTypes
6676 ;
6677 NVarTypes = [Term-Type|VarTypes]
6678 )
6679 ; ground(Term) ->
6680 NVarTypes = VarTypes
6681 ; % TODO improve approximation!
6682 term_variables(Term,Vars),
6683 length(Vars,VarNb),
6684 replicate(VarNb,any,Types),
6685 add_args_types(Vars,Types,VarTypes,NVarTypes)
6686 ).
6690 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6691 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6692 %
6693 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6694 add_heads_ground_variables([],GroundVars,GroundVars).
6695 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6696 add_head_ground_variables(Head,GroundVars,GroundVars1),
6697 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6699 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6700 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6701 %
6702 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6703 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6704 functor(Head,F,A),
6705 get_constraint_mode(F/A,ArgModes),
6706 Head =.. [_|Args],
6707 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6710 add_arg_ground_variables([],[],GroundVars,GroundVars).
6711 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6712 ( Mode == (+) ->
6713 term_variables(Arg,Vars),
6714 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6715 ;
6716 GroundVars = GroundVars1
6717 ),
6718 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6720 add_var_ground_variables([],GroundVars,GroundVars).
6721 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6722 ( memberchk_eq(Var,GroundVars) ->
6723 GroundVars1 = GroundVars
6724 ;
6725 GroundVars1 = [Var|GroundVars]
6726 ),
6727 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6728 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6729 %% is_ground(+GroundVars,+Term) is semidet.
6730 %
6731 % Determine whether =Term= is always ground.
6732 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6733 is_ground(GroundVars,Term) :-
6734 ( ground(Term) ->
6735 true
6736 ; compound(Term) ->
6737 Term =.. [_|Args],
6738 maplist(is_ground(GroundVars),Args)
6739 ;
6740 memberchk_eq(Term,GroundVars)
6741 ).
6743 %% check_ground(+GroundVars,+Term,-Goal) is det.
6744 %
6745 % Return runtime check to see whether =Term= is ground.
6746 check_ground(GroundVars,Term,Goal) :-
6747 term_variables(Term,Variables),
6748 check_ground_variables(Variables,GroundVars,Goal).
6750 check_ground_variables([],_,true).
6751 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6752 ( memberchk_eq(Var,GroundVars) ->
6753 check_ground_variables(Vars,GroundVars,Goal)
6754 ;
6755 Goal = (ground(Var), RGoal),
6756 check_ground_variables(Vars,GroundVars,RGoal)
6757 ).
6759 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6760 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6762 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6763 ( Heads = [_|_] ->
6764 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6765 ;
6766 GoalList = [],
6767 Susps = [],
6768 VarDict = NVarDict,
6769 GroundVars = NGroundVars
6770 ).
6772 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6773 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6774 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6775 functor(H,F,A),
6776 head_info(H,A,Vars,_,_,Pairs),
6777 get_store_type(F/A,StoreType),
6778 ( StoreType == default ->
6779 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6780 delay_phase_end(validate_store_type_assumptions,
6781 ( static_suspension_term(F/A,Suspension),
6782 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6783 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6784 )
6785 ),
6786 % create_get_mutable_ref(active,State,GetMutable),
6787 get_constraint_mode(F/A,Mode),
6788 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6789 NPairs = Pairs,
6790 sbag_member_call(Susp,VarSusps,Sbag),
6791 ExistentialLookup = (
6792 ViaGoal,
6793 Sbag,
6794 Susp = Suspension, % not inlined
6795 GetState
6796 )
6797 ;
6798 delay_phase_end(validate_store_type_assumptions,
6799 ( static_suspension_term(F/A,Suspension),
6800 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6801 )
6802 ),
6803 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6804 get_constraint_mode(F/A,Mode),
6805 filter_mode(NPairs,Pairs,Mode,NMode),
6806 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6807 ),
6808 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6809 append(NPairs,VarDict1,DA_), % order important here
6810 translate(GroundVars1,DA_,GroundVarsA),
6811 translate(GroundVars1,VarDict1,GroundVarsB),
6812 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6813 Goal =
6814 (
6815 ExistentialLookup,
6816 DiffSuspGoals,
6817 MatchingGoal2
6818 ),
6819 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6821 inline_matching_goal(A==B,true,GVA,GVB) :-
6822 memberchk_eq(A,GVA),
6823 memberchk_eq(B,GVB),
6824 A=B, !.
6826 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6827 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6828 inline_matching_goal(A,A2,GVA,GVB),
6829 inline_matching_goal(B,B2,GVA,GVB).
6830 inline_matching_goal(X,X,_,_).
6833 filter_mode([],_,_,[]).
6834 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6835 ( Var == V ->
6836 Modes = [M|MT],
6837 filter_mode(Rest,R,Ms,MT)
6838 ;
6839 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6840 ).
6842 check_unique_keys([],_).
6843 check_unique_keys([V|Vs],Dict) :-
6844 lookup_eq(Dict,V,_),
6845 check_unique_keys(Vs,Dict).
6847 % Generates tests to ensure the found constraint differs from previously found constraints
6848 % TODO: detect more cases where constraints need be different
6849 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6850 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6851 list2conj(DiffSuspGoalList,DiffSuspGoals).
6853 different_from_other_susps_(_,[],_,_,[]) :- !.
6854 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6855 ( functor(Head,F,A), functor(PreHead,F,A),
6856 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6857 \+ \+ PreHeadCopy = HeadCopy ->
6859 List = [Susp \== PreSusp | Tail]
6860 ;
6861 List = Tail
6862 ),
6863 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6865 % passive_head_via(in,in,in,in,out,out,out) :-
6866 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6867 functor(Head,F,A),
6868 get_constraint_index(F/A,Pos),
6869 common_variables(Head,PrevHeads,CommonVars),
6870 global_list_store_name(F/A,Name),
6871 GlobalGoal = nb_getval(Name,AllSusps),
6872 get_constraint_mode(F/A,ArgModes),
6873 ( Vars == [] ->
6874 Goal = GlobalGoal
6875 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6876 translate([CommonVar],VarDict,[Var]),
6877 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6878 Goal = AttrGoal
6879 ;
6880 translate(CommonVars,VarDict,Vars),
6881 add_heads_types(PrevHeads,[],TypeDict),
6882 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6883 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6884 Goal =
6885 ( ViaGoal ->
6886 AttrGoal
6887 ;
6888 GlobalGoal
6889 )
6890 ).
6892 common_variables(T,Ts,Vs) :-
6893 term_variables(T,V1),
6894 term_variables(Ts,V2),
6895 intersect_eq(V1,V2,Vs).
6897 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6898 get_target_module(Mod),
6899 ( Vars = [A] ->
6900 lookup_eq(TypeDict,A,Type),
6901 ( atomic_type(Type) ->
6902 ViaGoal = var(A),
6903 A = V
6904 ;
6905 ViaGoal = 'chr newvia_1'(A,V)
6906 )
6907 ; Vars = [A,B] ->
6908 ViaGoal = 'chr newvia_2'(A,B,V)
6909 ;
6910 ViaGoal = 'chr newvia'(Vars,V)
6911 ),
6912 AttrGoal =
6913 ( get_attr(V,Mod,TSusps),
6914 TSuspsEqSusps % TSusps = Susps
6915 ),
6916 get_max_constraint_index(N),
6917 ( N == 1 ->
6918 TSuspsEqSusps = true, % TSusps = Susps
6919 AllSusps = TSusps
6920 ;
6921 get_constraint_index(FA,Pos),
6922 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6923 ).
6924 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6925 get_target_module(Mod),
6926 AttrGoal =
6927 ( get_attr(Var,Mod,TSusps),
6928 TSuspsEqSusps % TSusps = Susps
6929 ),
6930 get_max_constraint_index(N),
6931 ( N == 1 ->
6932 TSuspsEqSusps = true, % TSusps = Susps
6933 AllSusps = TSusps
6934 ;
6935 get_constraint_index(FA,Pos),
6936 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6937 ).
6939 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6940 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6941 list2conj(GuardCopyList,GuardCopy).
6943 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6944 Rule = rule(H,_,Guard,Body),
6945 conj2list(Guard,GuardList),
6946 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6947 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6949 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6950 term_variables(RestGuardList,GuardVars),
6951 term_variables(RestGuardListCopyCore,GuardCopyVars),
6952 % variables that are declared to be ground don't need to be locked
6953 ground_vars(H,GroundVars),
6954 list_difference_eq(GuardVars,GroundVars,GuardVars_),
6955 ( chr_pp_flag(guard_locks,on),
6956 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6957 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
6958 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
6959 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
6960 ),
6961 LocksUnlocks) ->
6962 once(pairup(Locks,Unlocks,LocksUnlocks))
6963 ;
6964 Locks = [],
6965 Unlocks = []
6966 ),
6967 list2conj(Locks,LockPhase),
6968 list2conj(Unlocks,UnlockPhase),
6969 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
6970 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
6971 my_term_copy(Body,VarDict2,BodyCopy).
6974 split_off_simple_guard([],_,[],[]).
6975 split_off_simple_guard([G|Gs],VarDict,S,C) :-
6976 ( simple_guard(G,VarDict) ->
6977 S = [G|Ss],
6978 split_off_simple_guard(Gs,VarDict,Ss,C)
6979 ;
6980 S = [],
6981 C = [G|Gs]
6982 ).
6984 % simple guard: cheap and benign (does not bind variables)
6985 simple_guard(G,VarDict) :-
6986 binds_b(G,Vars),
6987 \+ (( member(V,Vars),
6988 lookup_eq(VarDict,V,_)
6989 )).
6991 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
6992 functor(Head,F,A),
6993 C = F/A,
6994 ( is_stored(C) ->
6995 (
6996 (
6997 Id == [0], chr_pp_flag(store_in_guards, off)
6998 ;
6999 ( get_allocation_occurrence(C,AO),
7000 get_max_occurrence(C,MO),
7001 MO < AO )
7002 ),
7003 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7004 SuspDetachment = true
7005 ;
7006 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7007 ( chr_pp_flag(late_allocation,on) ->
7008 SuspDetachment =
7009 ( var(Susp) ->
7010 true
7011 ;
7012 UnCondSuspDetachment
7013 )
7014 ;
7015 SuspDetachment = UnCondSuspDetachment
7016 )
7017 )
7018 ;
7019 SuspDetachment = true
7020 ).
7022 partner_constraint_detachments([],[],_,true).
7023 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7024 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7025 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7027 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7028 functor(Head,F,A),
7029 C = F/A,
7030 ( is_stored(C) ->
7031 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7032 ( chr_pp_flag(debugable,on) ->
7033 DebugEvent = 'chr debug_event'(remove(Susp))
7034 ;
7035 DebugEvent = true
7036 ),
7037 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7038 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7039 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7040 detach_constraint_atom(C,Vars,Susp,Detach)
7041 ;
7042 Detach = true
7043 )
7044 ;
7045 SuspDetachment = true
7046 ).
7048 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7050 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7051 %% ____ _ _ _ _
7052 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7053 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7054 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7055 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7056 %% |_| |___/
7058 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7059 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7060 Rule = rule(_Heads,Heads2,Guard,Body),
7062 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7063 get_constraint_mode(F/A,Mode),
7064 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7066 build_head(F,A,Id,HeadVars,ClauseHead),
7068 append(RestHeads,Heads2,Heads),
7069 append(OtherIDs,Heads2IDs,IDs),
7070 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7072 guard_splitting(Rule,GuardList0),
7073 ( is_stored_in_guard(F/A, RuleNb) ->
7074 GuardList = [Hole1|GuardList0]
7075 ;
7076 GuardList = GuardList0
7077 ),
7078 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7080 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7081 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7083 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7085 ( is_stored_in_guard(F/A, RuleNb) ->
7086 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7087 GuardCopyList = [Hole1Copy|_],
7088 Hole1Copy = Attachment
7089 ;
7090 true
7091 ),
7093 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7094 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7095 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7097 ( chr_pp_flag(debugable,on) ->
7098 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7099 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7100 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7101 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7102 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7103 instrument_goal((!),DebugTry,DebugApply,Cut)
7104 ;
7105 Cut = (!)
7106 ),
7108 Clause = ( ClauseHead :-
7109 FirstMatching,
7110 RescheduledTest,
7111 Cut,
7112 SuspsDetachments,
7113 SuspDetachment,
7114 BodyCopy
7115 ),
7116 add_location(Clause,RuleNb,LocatedClause),
7117 L = [LocatedClause | T].
7119 split_by_ids([],[],_,[],[]).
7120 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7121 ( memberchk_eq(I,I1s) ->
7122 S1s = [S | R1s],
7123 S2s = R2s
7124 ;
7125 S1s = R1s,
7126 S2s = [S | R2s]
7127 ),
7128 split_by_ids(Is,Ss,I1s,R1s,R2s).
7130 split_by_ids([],[],_,[],[],[],[]).
7131 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7132 ( memberchk_eq(I,I1s) ->
7133 S1s = [S | R1s],
7134 SI1s = [I|RSI1s],
7135 S2s = R2s,
7136 SI2s = RSI2s
7137 ;
7138 S1s = R1s,
7139 SI1s = RSI1s,
7140 S2s = [S | R2s],
7141 SI2s = [I|RSI2s]
7142 ),
7143 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7144 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7147 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7148 %% ____ _ _ _ ____
7149 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7150 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7151 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7152 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7153 %% |_| |___/
7155 %% Genereate prelude + worker predicate
7156 %% prelude calls worker
7157 %% worker iterates over one type of removed constraints
7158 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7159 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7160 Rule = rule(Heads1,_,Guard,Body),
7161 append(Heads1,RestHeads2,Heads),
7162 append(IDs1,RestIDs,IDs),
7163 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7164 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7165 extend_id(Id,Id1),
7166 ( memberchk_eq(NID,IDs2) ->
7167 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7168 ;
7169 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7170 ),
7171 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
7172 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7174 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
7175 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7176 Heads = [Head|RHeads],
7177 inc_id(Id,Id1),
7178 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
7179 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
7180 ( memberchk_eq(ID,IDs2) ->
7181 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7182 ;
7183 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7184 ).
7186 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7187 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7188 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7189 build_head(F,A,Id1,VarsSusp,ClauseHead),
7190 get_constraint_mode(F/A,Mode),
7191 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7193 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7195 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7197 extend_id(Id1,DelegateId),
7198 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7199 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7200 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
7202 PreludeClause =
7203 ( ClauseHead :-
7204 FirstMatching,
7205 ModConstraintsGoal,
7206 !,
7207 ConstraintAllocationGoal,
7208 Delegate
7209 ),
7210 add_dummy_location(PreludeClause,LocatedPreludeClause),
7211 L = [LocatedPreludeClause|T].
7213 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7214 Term =.. [_|Args],
7215 delegate_variables(Term,Terms,VarDict,Args,Vars).
7217 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7218 term_variables(PrevTerms,PrevVars),
7219 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7221 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7222 term_variables(Term,V1),
7223 term_variables(Terms,V2),
7224 intersect_eq(V1,V2,V3),
7225 list_difference_eq(V3,PrevVars,V4),
7226 translate(V4,VarDict,Vars).
7229 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7230 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7231 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7232 Rule = rule(_,_,Guard,Body),
7233 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7235 gen_var(OtherSusp),
7236 gen_var(OtherSusps),
7238 functor(CurrentHead,OtherF,OtherA),
7239 gen_vars(OtherA,OtherVars),
7240 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7241 get_constraint_mode(OtherF/OtherA,Mode),
7242 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7244 delay_phase_end(validate_store_type_assumptions,
7245 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7246 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7247 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7248 )
7249 ),
7250 % create_get_mutable_ref(active,State,GetMutable),
7251 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7252 CurrentSuspTest = (
7253 OtherSusp = OtherSuspension,
7254 GetState,
7255 DiffSuspGoals,
7256 FirstMatching
7257 ),
7259 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7260 build_head(F,A,Id,ClauseVars,ClauseHead),
7262 guard_splitting(Rule,GuardList0),
7263 ( is_stored_in_guard(F/A, RuleNb) ->
7264 GuardList = [Hole1|GuardList0]
7265 ;
7266 GuardList = GuardList0
7267 ),
7268 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7270 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7271 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7272 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7274 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7276 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7277 build_head(F,A,Id,RecursiveVars,RecursiveCall),
7278 RecursiveVars2 = [[]|PreVarsAndSusps],
7279 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
7281 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7282 ( is_stored_in_guard(F/A, RuleNb) ->
7283 GuardCopyList = [GuardAttachment|_] % once( ) ??
7284 ;
7285 true
7286 ),
7288 ( is_observed(F/A,O) ->
7289 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7290 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7291 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7292 ;
7293 Attachment = true,
7294 ConditionalRecursiveCall = RecursiveCall,
7295 ConditionalRecursiveCall2 = RecursiveCall2
7296 ),
7298 ( chr_pp_flag(debugable,on) ->
7299 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7300 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7301 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7302 ;
7303 DebugTry = true,
7304 DebugApply = true
7305 ),
7307 ( is_stored_in_guard(F/A, RuleNb) ->
7308 GuardAttachment = Attachment,
7309 BodyAttachment = true
7310 ;
7311 GuardAttachment = true,
7312 BodyAttachment = Attachment % will be true if not observed at all
7313 ),
7315 ( member(unique(ID1,UniqueKeys), Pragmas),
7316 check_unique_keys(UniqueKeys,VarDict) ->
7317 Clause =
7318 ( ClauseHead :-
7319 ( CurrentSuspTest ->
7320 ( RescheduledTest,
7321 DebugTry ->
7322 DebugApply,
7323 Susps1Detachments,
7324 BodyAttachment,
7325 BodyCopy,
7326 ConditionalRecursiveCall2
7327 ;
7328 RecursiveCall2
7329 )
7330 ;
7331 RecursiveCall
7332 )
7333 )
7334 ;
7335 Clause =
7336 ( ClauseHead :-
7337 ( CurrentSuspTest,
7338 RescheduledTest,
7339 DebugTry ->
7340 DebugApply,
7341 Susps1Detachments,
7342 BodyAttachment,
7343 BodyCopy,
7344 ConditionalRecursiveCall
7345 ;
7346 RecursiveCall
7347 )
7348 )
7349 ),
7350 add_location(Clause,RuleNb,LocatedClause),
7351 L = [LocatedClause | T].
7353 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7354 ( may_trigger(FA) ->
7355 does_use_field(FA,generation),
7356 delay_phase_end(validate_store_type_assumptions,
7357 ( static_suspension_term(FA,Suspension),
7358 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7359 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7360 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7361 )
7362 )
7363 ;
7364 delay_phase_end(validate_store_type_assumptions,
7365 ( static_suspension_term(FA,Suspension),
7366 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7367 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7368 )
7369 ),
7370 GetGeneration = true
7371 ),
7372 ConditionalCall =
7373 ( Susp = Suspension,
7374 GetState,
7375 GetGeneration ->
7376 UpdateState,
7377 Call
7378 ;
7379 true
7380 ).
7382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7386 %% ____ _ _
7387 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7388 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7389 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7390 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7391 %% |_| |___/
7393 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7394 ( RestHeads == [] ->
7395 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7396 ;
7397 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7398 ).
7399 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7400 %% Single headed propagation
7401 %% everything in a single clause
7402 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7403 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7404 build_head(F,A,Id,VarsSusp,ClauseHead),
7406 inc_id(Id,NextId),
7407 build_head(F,A,NextId,VarsSusp,NextHead),
7409 get_constraint_mode(F/A,Mode),
7410 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7411 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7413 % - recursive call -
7414 RecursiveCall = NextHead,
7416 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7417 ActualCut = true
7418 ;
7419 ActualCut = !
7420 ),
7422 Rule = rule(_,_,Guard,Body),
7423 ( chr_pp_flag(debugable,on) ->
7424 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7425 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7426 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7427 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7428 ;
7429 Cut = ActualCut
7430 ),
7431 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7432 use_auxiliary_predicate(novel_production),
7433 use_auxiliary_predicate(extend_history),
7434 does_use_history(F/A,O),
7435 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7437 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7438 ( HistoryIDs == [] ->
7439 empty_named_history_novel_production(HistoryName,NovelProduction),
7440 empty_named_history_extend_history(HistoryName,ExtendHistory)
7441 ;
7442 Tuple = HistoryName
7443 )
7444 ;
7445 Tuple = RuleNb
7446 ),
7448 ( var(NovelProduction) ->
7449 NovelProduction = '$novel_production'(Susp,Tuple),
7450 ExtendHistory = '$extend_history'(Susp,Tuple)
7451 ;
7452 true
7453 ),
7455 ( is_observed(F/A,O) ->
7456 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7457 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7458 ;
7459 Attachment = true,
7460 ConditionalRecursiveCall = RecursiveCall
7461 )
7462 ;
7463 Allocation = true,
7464 NovelProduction = true,
7465 ExtendHistory = true,
7467 ( is_observed(F/A,O) ->
7468 get_allocation_occurrence(F/A,AllocO),
7469 ( O == AllocO ->
7470 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7471 Generation = 0
7472 ; % more room for improvement?
7473 Attachment = (Attachment1, Attachment2),
7474 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7475 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7476 ),
7477 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7478 ;
7479 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7480 ConditionalRecursiveCall = RecursiveCall
7481 )
7482 ),
7484 ( is_stored_in_guard(F/A, RuleNb) ->
7485 GuardAttachment = Attachment,
7486 BodyAttachment = true
7487 ;
7488 GuardAttachment = true,
7489 BodyAttachment = Attachment % will be true if not observed at all
7490 ),
7492 Clause = (
7493 ClauseHead :-
7494 HeadMatching,
7495 Allocation,
7496 NovelProduction,
7497 GuardAttachment,
7498 GuardCopy,
7499 Cut,
7500 ExtendHistory,
7501 BodyAttachment,
7502 BodyCopy,
7503 ConditionalRecursiveCall
7504 ),
7505 add_location(Clause,RuleNb,LocatedClause),
7506 ProgramList = [LocatedClause | ProgramTail].
7508 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7509 %% multi headed propagation
7510 %% prelude + predicates to accumulate the necessary combinations of suspended
7511 %% constraints + predicate to execute the body
7512 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7513 RestHeads = [First|Rest],
7514 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7515 extend_id(Id,ExtendedId),
7516 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7518 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7519 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7520 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7521 build_head(F,A,Id,VarsSusp,PreludeHead),
7522 get_constraint_mode(F/A,Mode),
7523 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7524 Rule = rule(_,_,Guard,Body),
7525 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7527 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7529 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7531 extend_id(Id,NestedId),
7532 append([Susps|VarsSusp],ExtraVars,NestedVars),
7533 build_head(F,A,NestedId,NestedVars,NestedHead),
7534 NestedCall = NestedHead,
7536 Prelude = (
7537 PreludeHead :-
7538 FirstMatching,
7539 FirstSuspGoal,
7540 !,
7541 CondAllocation,
7542 NestedCall
7543 ),
7544 add_dummy_location(Prelude,LocatedPrelude),
7545 L = [LocatedPrelude|T].
7547 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7548 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7549 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
7550 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7552 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7553 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
7554 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
7555 inc_id(Id,IncId),
7556 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7558 %check_fd_lookup_condition(_,_,_,_) :- fail.
7559 check_fd_lookup_condition(F,A,_,_) :-
7560 get_store_type(F/A,global_singleton), !.
7561 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7562 \+ may_trigger(F/A),
7563 get_functional_dependency(F/A,1,P,K),
7564 copy_term(P-K,CurrentHead-Key),
7565 term_variables(PreHeads,PreVars),
7566 intersect_eq(Key,PreVars,Key),!.
7568 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7569 Rule = rule(_,H2,Guard,Body),
7570 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7571 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7572 init(AllSusps,RestSusps),
7573 last(AllSusps,Susp),
7574 gen_var(OtherSusp),
7575 gen_var(OtherSusps),
7576 functor(CurrentHead,OtherF,OtherA),
7577 gen_vars(OtherA,OtherVars),
7578 delay_phase_end(validate_store_type_assumptions,
7579 ( static_suspension_term(OtherF/OtherA,Suspension),
7580 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7581 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7582 )
7583 ),
7584 % create_get_mutable_ref(active,State,GetMutable),
7585 CurrentSuspTest = (
7586 OtherSusp = Suspension,
7587 GetState
7588 ),
7589 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7590 build_head(F,A,Id,ClauseVars,ClauseHead),
7591 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7592 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
7593 RecursiveVars = PreVarsAndSusps1
7594 ;
7595 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7596 PrevId = Id
7597 ),
7598 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7599 RecursiveCall = RecursiveHead,
7600 CurrentHead =.. [_|OtherArgs],
7601 pairup(OtherArgs,OtherVars,OtherPairs),
7602 get_constraint_mode(OtherF/OtherA,Mode),
7603 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7605 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7606 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7607 get_occurrence(F/A,O,_,ID),
7609 ( is_observed(F/A,O) ->
7610 init(FirstVarsSusp,FirstVars),
7611 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7612 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7613 ;
7614 Attachment = true,
7615 ConditionalRecursiveCall = RecursiveCall
7616 ),
7617 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7618 NovelProduction = true,
7619 ExtendHistory = true
7620 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7621 NovelProduction = true,
7622 ExtendHistory = true
7623 ;
7624 get_occurrence(F/A,O,_,ID),
7625 use_auxiliary_predicate(novel_production),
7626 use_auxiliary_predicate(extend_history),
7627 does_use_history(F/A,O),
7628 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7629 ( HistoryIDs == [] ->
7630 empty_named_history_novel_production(HistoryName,NovelProduction),
7631 empty_named_history_extend_history(HistoryName,ExtendHistory)
7632 ;
7633 reverse([OtherSusp|RestSusps],NamedSusps),
7634 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7635 HistorySusps = [HistorySusp|_],
7637 ( length(HistoryIDs, 1) ->
7638 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7639 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7640 ;
7641 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7642 Tuple =.. [t,HistoryName|HistorySusps]
7643 )
7644 )
7645 ;
7646 HistorySusp = Susp,
7647 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7648 sort([ID|RestIDs],HistoryIDs),
7649 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7650 Tuple =.. [t,RuleNb|HistorySusps]
7651 ),
7653 ( var(NovelProduction) ->
7654 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7655 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7656 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7657 ;
7658 true
7659 )
7660 ),
7663 ( chr_pp_flag(debugable,on) ->
7664 Rule = rule(_,_,Guard,Body),
7665 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7666 get_occurrence(F/A,O,_,ID),
7667 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7668 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7669 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7670 ;
7671 DebugTry = true,
7672 DebugApply = true
7673 ),
7675 ( is_stored_in_guard(F/A, RuleNb) ->
7676 GuardAttachment = Attachment,
7677 BodyAttachment = true
7678 ;
7679 GuardAttachment = true,
7680 BodyAttachment = Attachment % will be true if not observed at all
7681 ),
7683 Clause = (
7684 ClauseHead :-
7685 ( CurrentSuspTest,
7686 DiffSuspGoals,
7687 Matching,
7688 NovelProduction,
7689 GuardAttachment,
7690 GuardCopy,
7691 DebugTry ->
7692 DebugApply,
7693 ExtendHistory,
7694 BodyAttachment,
7695 BodyCopy,
7696 ConditionalRecursiveCall
7697 ; RecursiveCall
7698 )
7699 ),
7700 add_location(Clause,RuleNb,LocatedClause),
7701 L = [LocatedClause|T].
7703 novel_production_calls([],[],[],_,_,true).
7704 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7705 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7706 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7707 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7709 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7710 reverse(ReversedRestSusps,RestSusps),
7711 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7713 named_history_susps([],_,_,[]).
7714 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7715 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7716 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7720 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7721 !,
7722 functor(Head,F,A),
7723 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7724 get_constraint_mode(F/A,Mode),
7725 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7726 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7727 append(VarsSusp,ExtraVars,HeadVars).
7728 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7729 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7730 functor(Head,F,A),
7731 gen_var(Susps),
7732 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7733 get_constraint_mode(F/A,Mode),
7734 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7735 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7736 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7738 % returns
7739 % VarDict for the copies of variables in the original heads
7740 % VarsSuspsList list of lists of arguments for the successive heads
7741 % FirstVarsSusp top level arguments
7742 % SuspList list of all suspensions
7743 % Iterators list of all iterators
7744 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7745 !,
7746 functor(Head,F,A),
7747 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7748 get_constraint_mode(F/A,Mode),
7749 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7750 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7751 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7752 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7753 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7754 functor(Head,F,A),
7755 gen_var(Susps),
7756 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7757 get_constraint_mode(F/A,Mode),
7758 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7759 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7760 append(HeadVars,[Susp,Susps],Vars).
7762 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7763 !,
7764 functor(Head,F,A),
7765 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7766 get_constraint_mode(F/A,Mode),
7767 head_arg_matches(Pairs,Mode,[],_,VarDict),
7768 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7769 append(VarsSusp,ExtraVars,HeadVars).
7770 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7771 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7772 functor(Head,F,A),
7773 gen_var(Susps),
7774 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7775 get_constraint_mode(F/A,Mode),
7776 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7777 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7778 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7780 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7782 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7783 %% ____ _ _ _ _
7784 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7785 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7786 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7787 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7788 %%
7789 %% ____ _ _ _
7790 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7791 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7792 %% | _ < __/ |_| | | | __/\ V / (_| | |
7793 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7794 %%
7795 %% ____ _ _
7796 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7797 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7798 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7799 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7800 %% |___/
7802 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7803 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7804 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7805 ;
7806 NRestHeads = RestHeads,
7807 NRestIDs = RestIDs
7808 ).
7810 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7811 term_variables(Head,Vars),
7812 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7813 copy_term_nat(InitialData,InitialDataCopy),
7814 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7815 InitialDataCopy = InitialData,
7816 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7817 reverse(RNRestHeads,NRestHeads),
7818 reverse(RNRestIDs,NRestIDs).
7820 final_data(Entry) :-
7821 Entry = entry(_,_,_,_,[],_).
7823 expand_data(Entry,NEntry,Cost) :-
7824 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7825 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7826 term_variables([Head1|Vars],Vars1),
7827 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7828 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7830 % Assigns score to head based on known variables and heads to lookup
7831 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7832 functor(Head,F,A),
7833 get_store_type(F/A,StoreType),
7834 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7836 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7837 term_variables(Head,HeadVars),
7838 term_variables(RestHeads,RestVars),
7839 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7840 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7841 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7842 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7843 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7844 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7845 term_variables(Head,HeadVars),
7846 term_variables(RestHeads,RestVars),
7847 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7848 Score is Score_ * 2.
7849 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7850 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7851 Score = 1. % guaranteed O(1)
7853 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7854 find_with_var_identity(
7855 S,
7856 t(Head,KnownVars,RestHeads),
7857 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7858 Scores
7859 ),
7860 min_list(Scores,Score).
7861 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7862 Score = 10.
7863 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7864 Score = 10.
7866 order_score_indexes([],_,_,Score,NScore) :-
7867 Score > 0, NScore = 100.
7868 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7869 multi_hash_key_args(I,Head,Args),
7870 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7871 Score1 is Score + 1
7872 ;
7873 Score1 = Score
7874 ),
7875 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7877 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7878 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7879 ( K-R-O == 0-0-0 ->
7880 Score = 0
7881 ; K > 0 ->
7882 Score is max(10 - K,0)
7883 ; R > 0 ->
7884 Score is max(10 - R,1) * 10
7885 ;
7886 Score is max(10-O,1) * 100
7887 ).
7888 order_score_count_vars([],_,_,0-0-0).
7889 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7890 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7891 ( memberchk_eq(V,KnownVars) ->
7892 NK is K + 1,
7893 NR = R, NO = O
7894 ; memberchk_eq(V,RestVars) ->
7895 NR is R + 1,
7896 NK = K, NO = O
7897 ;
7898 NO is O + 1,
7899 NK = K, NR = R
7900 ).
7902 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7903 %% ___ _ _ _
7904 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
7905 %% | || '_ \| | | '_ \| | '_ \ / _` |
7906 %% | || | | | | | | | | | | | | (_| |
7907 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7908 %% |___/
7910 %% SWI begin
7911 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7912 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7913 %% SWI end
7915 %% SICStus begin
7916 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7917 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7918 %% SICStus end
7920 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7922 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7923 %% _ _ _ _ _ _ _
7924 %% | | | | |_(_) (_) |_ _ _
7925 %% | | | | __| | | | __| | | |
7926 %% | |_| | |_| | | | |_| |_| |
7927 %% \___/ \__|_|_|_|\__|\__, |
7928 %% |___/
7930 % Create a fresh variable.
7931 gen_var(_).
7933 % Create =N= fresh variables.
7934 gen_vars(N,Xs) :-
7935 length(Xs,N).
7937 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7938 vars_susp(A,Vars,Susp,VarsSusp),
7939 Head =.. [_|Args],
7940 pairup(Args,Vars,HeadPairs).
7942 inc_id([N|Ns],[O|Ns]) :-
7943 O is N + 1.
7944 dec_id([N|Ns],[M|Ns]) :-
7945 M is N - 1.
7947 extend_id(Id,[0|Id]).
7949 next_id([_,N|Ns],[O|Ns]) :-
7950 O is N + 1.
7952 % return clause Head
7953 % for F/A constraint symbol, predicate identifier Id and arguments Head
7954 build_head(F,A,Id,Args,Head) :-
7955 buildName(F,A,Id,Name),
7956 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
7957 ( may_trigger(F/A) ;
7958 get_allocation_occurrence(F/A,AO),
7959 get_max_occurrence(F/A,MO),
7960 MO >= AO ) ) ->
7961 Head =.. [Name|Args]
7962 ;
7963 init(Args,ArgsWOSusp), % XXX not entirely correct!
7964 Head =.. [Name|ArgsWOSusp]
7965 ).
7967 % return predicate name Result
7968 % for Fct/Aty constraint symbol and predicate identifier List
7969 buildName(Fct,Aty,List,Result) :-
7970 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
7971 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
7972 MO >= AO ) ; List \= [0])) ) ) ->
7973 atom_concat(Fct, '___' ,FctSlash),
7974 atomic_concat(FctSlash,Aty,FctSlashAty),
7975 buildName_(List,FctSlashAty,Result)
7976 ;
7977 Result = Fct
7978 ).
7980 buildName_([],Name,Name).
7981 buildName_([N|Ns],Name,Result) :-
7982 buildName_(Ns,Name,Name1),
7983 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
7984 atomic_concat(NameDash,N,Result).
7986 vars_susp(A,Vars,Susp,VarsSusp) :-
7987 length(Vars,A),
7988 append(Vars,[Susp],VarsSusp).
7990 or_pattern(Pos,Pat) :-
7991 Pow is Pos - 1,
7992 Pat is 1 << Pow. % was 2 ** X
7994 and_pattern(Pos,Pat) :-
7995 X is Pos - 1,
7996 Y is 1 << X, % was 2 ** X
7997 Pat is (-1)*(Y + 1).
7999 make_name(Prefix,F/A,Name) :-
8000 atom_concat_list([Prefix,F,'___',A],Name).
8002 %===============================================================================
8003 % Attribute for attributed variables
8005 make_attr(N,Mask,SuspsList,Attr) :-
8006 length(SuspsList,N),
8007 Attr =.. [v,Mask|SuspsList].
8009 get_all_suspensions2(N,Attr,SuspensionsList) :-
8010 chr_pp_flag(dynattr,off), !,
8011 make_attr(N,_,SuspensionsList,Attr).
8013 % NEW
8014 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8015 % writeln(get_all_suspensions2),
8016 length(SuspensionsList,N),
8017 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8020 % NEW
8021 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8022 % writeln(normalize_attr),
8023 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8025 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8026 chr_pp_flag(dynattr,off), !,
8027 make_attr(N,_,SuspsList,Attr),
8028 nth1(Position,SuspsList,Suspensions).
8030 % NEW
8031 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8032 % writeln(get_suspensions),
8033 Goal =
8034 ( memberchk(Position-Suspensions,TAttr) ->
8035 true
8036 ;
8037 Suspensions = []
8038 ).
8040 %-------------------------------------------------------------------------------
8041 % +N: number of constraint symbols
8042 % +Suspension: source-level variable, for suspension
8043 % +Position: constraint symbol number
8044 % -Attr: source-level term, for new attribute
8045 singleton_attr(N,Suspension,Position,Attr) :-
8046 chr_pp_flag(dynattr,off), !,
8047 or_pattern(Position,Pattern),
8048 make_attr(N,Pattern,SuspsList,Attr),
8049 nth1(Position,SuspsList,[Suspension]),
8050 chr_delete(SuspsList,[Suspension],RestSuspsList),
8051 set_elems(RestSuspsList,[]).
8053 % NEW
8054 singleton_attr(N,Suspension,Position,Attr) :-
8055 % writeln(singleton_attr),
8056 Attr = [Position-[Suspension]].
8058 %-------------------------------------------------------------------------------
8059 % +N: number of constraint symbols
8060 % +Suspension: source-level variable, for suspension
8061 % +Position: constraint symbol number
8062 % +TAttr: source-level variable, for old attribute
8063 % -Goal: goal for creating new attribute
8064 % -NTAttr: source-level variable, for new attribute
8065 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8066 chr_pp_flag(dynattr,off), !,
8067 make_attr(N,Mask,SuspsList,Attr),
8068 or_pattern(Position,Pattern),
8069 nth1(Position,SuspsList,Susps),
8070 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8071 make_attr(N,Mask,SuspsList1,NewAttr1),
8072 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8073 make_attr(N,NewMask,SuspsList2,NewAttr2),
8074 Goal = (
8075 TAttr = Attr,
8076 ( Mask /\ Pattern =:= Pattern ->
8077 NTAttr = NewAttr1
8078 ;
8079 NewMask is Mask \/ Pattern,
8080 NTAttr = NewAttr2
8081 )
8082 ), !.
8084 % NEW
8085 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8086 % writeln(add_attr),
8087 Goal =
8088 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8089 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8090 ;
8091 NTAttr = [Position-[Suspension]|TAttr]
8092 ).
8094 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8095 chr_pp_flag(dynattr,off), !,
8096 or_pattern(Position,Pattern),
8097 and_pattern(Position,DelPattern),
8098 make_attr(N,Mask,SuspsList,Attr),
8099 nth1(Position,SuspsList,Susps),
8100 substitute_eq(Susps,SuspsList,[],SuspsList1),
8101 make_attr(N,NewMask,SuspsList1,Attr1),
8102 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8103 make_attr(N,Mask,SuspsList2,Attr2),
8104 get_target_module(Mod),
8105 Goal = (
8106 TAttr = Attr,
8107 ( Mask /\ Pattern =:= Pattern ->
8108 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8109 ( NewSusps == [] ->
8110 NewMask is Mask /\ DelPattern,
8111 ( NewMask == 0 ->
8112 del_attr(Var,Mod)
8113 ;
8114 put_attr(Var,Mod,Attr1)
8115 )
8116 ;
8117 put_attr(Var,Mod,Attr2)
8118 )
8119 ;
8120 true
8121 )
8122 ), !.
8124 % NEW
8125 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8126 % writeln(rem_attr),
8127 get_target_module(Mod),
8128 Goal =
8129 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8130 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8131 ( NSuspensions == [] ->
8132 ( RAttr == [] ->
8133 del_attr(Var,Mod)
8134 ;
8135 put_attr(Var,Mod,RAttr)
8136 )
8137 ;
8138 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8139 )
8140 ;
8141 true
8142 ).
8144 %-------------------------------------------------------------------------------
8145 % +N: number of constraint symbols
8146 % +TAttr1: source-level variable, for attribute
8147 % +TAttr2: source-level variable, for other attribute
8148 % -Goal: goal for merging the two attributes
8149 % -Attr: source-level term, for merged attribute
8150 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8151 chr_pp_flag(dynattr,off), !,
8152 make_attr(N,Mask1,SuspsList1,Attr1),
8153 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8154 Goal = (
8155 TAttr1 = Attr1,
8156 Goal2
8157 ).
8159 % NEW
8160 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8161 % writeln(merge_attributes),
8162 Goal = (
8163 sort(TAttr1,Sorted1),
8164 sort(TAttr2,Sorted2),
8165 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8166 ).
8169 %-------------------------------------------------------------------------------
8170 % +N: number of constraint symbols
8171 % +Mask1: ...
8172 % +SuspsList1: static term, for suspensions list
8173 % +TAttr2: source-level variable, for other attribute
8174 % -Goal: goal for merging the two attributes
8175 % -Attr: source-level term, for merged attribute
8176 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8177 make_attr(N,Mask2,SuspsList2,Attr2),
8178 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8179 list2conj(Gs,SortGoals),
8180 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8181 make_attr(N,Mask,SuspsList,Attr),
8182 Goal = (
8183 TAttr2 = Attr2,
8184 SortGoals,
8185 Mask is Mask1 \/ Mask2
8186 ).
8189 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8190 % Storetype dependent lookup
8192 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8193 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8194 %% -Goal,-SuspensionList) is det.
8195 %
8196 % Create a universal lookup goal for given head.
8197 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8198 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8199 functor(Head,F,A),
8200 get_store_type(F/A,StoreType),
8201 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8203 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8204 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8205 %% -Goal,-SuspensionList) is det.
8206 %
8207 % Create a universal lookup goal for given head.
8208 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8209 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8210 functor(Head,F,A),
8211 get_store_type(F/A,StoreType),
8212 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8214 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8215 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8216 %% +GroundVars,-Goal,-SuspensionList) is det.
8217 %
8218 % Create a universal lookup goal for given head.
8219 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8220 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8221 functor(Head,F,A),
8222 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8223 update_store_type(F/A,default).
8224 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8225 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8226 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8227 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8228 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8229 functor(Head,F,A),
8230 global_ground_store_name(F/A,StoreName),
8231 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8232 update_store_type(F/A,global_ground).
8233 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8234 arg(VarIndex,Head,OVar),
8235 arg(KeyIndex,Head,OKey),
8236 translate([OVar,OKey],VarDict,[Var,Key]),
8237 get_target_module(Module),
8238 Goal = (
8239 get_attr(Var,Module,AssocStore),
8240 lookup_assoc_store(AssocStore,Key,AllSusps)
8241 ).
8242 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8243 functor(Head,F,A),
8244 global_singleton_store_name(F/A,StoreName),
8245 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8246 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8247 update_store_type(F/A,global_singleton).
8248 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8249 once((
8250 member(ST,StoreTypes),
8251 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8252 )).
8253 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8254 functor(Head,F,A),
8255 arg(Index,Head,Var),
8256 translate([Var],VarDict,[KeyVar]),
8257 delay_phase_end(validate_store_type_assumptions,
8258 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8259 ),
8260 update_store_type(F/A,identifier_store(Index)),
8261 get_identifier_index(F/A,Index,_).
8262 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8263 functor(Head,F,A),
8264 arg(Index,Head,Var),
8265 ( var(Var) ->
8266 translate([Var],VarDict,[KeyVar]),
8267 Goal = StructGoal
8268 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8269 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8270 Goal = (LookupGoal,StructGoal)
8271 ),
8272 delay_phase_end(validate_store_type_assumptions,
8273 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8274 ),
8275 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8276 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8278 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8279 get_identifier_size(ISize),
8280 functor(Struct,struct,ISize),
8281 get_identifier_index(C,Index,IIndex),
8282 arg(IIndex,Struct,AllSusps),
8283 Goal = (KeyVar = Struct).
8285 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8286 type_indexed_identifier_structure(IndexType,Struct),
8287 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8288 arg(IIndex,Struct,AllSusps),
8289 Goal = (KeyVar = Struct).
8291 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8292 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8293 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8294 %
8295 % Create a universal hash lookup goal for given head.
8296 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8297 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8298 once((
8299 member(Index,Indexes),
8300 multi_hash_key_args(Index,Head,KeyArgs),
8301 (
8302 translate(KeyArgs,VarDict,KeyArgCopies)
8303 ;
8304 ground(KeyArgs), KeyArgCopies = KeyArgs
8305 )
8306 )),
8307 ( KeyArgCopies = [KeyCopy] ->
8308 true
8309 ;
8310 KeyCopy =.. [k|KeyArgCopies]
8311 ),
8312 functor(Head,F,A),
8313 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8315 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8316 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8318 Goal = (GroundCheck,LookupGoal),
8320 ( HashType == inthash ->
8321 update_store_type(F/A,multi_inthash([Index]))
8322 ;
8323 update_store_type(F/A,multi_hash([Index]))
8324 ).
8326 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8327 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8328 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8329 %% +VarArgDict,-NewVarArgDict) is det.
8330 %
8331 % Create existential lookup goal for given head.
8332 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8333 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8334 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8335 sbag_member_call(Susp,AllSusps,Sbag),
8336 functor(Head,F,A),
8337 delay_phase_end(validate_store_type_assumptions,
8338 ( static_suspension_term(F/A,SuspTerm),
8339 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8340 )
8341 ),
8342 Goal = (
8343 UniversalGoal,
8344 Sbag,
8345 Susp = SuspTerm,
8346 GetState
8347 ).
8348 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8349 functor(Head,F,A),
8350 global_singleton_store_name(F/A,StoreName),
8351 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8352 Goal = (
8353 GetStoreGoal, % nb_getval(StoreName,Susp),
8354 Susp \== [],
8355 Susp = SuspTerm
8356 ),
8357 update_store_type(F/A,global_singleton).
8358 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8359 once((
8360 member(ST,StoreTypes),
8361 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8362 )).
8363 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8364 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8365 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8366 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8367 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8368 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8369 hash_index_filter(Pairs,Index,NPairs),
8371 functor(Head,F,A),
8372 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8373 Sbag = (AllSusps = [Susp])
8374 ;
8375 sbag_member_call(Susp,AllSusps,Sbag)
8376 ),
8377 delay_phase_end(validate_store_type_assumptions,
8378 ( static_suspension_term(F/A,SuspTerm),
8379 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8380 )
8381 ),
8382 Goal = (
8383 LookupGoal,
8384 Sbag,
8385 Susp = SuspTerm, % not inlined
8386 GetState
8387 ).
8388 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8389 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8390 hash_index_filter(Pairs,Index,NPairs),
8392 functor(Head,F,A),
8393 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8394 Sbag = (AllSusps = [Susp])
8395 ;
8396 sbag_member_call(Susp,AllSusps,Sbag)
8397 ),
8398 delay_phase_end(validate_store_type_assumptions,
8399 ( static_suspension_term(F/A,SuspTerm),
8400 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8401 )
8402 ),
8403 Goal = (
8404 LookupGoal,
8405 Sbag,
8406 Susp = SuspTerm, % not inlined
8407 GetState
8408 ).
8409 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8410 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8411 sbag_member_call(Susp,Susps,Sbag),
8412 functor(Head,F,A),
8413 delay_phase_end(validate_store_type_assumptions,
8414 ( static_suspension_term(F/A,SuspTerm),
8415 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8416 )
8417 ),
8418 Goal = (
8419 UGoal,
8420 Sbag,
8421 Susp = SuspTerm, % not inlined
8422 GetState
8423 ).
8425 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8426 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8427 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8428 %% +VarArgDict,-NewVarArgDict) is det.
8429 %
8430 % Create existential hash lookup goal for given head.
8431 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8432 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8433 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8435 hash_index_filter(Pairs,Index,NPairs),
8437 functor(Head,F,A),
8438 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8439 Sbag = (AllSusps = [Susp])
8440 ;
8441 sbag_member_call(Susp,AllSusps,Sbag)
8442 ),
8443 delay_phase_end(validate_store_type_assumptions,
8444 ( static_suspension_term(F/A,SuspTerm),
8445 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8446 )
8447 ),
8448 Goal = (
8449 LookupGoal,
8450 Sbag,
8451 Susp = SuspTerm, % not inlined
8452 GetState
8453 ).
8455 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8456 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8457 %
8458 % Filter out pairs already covered by given hash index.
8459 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8460 hash_index_filter(Pairs,Index,NPairs) :-
8461 ( integer(Index) ->
8462 NIndex = [Index]
8463 ;
8464 NIndex = Index
8465 ),
8466 hash_index_filter(Pairs,NIndex,1,NPairs).
8468 hash_index_filter([],_,_,[]).
8469 hash_index_filter([P|Ps],Index,N,NPairs) :-
8470 ( Index = [I|Is] ->
8471 NN is N + 1,
8472 ( I > N ->
8473 NPairs = [P|NPs],
8474 hash_index_filter(Ps,[I|Is],NN,NPs)
8475 ; I == N ->
8476 hash_index_filter(Ps,Is,NN,NPairs)
8477 )
8478 ;
8479 NPairs = [P|Ps]
8480 ).
8482 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8483 %------------------------------------------------------------------------------%
8484 %% assume_constraint_stores(+ConstraintSymbols) is det.
8485 %
8486 % Compute all constraint store types that are possible for the given
8487 % =ConstraintSymbols=.
8488 %------------------------------------------------------------------------------%
8489 assume_constraint_stores([]).
8490 assume_constraint_stores([C|Cs]) :-
8491 ( chr_pp_flag(debugable,off),
8492 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8493 is_stored(C),
8494 get_store_type(C,default) ->
8495 get_indexed_arguments(C,AllIndexedArgs),
8496 get_constraint_mode(C,Modes),
8497 findall(Index,(member(Index,AllIndexedArgs),
8498 nth(Index,Modes,+)),IndexedArgs),
8499 length(IndexedArgs,NbIndexedArgs),
8500 % Construct Index Combinations
8501 ( NbIndexedArgs > 10 ->
8502 findall([Index],member(Index,IndexedArgs),Indexes)
8503 ;
8504 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8505 predsort(longer_list,UnsortedIndexes,Indexes)
8506 ),
8507 % Choose Index Type
8508 ( get_functional_dependency(C,1,Pattern,Key),
8509 all_distinct_var_args(Pattern), Key == [] ->
8510 assumed_store_type(C,global_singleton)
8511 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8512 get_constraint_type_det(C,ArgTypes),
8513 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8515 ( IntHashIndexes = [] ->
8516 Stores = Stores1
8517 ;
8518 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8519 ),
8520 ( HashIndexes = [] ->
8521 Stores1 = Stores2
8522 ;
8523 Stores1 = [multi_hash(HashIndexes)|Stores2]
8524 ),
8525 ( IdentifierIndexes = [] ->
8526 Stores2 = Stores3
8527 ;
8528 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8529 append(WrappedIdentifierIndexes,Stores3,Stores2)
8530 ),
8531 append(CompoundIdentifierIndexes,Stores4,Stores3),
8532 ( only_ground_indexed_arguments(C)
8533 -> Stores4 = [global_ground]
8534 ; Stores4 = [default]
8535 ),
8536 assumed_store_type(C,multi_store(Stores))
8537 ; true
8538 )
8539 ;
8540 true
8541 ),
8542 assume_constraint_stores(Cs).
8544 %------------------------------------------------------------------------------%
8545 %% partition_indexes(+Indexes,+Types,
8546 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8547 %------------------------------------------------------------------------------%
8548 partition_indexes([],_,[],[],[],[]).
8549 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8550 ( Index = [I],
8551 nth(I,Types,Type),
8552 unalias_type(Type,UnAliasedType),
8553 UnAliasedType == chr_identifier ->
8554 IdentifierIndexes = [I|RIdentifierIndexes],
8555 IntHashIndexes = RIntHashIndexes,
8556 HashIndexes = RHashIndexes,
8557 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8558 ; Index = [I],
8559 nth(I,Types,Type),
8560 unalias_type(Type,UnAliasedType),
8561 nonvar(UnAliasedType),
8562 UnAliasedType = chr_identifier(IndexType) ->
8563 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8564 IdentifierIndexes = RIdentifierIndexes,
8565 IntHashIndexes = RIntHashIndexes,
8566 HashIndexes = RHashIndexes
8567 ; Index = [I],
8568 nth(I,Types,Type),
8569 unalias_type(Type,UnAliasedType),
8570 UnAliasedType == dense_int ->
8571 IntHashIndexes = [Index|RIntHashIndexes],
8572 HashIndexes = RHashIndexes,
8573 IdentifierIndexes = RIdentifierIndexes,
8574 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8575 ; member(I,Index),
8576 nth(I,Types,Type),
8577 unalias_type(Type,UnAliasedType),
8578 nonvar(UnAliasedType),
8579 UnAliasedType = chr_identifier(_) ->
8580 % don't use chr_identifiers in hash indexes
8581 IntHashIndexes = RIntHashIndexes,
8582 HashIndexes = RHashIndexes,
8583 IdentifierIndexes = RIdentifierIndexes,
8584 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8585 ;
8586 IntHashIndexes = RIntHashIndexes,
8587 HashIndexes = [Index|RHashIndexes],
8588 IdentifierIndexes = RIdentifierIndexes,
8589 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8590 ),
8591 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8593 longer_list(R,L1,L2) :-
8594 length(L1,N1),
8595 length(L2,N2),
8596 compare(Rt,N2,N1),
8597 ( Rt == (=) ->
8598 compare(R,L1,L2)
8599 ;
8600 R = Rt
8601 ).
8603 all_distinct_var_args(Term) :-
8604 Term =.. [_|Args],
8605 copy_term_nat(Args,NArgs),
8606 all_distinct_var_args_(NArgs).
8608 all_distinct_var_args_([]).
8609 all_distinct_var_args_([X|Xs]) :-
8610 var(X),
8611 X = t,
8612 all_distinct_var_args_(Xs).
8614 get_indexed_arguments(C,IndexedArgs) :-
8615 C = F/A,
8616 get_indexed_arguments(1,A,C,IndexedArgs).
8618 get_indexed_arguments(I,N,C,L) :-
8619 ( I > N ->
8620 L = []
8621 ; ( is_indexed_argument(C,I) ->
8622 L = [I|T]
8623 ;
8624 L = T
8625 ),
8626 J is I + 1,
8627 get_indexed_arguments(J,N,C,T)
8628 ).
8630 validate_store_type_assumptions([]).
8631 validate_store_type_assumptions([C|Cs]) :-
8632 validate_store_type_assumption(C),
8633 validate_store_type_assumptions(Cs).
8635 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8636 % new code generation
8637 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
8638 Rule = rule(H1,_,Guard,Body),
8639 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8640 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8641 flatten(VarsAndSuspsList,VarsAndSusps),
8642 Vars = [ [] | VarsAndSusps],
8643 build_head(F,A,Id,Vars,Head),
8644 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8645 Clause = ( Head :- PredecessorCall),
8646 add_dummy_location(Clause,LocatedClause),
8647 L = [LocatedClause | T].
8648 % ( H1 == [],
8649 % functor(CurrentHead,CF,CA),
8650 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8651 % L = T
8652 % ;
8653 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8654 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8655 % flatten(VarsAndSuspsList,VarsAndSusps),
8656 % Vars = [ [] | VarsAndSusps],
8657 % build_head(F,A,Id,Vars,Head),
8658 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8659 % Clause = ( Head :- PredecessorCall),
8660 % L = [Clause | T]
8661 % ).
8663 % skips back intelligently over global_singleton lookups
8664 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8665 ( Id = [0|_] ->
8666 next_id(Id,PrevId),
8667 PrevVarsAndSusps = BaseCallArgs
8668 ;
8669 VarsAndSuspsList = [_|AllButFirstList],
8670 dec_id(Id,PrevId1),
8671 ( PrevHeads = [PrevHead|PrevHeads1],
8672 functor(PrevHead,F,A),
8673 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8674 PrevIterators = [_|PrevIterators1],
8675 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8676 ;
8677 PrevId = PrevId1,
8678 flatten(AllButFirstList,AllButFirst),
8679 PrevIterators = [PrevIterator|_],
8680 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8681 )
8682 ).
8684 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
8685 Rule = rule(_,_,Guard,Body),
8686 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8687 init(AllSusps,PreSusps),
8688 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8689 gen_var(OtherSusps),
8690 functor(CurrentHead,OtherF,OtherA),
8691 gen_vars(OtherA,OtherVars),
8692 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8693 get_constraint_mode(OtherF/OtherA,Mode),
8694 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8696 delay_phase_end(validate_store_type_assumptions,
8697 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8698 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8699 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8700 )
8701 ),
8703 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8704 % create_get_mutable_ref(active,State,GetMutable),
8705 CurrentSuspTest = (
8706 OtherSusp = OtherSuspension,
8707 GetState,
8708 DiffSuspGoals,
8709 FirstMatching
8710 ),
8711 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8712 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8713 inc_id(Id,NestedId),
8714 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8715 build_head(F,A,Id,ClauseVars,ClauseHead),
8716 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8717 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8718 build_head(F,A,NestedId,NestedVars,NestedHead),
8720 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8721 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
8722 RecursiveVars = PreVarsAndSusps1
8723 ;
8724 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8725 PrevId = Id
8726 ),
8727 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8729 Clause = (
8730 ClauseHead :-
8731 ( CurrentSuspTest,
8732 NextSuspGoal
8733 ->
8734 NestedHead
8735 ; RecursiveHead
8736 )
8737 ),
8738 add_dummy_location(Clause,LocatedClause),
8739 L = [LocatedClause|T].
8741 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8743 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8744 % Observation Analysis
8745 %
8746 % CLASSIFICATION
8747 % Enabled
8748 %
8749 % Analysis based on Abstract Interpretation paper.
8750 %
8751 % TODO:
8752 % stronger analysis domain [research]
8754 :- chr_constraint
8755 initial_call_pattern/1,
8756 call_pattern/1,
8757 call_pattern_worker/1,
8758 final_answer_pattern/2,
8759 abstract_constraints/1,
8760 depends_on/2,
8761 depends_on_ap/4,
8762 depends_on_goal/2,
8763 ai_observed_internal/2,
8764 % ai_observed/2,
8765 ai_not_observed_internal/2,
8766 ai_not_observed/2,
8767 ai_is_observed/2,
8768 depends_on_as/3,
8769 ai_observation_gather_results/0.
8771 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8772 :- chr_type program_point == any.
8774 :- chr_option(mode,initial_call_pattern(+)).
8775 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8777 :- chr_option(mode,call_pattern(+)).
8778 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8780 :- chr_option(mode,call_pattern_worker(+)).
8781 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8783 :- chr_option(mode,final_answer_pattern(+,+)).
8784 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8786 :- chr_option(mode,abstract_constraints(+)).
8787 :- chr_option(type_declaration,abstract_constraints(list)).
8789 :- chr_option(mode,depends_on(+,+)).
8790 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8792 :- chr_option(mode,depends_on_as(+,+,+)).
8793 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8794 :- chr_option(mode,depends_on_goal(+,+)).
8795 :- chr_option(mode,ai_is_observed(+,+)).
8796 :- chr_option(mode,ai_not_observed(+,+)).
8797 % :- chr_option(mode,ai_observed(+,+)).
8798 :- chr_option(mode,ai_not_observed_internal(+,+)).
8799 :- chr_option(mode,ai_observed_internal(+,+)).
8802 abstract_constraints_fd @
8803 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8805 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8806 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8807 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8809 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8810 ai_is_observed(_,_) <=> true.
8812 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8813 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8814 ai_observation_gather_results <=> true.
8816 %------------------------------------------------------------------------------%
8817 % Main Analysis Entry
8818 %------------------------------------------------------------------------------%
8819 ai_observation_analysis(ACs) :-
8820 ( chr_pp_flag(ai_observation_analysis,on),
8821 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8822 list_to_ord_set(ACs,ACSet),
8823 abstract_constraints(ACSet),
8824 ai_observation_schedule_initial_calls(ACSet,ACSet),
8825 ai_observation_gather_results
8826 ;
8827 true
8828 ).
8830 ai_observation_schedule_initial_calls([],_).
8831 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8832 ai_observation_schedule_initial_call(AC,ACs),
8833 ai_observation_schedule_initial_calls(RACs,ACs).
8835 ai_observation_schedule_initial_call(AC,ACs) :-
8836 ai_observation_top(AC,CallPattern),
8837 % ai_observation_bot(AC,ACs,CallPattern),
8838 initial_call_pattern(CallPattern).
8840 ai_observation_schedule_new_calls([],AP).
8841 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8842 AP = odom(_,Set),
8843 initial_call_pattern(odom(AC,Set)),
8844 ai_observation_schedule_new_calls(ACs,AP).
8846 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8847 <=>
8848 ai_observation_leq(AP2,AP1)
8849 |
8850 true.
8852 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
8854 initial_call_pattern(CP) ==> call_pattern(CP).
8856 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
8857 ==>
8858 ai_observation_schedule_new_calls(ACs,AP)
8859 pragma
8860 passive(ID3).
8862 call_pattern(CP) \ call_pattern(CP) <=> true.
8864 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
8865 final_answer_pattern(CP1,AP).
8867 %call_pattern(CP) ==> writeln(call_pattern(CP)).
8869 call_pattern(CP) ==> call_pattern_worker(CP).
8871 %------------------------------------------------------------------------------%
8872 % Abstract Goal
8873 %------------------------------------------------------------------------------%
8875 % AbstractGoala
8876 %call_pattern(odom([],Set)) ==>
8877 % final_answer_pattern(odom([],Set),odom([],Set)).
8879 call_pattern_worker(odom([],Set)) <=>
8880 % writeln(' - AbstractGoal'(odom([],Set))),
8881 final_answer_pattern(odom([],Set),odom([],Set)).
8883 % AbstractGoalb
8884 call_pattern_worker(odom([G|Gs],Set)) <=>
8885 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
8886 CP1 = odom(G,Set),
8887 depends_on_goal(odom([G|Gs],Set),CP1),
8888 call_pattern(CP1).
8890 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
8891 <=> true pragma passive(ID).
8892 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
8893 ==>
8894 CP1 = odom([_|Gs],_),
8895 AP2 = odom([],Set),
8896 CCP = odom(Gs,Set),
8897 call_pattern(CCP),
8898 depends_on(CP1,CCP).
8900 %------------------------------------------------------------------------------%
8901 % Abstract Disjunction
8902 %------------------------------------------------------------------------------%
8904 call_pattern_worker(odom((AG1;AG2),Set)) <=>
8905 CP = odom((AG1;AG2),Set),
8906 InitialAnswerApproximation = odom([],Set),
8907 final_answer_pattern(CP,InitialAnswerApproximation),
8908 CP1 = odom(AG1,Set),
8909 CP2 = odom(AG2,Set),
8910 call_pattern(CP1),
8911 call_pattern(CP2),
8912 depends_on_as(CP,CP1,CP2).
8914 %------------------------------------------------------------------------------%
8915 % Abstract Solve
8916 %------------------------------------------------------------------------------%
8917 call_pattern_worker(odom(builtin,Set)) <=>
8918 % writeln(' - AbstractSolve'(odom(builtin,Set))),
8919 ord_empty(EmptySet),
8920 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
8922 %------------------------------------------------------------------------------%
8923 % Abstract Drop
8924 %------------------------------------------------------------------------------%
8925 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8926 <=>
8927 O > MO
8928 |
8929 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
8930 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8931 pragma
8932 passive(ID2).
8934 %------------------------------------------------------------------------------%
8935 % Abstract Activate
8936 %------------------------------------------------------------------------------%
8937 call_pattern_worker(odom(AC,Set))
8938 <=>
8939 AC = _ / _
8940 |
8941 % writeln(' - AbstractActivate'(odom(AC,Set))),
8942 CP = odom(occ(AC,1),Set),
8943 call_pattern(CP),
8944 depends_on(odom(AC,Set),CP).
8946 %------------------------------------------------------------------------------%
8947 % Abstract Passive
8948 %------------------------------------------------------------------------------%
8949 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8950 <=>
8951 is_passive(RuleNb,ID)
8952 |
8953 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8954 % DEFAULT
8955 NO is O + 1,
8956 DCP = odom(occ(C,NO),Set),
8957 call_pattern(DCP),
8958 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
8959 depends_on(odom(occ(C,O),Set),DCP)
8960 pragma
8961 passive(ID2).
8962 %------------------------------------------------------------------------------%
8963 % Abstract Simplify
8964 %------------------------------------------------------------------------------%
8966 % AbstractSimplify
8967 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8968 <=>
8969 \+ is_passive(RuleNb,ID)
8970 |
8971 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8972 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
8973 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
8974 ai_observation_memo_abstract_goal(RuleNb,AG),
8975 call_pattern(odom(AG,Set2)),
8976 % DEFAULT
8977 NO is O + 1,
8978 DCP = odom(occ(C,NO),Set),
8979 call_pattern(DCP),
8980 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
8981 % DEADLOCK AVOIDANCE
8982 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8983 pragma
8984 passive(ID2).
8986 depends_on_as(CP,CPS,CPD),
8987 final_answer_pattern(CPS,APS),
8988 final_answer_pattern(CPD,APD) ==>
8989 ai_observation_lub(APS,APD,AP),
8990 final_answer_pattern(CP,AP).
8993 :- chr_constraint
8994 ai_observation_memo_simplification_rest_heads/3,
8995 ai_observation_memoed_simplification_rest_heads/3.
8997 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
8998 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9000 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9001 <=>
9002 QRH = RH.
9003 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9004 <=>
9005 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9006 once(select2(ID,_,IDs1,H1,_,RestH1)),
9007 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9008 ai_observation_abstract_constraints(H2,ACs,AH2),
9009 append(ARestHeads,AH2,AbstractHeads),
9010 sort(AbstractHeads,QRH),
9011 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9012 pragma
9013 passive(ID1),
9014 passive(ID2),
9015 passive(ID3).
9017 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9019 %------------------------------------------------------------------------------%
9020 % Abstract Propagate
9021 %------------------------------------------------------------------------------%
9024 % AbstractPropagate
9025 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9026 <=>
9027 \+ is_passive(RuleNb,ID)
9028 |
9029 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9030 % observe partners
9031 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9032 ai_observation_observe_set(Set,AHs,Set2),
9033 ord_add_element(Set2,C,Set3),
9034 ai_observation_memo_abstract_goal(RuleNb,AG),
9035 call_pattern(odom(AG,Set3)),
9036 ( ord_memberchk(C,Set2) ->
9037 Delete = no
9038 ;
9039 Delete = yes
9040 ),
9041 % DEFAULT
9042 NO is O + 1,
9043 DCP = odom(occ(C,NO),Set),
9044 call_pattern(DCP),
9045 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9046 pragma
9047 passive(ID2).
9049 :- chr_constraint
9050 ai_observation_memo_propagation_rest_heads/3,
9051 ai_observation_memoed_propagation_rest_heads/3.
9053 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9054 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9056 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9057 <=>
9058 QRH = RH.
9059 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9060 <=>
9061 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9062 once(select2(ID,_,IDs2,H2,_,RestH2)),
9063 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9064 ai_observation_abstract_constraints(H1,ACs,AH1),
9065 append(ARestHeads,AH1,AbstractHeads),
9066 sort(AbstractHeads,QRH),
9067 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9068 pragma
9069 passive(ID1),
9070 passive(ID2),
9071 passive(ID3).
9073 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9075 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9076 final_answer_pattern(CP,APD).
9077 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9078 final_answer_pattern(CPD,APD) ==>
9079 true |
9080 CP = odom(occ(C,O),_),
9081 ( ai_observation_is_observed(APP,C) ->
9082 ai_observed_internal(C,O)
9083 ;
9084 ai_not_observed_internal(C,O)
9085 ),
9086 ( Delete == yes ->
9087 APP = odom([],Set0),
9088 ord_del_element(Set0,C,Set),
9089 NAPP = odom([],Set)
9090 ;
9091 NAPP = APP
9092 ),
9093 ai_observation_lub(NAPP,APD,AP),
9094 final_answer_pattern(CP,AP).
9096 %------------------------------------------------------------------------------%
9097 % Catch All
9098 %------------------------------------------------------------------------------%
9100 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9102 %------------------------------------------------------------------------------%
9103 % Auxiliary Predicates
9104 %------------------------------------------------------------------------------%
9106 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9107 ord_intersection(S1,S2,S3).
9109 ai_observation_bot(AG,AS,odom(AG,AS)).
9111 ai_observation_top(AG,odom(AG,EmptyS)) :-
9112 ord_empty(EmptyS).
9114 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9115 ord_subset(S2,S1).
9117 ai_observation_observe_set(S,ACSet,NS) :-
9118 ord_subtract(S,ACSet,NS).
9120 ai_observation_abstract_constraint(C,ACs,AC) :-
9121 functor(C,F,A),
9122 AC = F/A,
9123 memberchk(AC,ACs).
9125 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9126 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9128 %------------------------------------------------------------------------------%
9129 % Abstraction of Rule Bodies
9130 %------------------------------------------------------------------------------%
9132 :- chr_constraint
9133 ai_observation_memoed_abstract_goal/2,
9134 ai_observation_memo_abstract_goal/2.
9136 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9137 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9139 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9140 <=>
9141 QAG = AG
9142 pragma
9143 passive(ID1).
9145 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9146 <=>
9147 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9148 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9149 QAG = AG,
9150 ai_observation_memoed_abstract_goal(RuleNb,AG)
9151 pragma
9152 passive(ID1),
9153 passive(ID2).
9155 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9156 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9157 term_variables((H1,H2,Guard),HVars),
9158 append(H1,H2,Heads),
9159 % variables that are declared to be ground are safe,
9160 ground_vars(Heads,GroundVars),
9161 % so we remove them from the list of 'dangerous' head variables
9162 list_difference_eq(HVars,GroundVars,HV),
9163 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9164 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9165 % HV are 'dangerous' variables, all others are fresh and safe
9167 ground_vars([],[]).
9168 ground_vars([H|Hs],GroundVars) :-
9169 functor(H,F,A),
9170 get_constraint_mode(F/A,Mode),
9171 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9172 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9173 ground_vars(Hs,GroundVars2),
9174 append(GroundVars1,GroundVars2,GroundVars).
9176 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9177 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9178 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9179 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9180 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9181 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9182 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9183 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9184 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9185 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9186 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9187 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9188 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9189 % non-CHR constraint is safe if it only binds fresh variables
9190 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9191 builtin_binds_b(G,Vars),
9192 intersect_eq(Vars,HV,[]),
9193 !.
9194 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9195 AG = builtin. % default case if goal is not recognized/safe
9197 ai_observation_is_observed(odom(_,ACSet),AC) :-
9198 \+ ord_memberchk(AC,ACSet).
9200 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9201 unconditional_occurrence(C,O) :-
9202 get_occurrence(C,O,RuleNb,ID),
9203 get_rule(RuleNb,PRule),
9204 PRule = pragma(ORule,_,_,_,_),
9205 copy_term_nat(ORule,Rule),
9206 Rule = rule(H1,H2,Guard,_),
9207 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9208 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9209 once((
9210 H1 = [Head], H2 == []
9211 ;
9212 H2 = [Head], H1 == [], \+ may_trigger(C)
9213 )),
9214 functor(Head,F,A),
9215 Head =.. [_|Args],
9216 unconditional_occurrence_args(Args).
9218 unconditional_occurrence_args([]).
9219 unconditional_occurrence_args([X|Xs]) :-
9220 var(X),
9221 X = x,
9222 unconditional_occurrence_args(Xs).
9224 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9226 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9227 % Partial wake analysis
9228 %
9229 % In a Var = Var unification do not wake up constraints of both variables,
9230 % but rather only those of one variable.
9231 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9233 :- chr_constraint partial_wake_analysis/0.
9234 :- chr_constraint no_partial_wake/1.
9235 :- chr_option(mode,no_partial_wake(+)).
9236 :- chr_constraint wakes_partially/1.
9237 :- chr_option(mode,wakes_partially(+)).
9239 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9240 ==>
9241 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9242 ( is_passive(RuleNb,ID) ->
9243 true
9244 ; Type == simplification ->
9245 select(H,H1,RestH1),
9246 H =.. [_|Args],
9247 term_variables(Guard,Vars),
9248 partial_wake_args(Args,ArgModes,Vars,FA)
9249 ; % Type == propagation ->
9250 select(H,H2,RestH2),
9251 H =.. [_|Args],
9252 term_variables(Guard,Vars),
9253 partial_wake_args(Args,ArgModes,Vars,FA)
9254 ).
9256 partial_wake_args([],_,_,_).
9257 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9258 ( Mode \== (+) ->
9259 ( nonvar(Arg) ->
9260 no_partial_wake(C)
9261 ; memberchk_eq(Arg,Vars) ->
9262 no_partial_wake(C)
9263 ;
9264 true
9265 )
9266 ;
9267 true
9268 ),
9269 partial_wake_args(Args,Modes,Vars,C).
9271 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9273 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9275 wakes_partially(C) <=> true.
9278 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9279 % Generate rules that implement chr_show_store/1 functionality.
9280 %
9281 % CLASSIFICATION
9282 % Experimental
9283 % Unused
9284 %
9285 % Generates additional rules:
9286 %
9287 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9288 % ...
9289 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9290 % $show <=> true.
9292 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9293 ( chr_pp_flag(show,on) ->
9294 Constraints = ['$show'/0|Constraints0],
9295 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9296 inc_rule_count(RuleNb),
9297 Rule = pragma(
9298 rule(['$show'],[],true,true),
9299 ids([0],[]),
9300 [],
9301 no,
9302 RuleNb
9303 )
9304 ;
9305 Constraints = Constraints0,
9306 Rules = Rules0
9307 ).
9309 generate_show_rules([],Rules,Rules).
9310 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9311 functor(C,F,A),
9312 inc_rule_count(RuleNb),
9313 Rule = pragma(
9314 rule([],['$show',C],true,writeln(C)),
9315 ids([],[0,1]),
9316 [passive(1)],
9317 no,
9318 RuleNb
9319 ),
9320 generate_show_rules(Rest,Tail,Rules).
9322 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9323 % Custom supension term layout
9325 static_suspension_term(F/A,Suspension) :-
9326 suspension_term_base(F/A,Base),
9327 Arity is Base + A,
9328 functor(Suspension,suspension,Arity).
9330 has_suspension_field(FA,Field) :-
9331 suspension_term_base_fields(FA,Fields),
9332 memberchk(Field,Fields).
9334 suspension_term_base(FA,Base) :-
9335 suspension_term_base_fields(FA,Fields),
9336 length(Fields,Base).
9338 suspension_term_base_fields(FA,Fields) :-
9339 ( chr_pp_flag(debugable,on) ->
9340 % 1. ID
9341 % 2. State
9342 % 3. Propagation History
9343 % 4. Generation Number
9344 % 5. Continuation Goal
9345 % 6. Functor
9346 Fields = [id,state,history,generation,continuation,functor]
9347 ;
9348 ( uses_history(FA) ->
9349 Fields = [id,state,history|Fields2]
9350 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9351 Fields = [state|Fields2]
9352 ;
9353 Fields = [id,state|Fields2]
9354 ),
9355 ( only_ground_indexed_arguments(FA) ->
9356 get_store_type(FA,StoreType),
9357 basic_store_types(StoreType,BasicStoreTypes),
9358 ( memberchk(global_ground,BasicStoreTypes) ->
9359 % 1. ID
9360 % 2. State
9361 % 3. Propagation History
9362 % 4. Global List Prev
9363 Fields2 = [global_list_prev|Fields3]
9364 ;
9365 % 1. ID
9366 % 2. State
9367 % 3. Propagation History
9368 Fields2 = Fields3
9369 ),
9370 ( chr_pp_flag(ht_removal,on)
9371 -> ht_prev_fields(BasicStoreTypes,Fields3)
9372 ; Fields3 = []
9373 )
9374 ; may_trigger(FA) ->
9375 % 1. ID
9376 % 2. State
9377 % 3. Propagation History
9378 ( uses_field(FA,generation) ->
9379 % 4. Generation Number
9380 % 5. Global List Prev
9381 Fields2 = [generation,global_list_prev|Fields3]
9382 ;
9383 Fields2 = [global_list_prev|Fields3]
9384 ),
9385 ( chr_pp_flag(mixed_stores,on),
9386 chr_pp_flag(ht_removal,on)
9387 -> get_store_type(FA,StoreType),
9388 basic_store_types(StoreType,BasicStoreTypes),
9389 ht_prev_fields(BasicStoreTypes,Fields3)
9390 ; Fields3 = []
9391 )
9392 ;
9393 % 1. ID
9394 % 2. State
9395 % 3. Propagation History
9396 % 4. Global List Prev
9397 Fields2 = [global_list_prev|Fields3],
9398 ( chr_pp_flag(mixed_stores,on),
9399 chr_pp_flag(ht_removal,on)
9400 -> get_store_type(FA,StoreType),
9401 basic_store_types(StoreType,BasicStoreTypes),
9402 ht_prev_fields(BasicStoreTypes,Fields3)
9403 ; Fields3 = []
9404 )
9405 )
9406 ).
9408 ht_prev_fields(Stores,Prevs) :-
9409 ht_prev_fields_int(Stores,PrevsList),
9410 append(PrevsList,Prevs).
9411 ht_prev_fields_int([],[]).
9412 ht_prev_fields_int([H|T],Fields) :-
9413 ( H = multi_hash(Indexes)
9414 -> maplist(ht_prev_field,Indexes,FH),
9415 Fields = [FH|FT]
9416 ; Fields = FT
9417 ),
9418 ht_prev_fields_int(T,FT).
9420 ht_prev_field(Index,Field) :-
9421 ( integer(Index)
9422 -> atom_concat('multi_hash_prev-',Index,Field)
9423 ; Index = [_|_]
9424 -> concat_atom(['multi_hash_prev-'|Index],Field)
9425 ).
9427 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9428 suspension_term_base_fields(FA,Fields),
9429 nth(Index,Fields,FieldName), !,
9430 arg(Index,StaticSuspension,Field).
9431 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9432 suspension_term_base(FA,Base),
9433 StaticSuspension =.. [_|Args],
9434 drop(Base,Args,Field).
9435 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9436 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9439 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9440 suspension_term_base_fields(FA,Fields),
9441 nth(Index,Fields,FieldName), !,
9442 Goal = arg(Index,DynamicSuspension,Field).
9443 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9444 static_suspension_term(FA,StaticSuspension),
9445 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9446 Goal = (DynamicSuspension = StaticSuspension).
9447 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9448 suspension_term_base(FA,Base),
9449 Index is I + Base,
9450 Goal = arg(Index,DynamicSuspension,Field).
9451 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9452 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9455 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9456 suspension_term_base_fields(FA,Fields),
9457 nth(Index,Fields,FieldName), !,
9458 Goal = setarg(Index,DynamicSuspension,Field).
9459 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9460 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9462 basic_store_types(multi_store(Types),Types) :- !.
9463 basic_store_types(Type,[Type]).
9465 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9466 %
9468 :- chr_constraint
9469 phase_end/1,
9470 delay_phase_end/2.
9472 :- chr_option(mode,phase_end(+)).
9473 :- chr_option(mode,delay_phase_end(+,?)).
9475 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9476 % phase_end(Phase) <=> true.
9479 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9480 :- chr_constraint
9481 does_use_history/2,
9482 uses_history/1,
9483 novel_production_call/4.
9485 :- chr_option(mode,uses_history(+)).
9486 :- chr_option(mode,does_use_history(+,+)).
9487 :- chr_option(mode,novel_production_call(+,+,?,?)).
9489 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9490 does_use_history(FA,_) \ uses_history(FA) <=> true.
9491 uses_history(_FA) <=> fail.
9493 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9494 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9496 :- chr_constraint
9497 does_use_field/2,
9498 uses_field/2.
9500 :- chr_option(mode,uses_field(+,+)).
9501 :- chr_option(mode,does_use_field(+,+)).
9503 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9504 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9505 uses_field(_FA,_Field) <=> fail.
9507 :- chr_constraint
9508 uses_state/2,
9509 if_used_state/5,
9510 used_states_known/0.
9512 :- chr_option(mode,uses_state(+,+)).
9513 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9516 % states ::= not_stored_yet | passive | active | triggered | removed
9517 %
9518 % allocate CREATES not_stored_yet
9519 % remove CHECKS not_stored_yet
9520 % activate CHECKS not_stored_yet
9521 %
9522 % ==> no allocate THEN no not_stored_yet
9524 % recurs CREATES inactive
9525 % lookup CHECKS inactive
9527 % insert CREATES active
9528 % activate CREATES active
9529 % lookup CHECKS active
9530 % recurs CHECKS active
9532 % runsusp CREATES triggered
9533 % lookup CHECKS triggered
9534 %
9535 % ==> no runsusp THEN no triggered
9537 % remove CREATES removed
9538 % runsusp CHECKS removed
9539 % lookup CHECKS removed
9540 % recurs CHECKS removed
9541 %
9542 % ==> no remove THEN no removed
9544 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9546 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9548 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9549 <=> ResultGoal = Used.
9550 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9551 <=> ResultGoal = NotUsed.
9553 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9554 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9555 % (Feature for SSS)
9556 %
9557 % 1. Checking
9558 % ~~~~~~~~~~~
9559 %
9560 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9561 %
9562 % :- chr_option(declare_stored_constraints,on).
9563 %
9564 % the compiler will check for the storedness of constraints.
9565 %
9566 % By default, the compiler assumes that the programmer wants his constraints to
9567 % be never-stored. Hence, a warning will be issues when a constraint is actually
9568 % stored.
9569 %
9570 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9571 % to a constraint declaration, i.e. writes
9572 %
9573 % :- chr_constraint c(...) # stored.
9574 %
9575 % In that case a warning is issued when the constraint is never-stored.
9576 %
9577 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9578 % constraints are stored anyway.
9579 %
9580 %
9581 % 2. Rule Generation
9582 % ~~~~~~~~~~~~~~~~~~
9583 %
9584 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9585 %
9586 % :- chr_option(declare_stored_constraints,on).
9587 %
9588 % the compiler will generate default simplification rules for constraints.
9589 %
9590 % By default, no default rule is generated for a constraint. However, if the
9591 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9592 %
9593 % :- chr_constraint c(...) # default(Goal).
9594 %
9595 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9596 % the compiler generates a rule:
9597 %
9598 % c(_,...,_) <=> Goal.
9599 %
9600 % at the end of the program. If multiple default rules are generated, for several constraints,
9601 % then the order of the default rules is not specified.
9604 :- chr_constraint stored_assertion/1.
9605 :- chr_option(mode,stored_assertion(+)).
9606 :- chr_option(type_declaration,stored_assertion(constraint)).
9608 :- chr_constraint never_stored_default/2.
9609 :- chr_option(mode,never_stored_default(+,?)).
9610 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9612 % Rule Generation
9613 % ~~~~~~~~~~~~~~~
9615 generate_never_stored_rules(Constraints,Rules) :-
9616 ( chr_pp_flag(declare_stored_constraints,on) ->
9617 never_stored_rules(Constraints,Rules)
9618 ;
9619 Rules = []
9620 ).
9622 :- chr_constraint never_stored_rules/2.
9623 :- chr_option(mode,never_stored_rules(+,?)).
9624 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9626 never_stored_rules([],Rules) <=> Rules = [].
9627 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9628 Constraint = F/A,
9629 functor(Head,F,A),
9630 inc_rule_count(RuleNb),
9631 Rule = pragma(
9632 rule([Head],[],true,Goal),
9633 ids([0],[]),
9634 [],
9635 no,
9636 RuleNb
9637 ),
9638 Rules = [Rule|Tail],
9639 never_stored_rules(Constraints,Tail).
9640 never_stored_rules([_|Constraints],Rules) <=>
9641 never_stored_rules(Constraints,Rules).
9643 % Checking
9644 % ~~~~~~~~
9646 check_storedness_assertions(Constraints) :-
9647 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9648 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9649 ;
9650 true
9651 ).
9654 :- chr_constraint check_storedness_assertion/1.
9655 :- chr_option(mode,check_storedness_assertion(+)).
9656 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9658 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9659 <=> ( is_stored(Constraint) ->
9660 true
9661 ;
9662 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9663 ).
9664 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9665 <=> ( is_finally_stored(Constraint) ->
9666 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9667 ; is_stored(Constraint) ->
9668 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9669 ;
9670 true
9671 ).
9672 % never-stored, no default goal
9673 check_storedness_assertion(Constraint)
9674 <=> ( is_finally_stored(Constraint) ->
9675 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9676 ; is_stored(Constraint) ->
9677 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9678 ;
9679 true
9680 ).