| blob | 12b4b3d7dab26d9592d818361cc4a4d62d0288d8 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% OPEN BUGS
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * success continuation optimization
64 %% * analyze history usage to determine whether/when
65 %% cheaper suspension is possible:
66 %% don't use history when all partners are passive and self never triggers
67 %% * store constraint unconditionally for unconditional propagation rule,
68 %% if first, i.e. without checking history and set trigger cont to next occ
69 %% * get rid of suspension passing for never triggered constraints,
70 %% up to allocation occurrence
71 %% * get rid of call indirection for never triggered constraints
72 %% up to first allocation occurrence.
73 %% * get rid of unnecessary indirection if last active occurrence
74 %% before unconditional removal is head2, e.g.
75 %% a \ b <=> true.
76 %% a <=> true.
77 %% * Eliminate last clause of never stored constraint, if its body
78 %% is fail, e.g.
79 %% a ...
80 %% a <=> fail.
81 %% * Specialize lookup operations and indexes for functional dependencies.
82 %%
83 %% MORE TODO
84 %%
85 %% * generate code to empty all constraint stores of a module (Bart Demoen)
86 %% * map A \ B <=> true | true rules
87 %% onto efficient code that empties the constraint stores of B
88 %% in O(1) time for ground constraints where A and B do not share
89 %% any variables
90 %% * ground matching seems to be not optimized for compound terms
91 %% in case of simpagation_head2 and propagation occurrences
92 %% * analysis for storage delaying (see primes for case)
93 %% * internal constraints declaration + analyses?
94 %% * Do not store in global variable store if not necessary
95 %% NOTE: affects show_store/1
96 %% * var_assoc multi-level store: variable - ground
97 %% * Do not maintain/check unnecessary propagation history
98 %% for reasons of anti-monotony
99 %% * Strengthen storage analysis for propagation rules
100 %% reason about bodies of rules only containing constraints
101 %% -> fixpoint with observation analysis
102 %% * instantiation declarations
103 %% COMPOUND (bound to nonvar)
104 %% avoid nonvar tests
105 %%
106 %% * make difference between cheap guards for reordering
107 %% and non-binding guards for lock removal
108 %% * fd -> once/[] transformation for propagation
109 %% * cheap guards interleaved with head retrieval + faster
110 %% via-retrieval + non-empty checking for propagation rules
111 %% redo for simpagation_head2 prelude
112 %% * intelligent backtracking for simplification/simpagation rule
113 %% generator_1(X),'_$savecp'(CP_1),
114 %% ...
115 %% if( (
116 %% generator_n(Y),
117 %% test(X,Y)
118 %% ),
119 %% true,
120 %% ('_$cutto'(CP_1), fail)
121 %% ),
122 %% ...
123 %%
124 %% or recently developped cascading-supported approach
125 %% * intelligent backtracking for propagation rule
126 %% use additional boolean argument for each possible smart backtracking
127 %% when boolean at end of list true -> no smart backtracking
128 %% false -> smart backtracking
129 %% only works for rules with at least 3 constraints in the head
130 %% * (set semantics + functional dependency) declaration + resolution
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %% merged
133 %%
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
137 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
138 ]).
139 %% SWI begin
140 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
141 :- use_module(library(ordsets)).
142 %% SWI end
144 :- use_module(hprolog).
145 :- use_module(pairlist).
146 :- use_module(a_star).
147 :- use_module(listmap).
148 :- use_module(clean_code).
149 :- use_module(builtins).
150 :- use_module(find).
151 :- use_module(binomialheap).
152 :- use_module(guard_entailment).
153 :- use_module(chr_compiler_options).
154 :- use_module(chr_compiler_utility).
155 :- use_module(chr_compiler_errors).
156 :- include(chr_op).
157 :- op(1150, fx, chr_type).
158 :- op(1130, xfx, --->).
159 :- op(980, fx, (+)).
160 :- op(980, fx, (-)).
161 :- op(980, fx, (?)).
162 :- op(1150, fx, constraints).
163 :- op(1150, fx, chr_constraint).
165 :- chr_option(debug,off).
166 :- chr_option(optimize,full).
167 :- chr_option(check_guard_bindings,off).
169 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
171 :- chr_type list(T) ---> [] ; [T|list(T)].
172 :- chr_type list == list(any).
174 :- chr_type maybe(T) ---> yes(T) ; no.
176 :- chr_type constraint ---> any / any.
178 :- chr_type module_name == any.
180 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
181 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
182 :- chr_type idspair ---> ids(list(id),list(id)).
184 :- chr_type pragma_type ---> passive(id)
185 ; mpassive(list(id))
186 ; already_in_heads
187 ; already_in_heads(id)
188 ; no_history
189 ; history(history_name,list(id)).
190 :- chr_type history_name== any.
192 :- chr_type rule_name == any.
193 :- chr_type rule_nb == natural.
194 :- chr_type id == natural.
196 :- chr_type goal == any.
198 :- chr_type store_type ---> default
199 ; multi_store(list(store_type))
200 ; multi_hash(list(list(int)))
201 ; multi_inthash(list(list(int)))
202 ; global_singleton
203 ; global_ground
204 % EXPERIMENTAL STORES
205 ; var_assoc_store(int,list(int))
206 ; identifier_store(int)
207 ; type_indexed_identifier_store(int,any).
209 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
211 %------------------------------------------------------------------------------%
212 :- chr_constraint chr_source_file/1.
213 :- chr_option(mode,chr_source_file(+)).
214 :- chr_option(type_declaration,chr_source_file(module_name)).
215 %------------------------------------------------------------------------------%
216 chr_source_file(_) \ chr_source_file(_) <=> true.
218 %------------------------------------------------------------------------------%
219 :- chr_constraint get_chr_source_file/1.
220 :- chr_option(mode,get_chr_source_file(-)).
221 :- chr_option(type_declaration,get_chr_source_file(module_name)).
222 %------------------------------------------------------------------------------%
223 chr_source_file(Mod) \ get_chr_source_file(Query)
224 <=> Query = Mod .
225 get_chr_source_file(Query)
226 <=> Query = user.
229 %------------------------------------------------------------------------------%
230 :- chr_constraint target_module/1.
231 :- chr_option(mode,target_module(+)).
232 :- chr_option(type_declaration,target_module(module_name)).
233 %------------------------------------------------------------------------------%
234 target_module(_) \ target_module(_) <=> true.
236 %------------------------------------------------------------------------------%
237 :- chr_constraint get_target_module/1.
238 :- chr_option(mode,get_target_module(-)).
239 :- chr_option(type_declaration,get_target_module(module_name)).
240 %------------------------------------------------------------------------------%
241 target_module(Mod) \ get_target_module(Query)
242 <=> Query = Mod .
243 get_target_module(Query)
244 <=> Query = user.
246 %------------------------------------------------------------------------------%
247 :- chr_constraint line_number/2.
248 :- chr_option(mode,line_number(+,+)).
249 %------------------------------------------------------------------------------%
250 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
252 %------------------------------------------------------------------------------%
253 :- chr_constraint get_line_number/2.
254 :- chr_option(mode,get_line_number(+,-)).
255 %------------------------------------------------------------------------------%
256 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
257 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
259 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
260 :- chr_option(mode,indexed_argument(+,+)).
261 :- chr_option(type_declaration,indexed_argument(constraint,int)).
263 :- chr_constraint is_indexed_argument/2.
264 :- chr_option(mode,is_indexed_argument(+,+)).
265 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
267 :- chr_constraint constraint_mode/2.
268 :- chr_option(mode,constraint_mode(+,+)).
269 :- chr_option(type_declaration,constraint_mode(constraint,list)).
271 :- chr_constraint get_constraint_mode/2.
272 :- chr_option(mode,get_constraint_mode(+,-)).
273 :- chr_option(type_declaration,get_constraint_mode(constraint,list)).
275 :- chr_constraint may_trigger/1.
276 :- chr_option(mode,may_trigger(+)).
277 :- chr_option(type_declaration,may_trigger(constraint)).
279 :- chr_constraint only_ground_indexed_arguments/1.
280 :- chr_option(mode,only_ground_indexed_arguments(+)).
281 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
283 :- chr_constraint none_suspended_on_variables/0.
285 :- chr_constraint are_none_suspended_on_variables/0.
287 :- chr_constraint store_type/2.
288 :- chr_option(mode,store_type(+,+)).
289 :- chr_option(type_declaration,store_type(constraint,store_type)).
291 :- chr_constraint get_store_type/2.
292 :- chr_option(mode,get_store_type(+,?)).
293 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
295 :- chr_constraint update_store_type/2.
296 :- chr_option(mode,update_store_type(+,+)).
297 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
299 :- chr_constraint actual_store_types/2.
300 :- chr_option(mode,actual_store_types(+,+)).
301 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
303 :- chr_constraint assumed_store_type/2.
304 :- chr_option(mode,assumed_store_type(+,+)).
305 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
307 :- chr_constraint validate_store_type_assumption/1.
308 :- chr_option(mode,validate_store_type_assumption(+)).
309 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
311 :- chr_constraint rule_count/1.
312 :- chr_option(mode,rule_count(+)).
313 :- chr_option(type_declaration,rule_count(natural)).
315 :- chr_constraint inc_rule_count/1.
316 :- chr_option(mode,inc_rule_count(-)).
317 :- chr_option(type_declaration,inc_rule_count(natural)).
319 rule_count(_) \ rule_count(_)
320 <=> true.
321 rule_count(C), inc_rule_count(NC)
322 <=> NC is C + 1, rule_count(NC).
323 inc_rule_count(NC)
324 <=> NC = 1, rule_count(NC).
326 :- chr_constraint passive/2.
327 :- chr_option(mode,passive(+,+)).
329 :- chr_constraint is_passive/2.
330 :- chr_option(mode,is_passive(+,+)).
332 :- chr_constraint any_passive_head/1.
333 :- chr_option(mode,any_passive_head(+)).
335 :- chr_constraint new_occurrence/4.
336 :- chr_option(mode,new_occurrence(+,+,+,+)).
338 :- chr_constraint occurrence/5.
339 :- chr_option(mode,occurrence(+,+,+,+,+)).
340 :- chr_type occurrence_type ---> simplification ; propagation.
341 :- chr_option(type_declaration,occurrence(any,any,any,any,occurrence_type)).
343 :- chr_constraint get_occurrence/4.
344 :- chr_option(mode,get_occurrence(+,+,-,-)).
346 :- chr_constraint get_occurrence_from_id/4.
347 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
349 :- chr_constraint max_occurrence/2.
350 :- chr_option(mode,max_occurrence(+,+)).
352 :- chr_constraint get_max_occurrence/2.
353 :- chr_option(mode,get_max_occurrence(+,-)).
355 :- chr_constraint allocation_occurrence/2.
356 :- chr_option(mode,allocation_occurrence(+,+)).
358 :- chr_constraint get_allocation_occurrence/2.
359 :- chr_option(mode,get_allocation_occurrence(+,-)).
361 :- chr_constraint rule/2.
362 :- chr_option(mode,rule(+,+)).
363 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
365 :- chr_constraint get_rule/2.
366 :- chr_option(mode,get_rule(+,-)).
367 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
369 :- chr_constraint least_occurrence/2.
370 :- chr_option(mode,least_occurrence(+,+)).
371 :- chr_option(type_declaration,least_occurrence(any,list)).
373 :- chr_constraint is_least_occurrence/1.
374 :- chr_option(mode,is_least_occurrence(+)).
377 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
378 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
379 is_indexed_argument(_,_) <=> fail.
381 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
383 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
384 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
385 Q = Mode.
386 get_constraint_mode(FA,Q) <=>
387 FA = _ / N,
388 replicate(N,(?),Q).
390 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
392 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
393 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
394 nth1(I,Mode,M),
395 M \== (+) |
396 is_stored(FA).
397 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
399 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
400 <=>
401 nth1(I,Mode,M),
402 M \== (+)
403 |
404 fail.
405 only_ground_indexed_arguments(_) <=>
406 true.
408 none_suspended_on_variables \ none_suspended_on_variables <=> true.
409 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
410 are_none_suspended_on_variables <=> fail.
411 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
413 store_type(FA,Store) \ get_store_type(FA,Query)
414 <=> Query = Store.
416 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
417 <=> Query = Store.
418 get_store_type(_,Query)
419 <=> Query = default.
421 actual_store_types(C,STs) \ update_store_type(C,ST)
422 <=> member(ST,STs) | true.
423 update_store_type(C,ST), actual_store_types(C,STs)
424 <=>
425 actual_store_types(C,[ST|STs]).
426 update_store_type(C,ST)
427 <=>
428 actual_store_types(C,[ST]).
430 % refine store type assumption
431 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
432 <=>
433 store_type(C,multi_store(STs)).
434 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
435 <=>
436 store_type(C,multi_store(STs)).
437 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
438 <=>
439 chr_pp_flag(debugable,on)
440 |
441 store_type(C,default).
442 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
443 <=> store_type(C,global_ground).
444 validate_store_type_assumption(C)
445 <=> true.
447 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
448 passive(R,ID) \ passive(R,ID) <=> true.
450 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
451 is_passive(_,_) <=> fail.
453 passive(RuleNb,_) \ any_passive_head(RuleNb)
454 <=> true.
455 any_passive_head(_)
456 <=> fail.
457 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
459 max_occurrence(C,N) \ max_occurrence(C,M)
460 <=> N >= M | true.
462 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
463 NO is MO + 1,
464 occurrence(C,NO,RuleNb,ID,Type),
465 max_occurrence(C,NO).
466 new_occurrence(C,RuleNb,ID,_) <=>
467 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
469 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
470 <=> Q = MON.
471 get_max_occurrence(C,Q)
472 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
474 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
475 <=> Rule = QRule, ID = QID.
476 get_occurrence(C,O,_,_)
477 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
479 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
480 <=> QC = C, QON = ON.
481 get_occurrence_from_id(C,O,_,_)
482 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
484 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
485 % Late allocation
487 late_allocation_analysis(Cs) :-
488 ( chr_pp_flag(late_allocation,on) ->
489 maplist(late_allocation, Cs)
490 ;
491 true
492 ).
494 late_allocation(C) :- late_allocation(C,0).
495 late_allocation(C,O) :- allocation_occurrence(C,O), !.
496 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
498 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
500 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
502 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
503 \+ is_passive(RuleNb,Id),
504 Type == propagation,
505 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
506 true
507 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
508 is_observed(C,O)
509 ; is_least_occurrence(RuleNb) -> % propagation rule
510 is_observed(C,O)
511 ;
512 true
513 ).
515 stored_in_guard_before_next_kept_occurrence(C,O) :-
516 chr_pp_flag(store_in_guards, on),
517 NO is O + 1,
518 stored_in_guard_lookahead(C,NO).
520 :- chr_constraint stored_in_guard_lookahead/2.
521 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
523 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
524 NO is O + 1, stored_in_guard_lookahead(C,NO).
525 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
526 Type == simplification,
527 ( is_stored_in_guard(C,RuleNb) ->
528 true
529 ;
530 NO is O + 1, stored_in_guard_lookahead(C,NO)
531 ).
532 stored_in_guard_lookahead(_,_) <=> fail.
535 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
536 \ least_occurrence(RuleNb,[ID|IDs])
537 <=> AO >= O, \+ may_trigger(C) |
538 least_occurrence(RuleNb,IDs).
539 rule(RuleNb,Rule), passive(RuleNb,ID)
540 \ least_occurrence(RuleNb,[ID|IDs])
541 <=> least_occurrence(RuleNb,IDs).
543 rule(RuleNb,Rule)
544 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
545 least_occurrence(RuleNb,IDs).
547 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
548 <=> true.
549 is_least_occurrence(_)
550 <=> fail.
552 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
553 <=> Q = O.
554 get_allocation_occurrence(_,Q)
555 <=> chr_pp_flag(late_allocation,off), Q=0.
556 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
558 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
559 <=> Q = Rule.
560 get_rule(_,_)
561 <=> fail.
563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
565 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
566 %
567 % Default store constraint index assignment.
569 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
570 :- chr_option(mode,constraint_index(+,+)).
571 :- chr_option(type_declaration,constraint_index(constraint,int)).
573 :- chr_constraint get_constraint_index/2.
574 :- chr_option(mode,get_constraint_index(+,-)).
575 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
577 :- chr_constraint get_indexed_constraint/2.
578 :- chr_option(mode,get_indexed_constraint(+,-)).
579 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
581 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
582 :- chr_option(mode,max_constraint_index(+)).
583 :- chr_option(type_declaration,max_constraint_index(int)).
585 :- chr_constraint get_max_constraint_index/1.
586 :- chr_option(mode,get_max_constraint_index(-)).
587 :- chr_option(type_declaration,get_max_constraint_index(int)).
589 constraint_index(C,Index) \ get_constraint_index(C,Query)
590 <=> Query = Index.
591 get_constraint_index(C,Query)
592 <=> fail.
594 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
595 <=> Q = C.
596 get_indexed_constraint(Index,Q)
597 <=> fail.
599 max_constraint_index(Index) \ get_max_constraint_index(Query)
600 <=> Query = Index.
601 get_max_constraint_index(Query)
602 <=> Query = 0.
604 set_constraint_indices(Constraints) :-
605 set_constraint_indices(Constraints,1).
606 set_constraint_indices([],M) :-
607 N is M - 1,
608 max_constraint_index(N).
609 set_constraint_indices([C|Cs],N) :-
610 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
611 ; get_store_type(C,var_assoc_store(_,_))) ->
612 constraint_index(C,N),
613 M is N + 1,
614 set_constraint_indices(Cs,M)
615 ;
616 set_constraint_indices(Cs,N)
617 ).
619 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
620 % Identifier Indexes
622 :- chr_constraint identifier_size/1.
623 :- chr_option(mode,identifier_size(+)).
624 :- chr_option(type_declaration,identifier_size(natural)).
626 identifier_size(_) \ identifier_size(_)
627 <=>
628 true.
630 :- chr_constraint get_identifier_size/1.
631 :- chr_option(mode,get_identifier_size(-)).
632 :- chr_option(type_declaration,get_identifier_size(natural)).
634 identifier_size(Size) \ get_identifier_size(Q)
635 <=>
636 Q = Size.
638 get_identifier_size(Q)
639 <=>
640 Q = 1.
642 :- chr_constraint identifier_index/3.
643 :- chr_option(mode,identifier_index(+,+,+)).
644 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
646 identifier_index(C,I,_) \ identifier_index(C,I,_)
647 <=>
648 true.
650 :- chr_constraint get_identifier_index/3.
651 :- chr_option(mode,get_identifier_index(+,+,-)).
652 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
654 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
655 <=>
656 Q = II.
657 identifier_size(Size), get_identifier_index(C,I,Q)
658 <=>
659 NSize is Size + 1,
660 identifier_index(C,I,NSize),
661 identifier_size(NSize),
662 Q = NSize.
663 get_identifier_index(C,I,Q)
664 <=>
665 identifier_index(C,I,2),
666 identifier_size(2),
667 Q = 2.
669 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
670 % Type Indexed Identifier Indexes
672 :- chr_constraint type_indexed_identifier_size/2.
673 :- chr_option(mode,type_indexed_identifier_size(+,+)).
674 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
676 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
677 <=>
678 true.
680 :- chr_constraint get_type_indexed_identifier_size/2.
681 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
682 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
684 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
685 <=>
686 Q = Size.
688 get_type_indexed_identifier_size(IndexType,Q)
689 <=>
690 Q = 1.
692 :- chr_constraint type_indexed_identifier_index/4.
693 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
694 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
696 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
697 <=>
698 true.
700 :- chr_constraint get_type_indexed_identifier_index/4.
701 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
702 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
704 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
705 <=>
706 Q = II.
707 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
708 <=>
709 NSize is Size + 1,
710 type_indexed_identifier_index(IndexType,C,I,NSize),
711 type_indexed_identifier_size(IndexType,NSize),
712 Q = NSize.
713 get_type_indexed_identifier_index(IndexType,C,I,Q)
714 <=>
715 type_indexed_identifier_index(IndexType,C,I,2),
716 type_indexed_identifier_size(IndexType,2),
717 Q = 2.
719 type_indexed_identifier_structure(IndexType,Structure) :-
720 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
721 get_type_indexed_identifier_size(IndexType,Arity),
722 functor(Structure,Functor,Arity).
723 type_indexed_identifier_name(IndexType,Prefix,Name) :-
724 ( atom(IndexType) ->
725 IndexTypeName = IndexType
726 ;
727 term_to_atom(IndexType,IndexTypeName)
728 ),
729 atom_concat_list([Prefix,'_',IndexTypeName],Name).
731 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
736 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
737 %%
738 %% Translation
740 chr_translate(Declarations,NewDeclarations) :-
741 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
743 chr_translate_line_info(Declarations,File,NewDeclarations) :-
744 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',[]),
745 init_chr_pp_flags,
746 chr_source_file(File),
747 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
748 chr_compiler_options:sanity_check,
749 check_declared_constraints(Constraints0),
750 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
751 add_constraints(Constraints),
752 add_rules(Rules1),
753 generate_never_stored_rules(Constraints,NewRules),
754 add_rules(NewRules),
755 append(Rules1,NewRules,Rules),
756 % start analysis
757 check_rules(Rules,Constraints),
758 time('type checking',chr_translate:static_type_check),
759 add_occurrences(Rules),
760 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
761 time('set semantics',chr_translate:set_semantics_rules(Rules)),
762 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
763 time('guard simplification',chr_translate:guard_simplification),
764 time('late storage',chr_translate:storage_analysis(Constraints)),
765 time('observation',chr_translate:observation_analysis(Constraints)),
766 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
767 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
768 partial_wake_analysis,
769 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
770 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
771 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
772 % end analysis
773 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
774 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
775 phase_end(validate_store_type_assumptions),
776 used_states_known,
777 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
778 insert_declarations(OtherClauses, Clauses0),
779 chr_module_declaration(CHRModuleDeclaration),
780 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
781 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
782 append([Clauses0,GeneratedClauses], NewDeclarations).
784 store_management_preds(Constraints,Clauses) :-
785 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
786 generate_attr_unify_hook(AttrUnifyHookClauses),
787 generate_attach_increment(AttachIncrementClauses),
788 generate_extra_clauses(Constraints,ExtraClauses),
789 generate_insert_delete_constraints(Constraints,DeleteClauses),
790 generate_attach_code(Constraints,StoreClauses),
791 generate_counter_code(CounterClauses),
792 generate_dynamic_type_check_clauses(TypeCheckClauses),
793 append([AttachAConstraintClauses
794 ,AttachIncrementClauses
795 ,AttrUnifyHookClauses
796 ,ExtraClauses
797 ,DeleteClauses
798 ,StoreClauses
799 ,CounterClauses
800 ,TypeCheckClauses
801 ]
802 ,Clauses).
805 insert_declarations(Clauses0, Clauses) :-
806 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
807 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
809 auxiliary_module(chr_hashtable_store).
810 auxiliary_module(chr_integertable_store).
811 auxiliary_module(chr_assoc_store).
813 generate_counter_code(Clauses) :-
814 ( chr_pp_flag(store_counter,on) ->
815 Clauses = [
816 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
817 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
818 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
819 (:- '$counter_init'('$insert_counter')),
820 (:- '$counter_init'('$delete_counter')),
821 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
822 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
823 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
824 ]
825 ;
826 Clauses = []
827 ).
829 % for systems with multifile declaration
830 chr_module_declaration(CHRModuleDeclaration) :-
831 get_target_module(Mod),
832 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
833 CHRModuleDeclaration = [
834 (:- multifile chr:'$chr_module'/1),
835 chr:'$chr_module'(Mod)
836 ]
837 ;
838 CHRModuleDeclaration = []
839 ).
842 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
843 %%
844 %% Partitioning of clauses into constraint declarations, chr rules and other
845 %% clauses
847 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
848 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
849 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
850 partition_clauses([],[],[],[]).
851 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
852 ( parse_rule(Clause,Rule) ->
853 ConstraintDeclarations = RestConstraintDeclarations,
854 Rules = [Rule|RestRules],
855 OtherClauses = RestOtherClauses
856 ; is_declaration(Clause,ConstraintDeclaration) ->
857 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
858 Rules = RestRules,
859 OtherClauses = RestOtherClauses
860 ; is_module_declaration(Clause,Mod) ->
861 target_module(Mod),
862 ConstraintDeclarations = RestConstraintDeclarations,
863 Rules = RestRules,
864 OtherClauses = [Clause|RestOtherClauses]
865 ; is_type_definition(Clause) ->
866 ConstraintDeclarations = RestConstraintDeclarations,
867 Rules = RestRules,
868 OtherClauses = RestOtherClauses
869 ; Clause = (handler _) ->
870 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
871 ConstraintDeclarations = RestConstraintDeclarations,
872 Rules = RestRules,
873 OtherClauses = RestOtherClauses
874 ; Clause = (rules _) ->
875 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
876 ConstraintDeclarations = RestConstraintDeclarations,
877 Rules = RestRules,
878 OtherClauses = RestOtherClauses
879 ; Clause = option(OptionName,OptionValue) ->
880 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
881 handle_option(OptionName,OptionValue),
882 ConstraintDeclarations = RestConstraintDeclarations,
883 Rules = RestRules,
884 OtherClauses = RestOtherClauses
885 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
886 handle_option(OptionName,OptionValue),
887 ConstraintDeclarations = RestConstraintDeclarations,
888 Rules = RestRules,
889 OtherClauses = RestOtherClauses
890 ; Clause = ('$chr_compiled_with_version'(_)) ->
891 ConstraintDeclarations = RestConstraintDeclarations,
892 Rules = RestRules,
893 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
894 ; ConstraintDeclarations = RestConstraintDeclarations,
895 Rules = RestRules,
896 OtherClauses = [Clause|RestOtherClauses]
897 ),
898 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
900 '$chr_compiled_with_version'(2).
902 is_declaration(D, Constraints) :- %% constraint declaration
903 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
904 conj2list(Cs,Constraints0)
905 ;
906 ( D = (:- Decl) ->
907 Decl =.. [constraints,Cs]
908 ;
909 D =.. [constraints,Cs]
910 ),
911 conj2list(Cs,Constraints0),
912 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
913 ),
914 extract_type_mode(Constraints0,Constraints).
916 extract_type_mode([],[]).
917 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
918 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
919 ( C0 = C # Annotation ->
920 functor(C,F,A),
921 extract_annotation(Annotation,F/A)
922 ;
923 C0 = C,
924 functor(C,F,A)
925 ),
926 ConstraintSymbol = F/A,
927 C =.. [_|Args],
928 extract_types_and_modes(Args,ArgTypes,ArgModes),
929 constraint_type(ConstraintSymbol,ArgTypes),
930 constraint_mode(ConstraintSymbol,ArgModes),
931 extract_type_mode(R,R2).
933 extract_annotation(stored,Symbol) :-
934 stored_assertion(Symbol).
935 extract_annotation(default(Goal),Symbol) :-
936 never_stored_default(Symbol,Goal).
938 extract_types_and_modes([],[],[]).
939 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
940 extract_type_and_mode(X,T,M),
941 extract_types_and_modes(R,R2,R3).
943 extract_type_and_mode(+(T),T,(+)) :- !.
944 extract_type_and_mode(?(T),T,(?)) :- !.
945 extract_type_and_mode(-(T),T,(-)) :- !.
946 extract_type_and_mode((+),any,(+)) :- !.
947 extract_type_and_mode((?),any,(?)) :- !.
948 extract_type_and_mode((-),any,(-)) :- !.
949 extract_type_and_mode(Illegal,_,_) :-
950 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
952 is_type_definition(Declaration) :-
953 ( Declaration = (:- TDef) ->
954 true
955 ;
956 Declaration = TDef
957 ),
958 TDef =.. [chr_type,TypeDef],
959 ( TypeDef = (Name ---> Def) ->
960 tdisj2list(Def,DefList),
961 type_definition(Name,DefList)
962 ; TypeDef = (Alias == Name) ->
963 type_alias(Alias,Name)
964 ;
965 type_definition(TypeDef,[]),
966 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
967 ).
969 %% tdisj2list(+Goal,-ListOfGoals) is det.
970 %
971 % no removal of fails, e.g. :- type bool ---> true ; fail.
972 tdisj2list(Conj,L) :-
973 tdisj2list(Conj,L,[]).
975 tdisj2list(Conj,L,T) :-
976 Conj = (G1;G2), !,
977 tdisj2list(G1,L,T1),
978 tdisj2list(G2,T1,T).
979 tdisj2list(G,[G | T],T).
982 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
983 %% parse_rule(+term,-pragma_rule) is semidet.
984 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
985 parse_rule(RI,R) :- %% name @ rule
986 RI = (Name @ RI2), !,
987 rule(RI2,yes(Name),R).
988 parse_rule(RI,R) :-
989 rule(RI,no,R).
991 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
992 %% parse_rule(+term,-pragma_rule) is semidet.
993 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
994 rule(RI,Name,R) :-
995 RI = (RI2 pragma P), !, %% pragmas
996 ( var(P) ->
997 Ps = [_] % intercept variable
998 ;
999 conj2list(P,Ps)
1000 ),
1001 inc_rule_count(RuleCount),
1002 R = pragma(R1,IDs,Ps,Name,RuleCount),
1003 is_rule(RI2,R1,IDs,R).
1004 rule(RI,Name,R) :-
1005 inc_rule_count(RuleCount),
1006 R = pragma(R1,IDs,[],Name,RuleCount),
1007 is_rule(RI,R1,IDs,R).
1009 is_rule(RI,R,IDs,RC) :- %% propagation rule
1010 RI = (H ==> B), !,
1011 conj2list(H,Head2i),
1012 get_ids(Head2i,IDs2,Head2,RC),
1013 IDs = ids([],IDs2),
1014 ( B = (G | RB) ->
1015 R = rule([],Head2,G,RB)
1016 ;
1017 R = rule([],Head2,true,B)
1018 ).
1019 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1020 RI = (H <=> B), !,
1021 ( B = (G | RB) ->
1022 Guard = G,
1023 Body = RB
1024 ; Guard = true,
1025 Body = B
1026 ),
1027 ( H = (H1 \ H2) ->
1028 conj2list(H1,Head2i),
1029 conj2list(H2,Head1i),
1030 get_ids(Head2i,IDs2,Head2,0,N,RC),
1031 get_ids(Head1i,IDs1,Head1,N,_,RC),
1032 IDs = ids(IDs1,IDs2)
1033 ; conj2list(H,Head1i),
1034 Head2 = [],
1035 get_ids(Head1i,IDs1,Head1,RC),
1036 IDs = ids(IDs1,[])
1037 ),
1038 R = rule(Head1,Head2,Guard,Body).
1040 get_ids(Cs,IDs,NCs,RC) :-
1041 get_ids(Cs,IDs,NCs,0,_,RC).
1043 get_ids([],[],[],N,N,_).
1044 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1045 ( C = (NC # N1) ->
1046 ( var(N1) ->
1047 N1 = N
1048 ;
1049 check_direct_pragma(N1,N,RC)
1050 )
1051 ;
1052 NC = C
1053 ),
1054 M is N + 1,
1055 get_ids(Cs,IDs,NCs, M,NN,RC).
1057 check_direct_pragma(passive,Id,PragmaRule) :- !,
1058 PragmaRule = pragma(_,_,_,_,RuleNb),
1059 passive(RuleNb,Id).
1060 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1061 ( direct_pragma(FullPragma),
1062 atom_concat(Abbrev,Remainder,FullPragma) ->
1063 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1064 ;
1065 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1066 ).
1068 direct_pragma(passive).
1070 is_module_declaration((:- module(Mod)),Mod).
1071 is_module_declaration((:- module(Mod,_)),Mod).
1073 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1075 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1076 % Add constraints
1077 add_constraints([]).
1078 add_constraints([C|Cs]) :-
1079 max_occurrence(C,0),
1080 C = _/A,
1081 length(Mode,A),
1082 set_elems(Mode,?),
1083 constraint_mode(C,Mode),
1084 add_constraints(Cs).
1086 % Add rules
1087 add_rules([]).
1088 add_rules([Rule|Rules]) :-
1089 Rule = pragma(_,_,_,_,RuleNb),
1090 rule(RuleNb,Rule),
1091 add_rules(Rules).
1093 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1095 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1096 %% Some input verification:
1098 check_declared_constraints(Constraints) :-
1099 check_declared_constraints(Constraints,[]).
1101 check_declared_constraints([],_).
1102 check_declared_constraints([C|Cs],Acc) :-
1103 ( memberchk_eq(C,Acc) ->
1104 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1105 ;
1106 true
1107 ),
1108 check_declared_constraints(Cs,[C|Acc]).
1110 %% - all constraints in heads are declared constraints
1111 %% - all passive pragmas refer to actual head constraints
1113 check_rules([],_).
1114 check_rules([PragmaRule|Rest],Decls) :-
1115 check_rule(PragmaRule,Decls),
1116 check_rules(Rest,Decls).
1118 check_rule(PragmaRule,Decls) :-
1119 check_rule_indexing(PragmaRule),
1120 check_trivial_propagation_rule(PragmaRule),
1121 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1122 Rule = rule(H1,H2,_,_),
1123 append(H1,H2,HeadConstraints),
1124 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1125 check_pragmas(Pragmas,PragmaRule).
1127 % Make all heads passive in trivial propagation rule
1128 % ... ==> ... | true.
1129 check_trivial_propagation_rule(PragmaRule) :-
1130 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1131 ( Rule = rule([],_,_,true) ->
1132 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1133 set_all_passive(RuleNb)
1134 ;
1135 true
1136 ).
1138 check_head_constraints([],_,_).
1139 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1140 functor(Constr,F,A),
1141 ( member(F/A,Decls) ->
1142 check_head_constraints(Rest,Decls,PragmaRule)
1143 ;
1144 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1145 ).
1147 check_pragmas([],_).
1148 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1149 check_pragma(Pragma,PragmaRule),
1150 check_pragmas(Pragmas,PragmaRule).
1152 check_pragma(Pragma,PragmaRule) :-
1153 var(Pragma), !,
1154 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1155 check_pragma(passive(ID), PragmaRule) :-
1156 !,
1157 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1158 ( memberchk_eq(ID,IDs1) ->
1159 true
1160 ; memberchk_eq(ID,IDs2) ->
1161 true
1162 ;
1163 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1164 ),
1165 passive(RuleNb,ID).
1167 check_pragma(mpassive(IDs), PragmaRule) :-
1168 !,
1169 PragmaRule = pragma(_,_,_,_,RuleNb),
1170 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1171 maplist(passive(RuleNb),IDs).
1173 check_pragma(Pragma, PragmaRule) :-
1174 Pragma = already_in_heads,
1175 !,
1176 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1178 check_pragma(Pragma, PragmaRule) :-
1179 Pragma = already_in_head(_),
1180 !,
1181 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1183 check_pragma(Pragma, PragmaRule) :-
1184 Pragma = no_history,
1185 !,
1186 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1187 PragmaRule = pragma(_,_,_,_,N),
1188 no_history(N).
1190 check_pragma(Pragma, PragmaRule) :-
1191 Pragma = history(HistoryName,IDs),
1192 !,
1193 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1194 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1195 ( IDs1 \== [] ->
1196 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1197 ; \+ atom(HistoryName) ->
1198 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1199 ; \+ is_set(IDs) ->
1200 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1201 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1202 history(RuleNb,HistoryName,IDs)
1203 ;
1204 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1205 ).
1206 check_pragma(Pragma,PragmaRule) :-
1207 Pragma = line_number(LineNumber),
1208 !,
1209 PragmaRule = pragma(_,_,_,_,RuleNb),
1210 line_number(RuleNb,LineNumber).
1212 check_history_pragma_ids([], _, _).
1213 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1214 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1215 check_history_pragma_ids(IDs,IDs1,IDs2).
1217 check_pragma(Pragma,PragmaRule) :-
1218 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1220 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1221 %% no_history(+RuleNb) is det.
1222 :- chr_constraint no_history/1.
1223 :- chr_option(mode,no_history(+)).
1224 :- chr_option(type_declaration,no_history(int)).
1226 %% has_no_history(+RuleNb) is semidet.
1227 :- chr_constraint has_no_history/1.
1228 :- chr_option(mode,has_no_history(+)).
1229 :- chr_option(type_declaration,has_no_history(int)).
1231 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1232 has_no_history(_) <=> fail.
1234 :- chr_constraint history/3.
1235 :- chr_option(mode,history(+,+,+)).
1236 :- chr_option(type_declaration,history(any,any,list)).
1238 :- chr_constraint named_history/3.
1240 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1241 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1243 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1244 length(IDs1,L1), length(IDs2,L2),
1245 ( L1 \== L2 ->
1246 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1247 ;
1248 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1249 ).
1251 test_named_history_id_pairs(_, [], _, []).
1252 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1253 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1254 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1256 :- chr_constraint test_named_history_id_pair/4.
1257 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1259 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1260 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1261 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1262 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1264 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1265 named_history(_,_,_) <=> fail.
1267 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1270 format_rule(PragmaRule) :-
1271 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1272 ( MaybeName = yes(Name) ->
1273 write('rule '), write(Name)
1274 ;
1275 write('rule number '), write(RuleNumber)
1276 ),
1277 get_line_number(RuleNumber,LineNumber),
1278 write(' (line '),
1279 write(LineNumber),
1280 write(')').
1282 check_rule_indexing(PragmaRule) :-
1283 PragmaRule = pragma(Rule,_,_,_,_),
1284 Rule = rule(H1,H2,G,_),
1285 term_variables(H1-H2,HeadVars),
1286 remove_anti_monotonic_guards(G,HeadVars,NG),
1287 check_indexing(H1,NG-H2),
1288 check_indexing(H2,NG-H1),
1289 % EXPERIMENT
1290 ( chr_pp_flag(term_indexing,on) ->
1291 term_variables(NG,GuardVariables),
1292 append(H1,H2,Heads),
1293 check_specs_indexing(Heads,GuardVariables,Specs)
1294 ;
1295 true
1296 ).
1298 :- chr_constraint indexing_spec/2.
1299 :- chr_option(mode,indexing_spec(+,+)).
1301 :- chr_constraint get_indexing_spec/2.
1302 :- chr_option(mode,get_indexing_spec(+,-)).
1305 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1306 get_indexing_spec(_,Spec) <=> Spec = [].
1308 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1309 <=>
1310 append(Specs1,Specs2,Specs),
1311 indexing_spec(FA,Specs).
1313 remove_anti_monotonic_guards(G,Vars,NG) :-
1314 conj2list(G,GL),
1315 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1316 list2conj(NGL,NG).
1318 remove_anti_monotonic_guard_list([],_,[]).
1319 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1320 ( G = var(X), memberchk_eq(X,Vars) ->
1321 NGs = RGs
1322 % TODO: this is not correct
1323 % ; G = functor(Term,Functor,Arity), % isotonic
1324 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1325 % NGs = RGs
1326 ;
1327 NGs = [G|RGs]
1328 ),
1329 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1331 check_indexing([],_).
1332 check_indexing([Head|Heads],Other) :-
1333 functor(Head,F,A),
1334 Head =.. [_|Args],
1335 term_variables(Heads-Other,OtherVars),
1336 check_indexing(Args,1,F/A,OtherVars),
1337 check_indexing(Heads,[Head|Other]).
1339 check_indexing([],_,_,_).
1340 check_indexing([Arg|Args],I,FA,OtherVars) :-
1341 ( is_indexed_argument(FA,I) ->
1342 true
1343 ; nonvar(Arg) ->
1344 indexed_argument(FA,I)
1345 ; % var(Arg) ->
1346 term_variables(Args,ArgsVars),
1347 append(ArgsVars,OtherVars,RestVars),
1348 ( memberchk_eq(Arg,RestVars) ->
1349 indexed_argument(FA,I)
1350 ;
1351 true
1352 )
1353 ),
1354 J is I + 1,
1355 term_variables(Arg,NVars),
1356 append(NVars,OtherVars,NOtherVars),
1357 check_indexing(Args,J,FA,NOtherVars).
1359 check_specs_indexing([],_,[]).
1360 check_specs_indexing([Head|Heads],Variables,Specs) :-
1361 Specs = [Spec|RSpecs],
1362 term_variables(Heads,OtherVariables,Variables),
1363 check_spec_indexing(Head,OtherVariables,Spec),
1364 term_variables(Head,NVariables,Variables),
1365 check_specs_indexing(Heads,NVariables,RSpecs).
1367 check_spec_indexing(Head,OtherVariables,Spec) :-
1368 functor(Head,F,A),
1369 Spec = spec(F,A,ArgSpecs),
1370 Head =.. [_|Args],
1371 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1372 indexing_spec(F/A,[ArgSpecs]).
1374 check_args_spec_indexing([],_,_,[]).
1375 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1376 term_variables(Args,Variables,OtherVariables),
1377 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1378 ArgSpecs = [ArgSpec|RArgSpecs]
1379 ;
1380 ArgSpecs = RArgSpecs
1381 ),
1382 J is I + 1,
1383 term_variables(Arg,NOtherVariables,OtherVariables),
1384 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1386 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1387 ( var(Arg) ->
1388 memberchk_eq(Arg,Variables),
1389 ArgSpec = specinfo(I,any,[])
1390 ;
1391 functor(Arg,F,A),
1392 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1393 Arg =.. [_|Args],
1394 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1395 ).
1397 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1399 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1400 % Occurrences
1402 add_occurrences([]).
1403 add_occurrences([Rule|Rules]) :-
1404 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1405 add_occurrences(H1,IDs1,simplification,Nb),
1406 add_occurrences(H2,IDs2,propagation,Nb),
1407 add_occurrences(Rules).
1409 add_occurrences([],[],_,_).
1410 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1411 functor(H,F,A),
1412 FA = F/A,
1413 new_occurrence(FA,RuleNb,ID,Type),
1414 add_occurrences(Hs,IDs,Type,RuleNb).
1416 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1418 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1419 % Observation Analysis
1420 %
1421 % CLASSIFICATION
1422 %
1423 %
1424 %
1425 %
1426 %
1427 %
1429 :- chr_constraint observation_analysis/1.
1430 :- chr_option(mode, observation_analysis(+)).
1432 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1433 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1434 ( chr_pp_flag(store_in_guards, on) ->
1435 observation_analysis(RuleNb, Guard, guard, Cs)
1436 ;
1437 true
1438 ),
1439 observation_analysis(RuleNb, Body, body, Cs)
1441 pragma passive(Id).
1442 observation_analysis(_) <=> true.
1444 observation_analysis(RuleNb, Term, GB, Cs) :-
1445 ( all_spawned(RuleNb,GB) ->
1446 true
1447 ; var(Term) ->
1448 spawns_all(RuleNb,GB)
1449 ; Term = true ->
1450 true
1451 ; Term = fail ->
1452 true
1453 ; Term = '!' ->
1454 true
1455 ; Term = (T1,T2) ->
1456 observation_analysis(RuleNb,T1,GB,Cs),
1457 observation_analysis(RuleNb,T2,GB,Cs)
1458 ; Term = (T1;T2) ->
1459 observation_analysis(RuleNb,T1,GB,Cs),
1460 observation_analysis(RuleNb,T2,GB,Cs)
1461 ; Term = (T1->T2) ->
1462 observation_analysis(RuleNb,T1,GB,Cs),
1463 observation_analysis(RuleNb,T2,GB,Cs)
1464 ; Term = (\+ T) ->
1465 observation_analysis(RuleNb,T,GB,Cs)
1466 ; functor(Term,F,A), member(F/A,Cs) ->
1467 spawns(RuleNb,GB,F/A)
1468 ; Term = (_ = _) ->
1469 spawns_all_triggers(RuleNb,GB)
1470 ; Term = (_ is _) ->
1471 spawns_all_triggers(RuleNb,GB)
1472 ; builtin_binds_b(Term,Vars) ->
1473 ( Vars == [] ->
1474 true
1475 ;
1476 spawns_all_triggers(RuleNb,GB)
1477 )
1478 ;
1479 spawns_all(RuleNb,GB)
1480 ).
1482 :- chr_constraint spawns/3.
1483 :- chr_option(mode, spawns(+,+,+)).
1484 :- chr_type spawns_type ---> guard ; body.
1485 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1487 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1488 :- chr_option(mode, spawns_all(+,+)).
1489 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1490 :- chr_option(mode, spawns_all_triggers(+,+)).
1491 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1493 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1494 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1495 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1496 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1497 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1498 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1500 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1501 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1502 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1503 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1505 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1506 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1508 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1509 \
1510 spawns(RuleNb1,GB,C1)
1511 <=>
1512 \+ is_passive(RuleNb2,O)
1513 |
1514 spawns_all(RuleNb1,GB)
1515 pragma
1516 passive(Id).
1518 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1519 ==>
1520 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1521 \+ is_passive(RuleNb2,O), may_trigger(C1)
1522 |
1523 spawns_all_triggers_implies_spawns_all
1524 pragma
1525 passive(Id).
1527 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1528 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1529 spawns_all_triggers_implies_spawns_all \
1530 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1532 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1533 \
1534 spawns(RuleNb1,GB,C1)
1535 <=>
1536 may_trigger(C1),
1537 \+ is_passive(RuleNb2,O)
1538 |
1539 spawns_all_triggers(RuleNb1,GB)
1540 pragma
1541 passive(Id).
1543 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1544 spawns(RuleNb1,GB,C1)
1545 ==>
1546 \+ may_trigger(C1),
1547 \+ is_passive(RuleNb2,O)
1548 |
1549 spawns_all_triggers(RuleNb1,GB)
1550 pragma
1551 passive(Id).
1553 % a bit dangerous this rule: could start propagating too much too soon?
1554 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1555 spawns(RuleNb1,GB,C1)
1556 ==>
1557 RuleNb1 \== RuleNb2, C1 \== C2,
1558 \+ is_passive(RuleNb2,O)
1559 |
1560 spawns(RuleNb1,GB,C2)
1561 pragma
1562 passive(Id).
1564 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1565 spawns_all_triggers(RuleNb1,GB)
1566 ==>
1567 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1568 |
1569 spawns(RuleNb1,GB,C2)
1570 pragma
1571 passive(Id).
1574 :- chr_constraint all_spawned/2.
1575 :- chr_option(mode, all_spawned(+,+)).
1576 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1577 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1578 all_spawned(RuleNb,GB) <=> fail.
1581 % Overview of the supported queries:
1582 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1583 % only succeeds if the occurrence is observed by the
1584 % guard resp. body (depending on the last argument) of its rule
1585 % is_observed(+functor/artiy, +occurrence_number, -)
1586 % succeeds if the occurrence is observed by either the guard or
1587 % the body of its rule
1588 % NOTE: the last argument is NOT bound by this query
1589 %
1590 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1591 % succeeds if the given constraint is observed by the given
1592 % guard resp. body
1593 % do_is_observed(+functor/artiy,+rule_number)
1594 % succeeds if the given constraint is observed by the given
1595 % rule (either its guard or its body)
1598 is_observed(C,O) :-
1599 is_observed(C,O,_),
1600 ai_is_observed(C,O).
1602 is_stored_in_guard(C,RuleNb) :-
1603 chr_pp_flag(store_in_guards, on),
1604 do_is_observed(C,RuleNb,guard).
1606 :- chr_constraint is_observed/3.
1607 :- chr_option(mode, is_observed(+,+,+)).
1608 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1609 is_observed(_,_,_) <=> fail. % this will not happen in practice
1612 :- chr_constraint do_is_observed/3.
1613 :- chr_option(mode, do_is_observed(+,+,+)).
1614 :- chr_constraint do_is_observed/2.
1615 :- chr_option(mode, do_is_observed(+,+)).
1617 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1619 % (1) spawns_all
1620 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1621 % and some non-passive occurrence of some (possibly other) constraint
1622 % exists in a rule (could be same rule) with at least one occurrence of C
1624 spawns_all(RuleNb,GB),
1625 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1626 \
1627 do_is_observed(C,RuleNb,GB)
1628 <=>
1629 \+ is_passive(RuleNb2,O)
1630 |
1631 true.
1633 spawns_all(RuleNb,_),
1634 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1635 \
1636 do_is_observed(C,RuleNb)
1637 <=>
1638 \+ is_passive(RuleNb2,O)
1639 |
1640 true.
1642 % (2) spawns
1643 % a constraint C is observed if the GB of the rule it occurs in spawns a
1644 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1645 % as an occurrence of C
1647 spawns(RuleNb,GB,C2),
1648 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1649 \
1650 do_is_observed(C,RuleNb,GB)
1651 <=>
1652 \+ is_passive(RuleNb2,O)
1653 |
1654 true.
1656 spawns(RuleNb,_,C2),
1657 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1658 \
1659 do_is_observed(C,RuleNb)
1660 <=>
1661 \+ is_passive(RuleNb2,O)
1662 |
1663 true.
1665 % (3) spawns_all_triggers
1666 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1667 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1668 % exists in a rule (could be same rule) with at least one occurrence of C
1670 spawns_all_triggers(RuleNb,GB),
1671 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1672 \
1673 do_is_observed(C,RuleNb,GB)
1674 <=>
1675 \+ is_passive(RuleNb2,O), may_trigger(C2)
1676 |
1677 true.
1679 spawns_all_triggers(RuleNb,_),
1680 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1681 \
1682 do_is_observed(C,RuleNb)
1683 <=>
1684 \+ is_passive(RuleNb2,O), may_trigger(C2)
1685 |
1686 true.
1688 % (4) conservativeness
1689 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1690 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1693 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1695 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1697 %%
1698 %% Generated predicates
1699 %% attach_$CONSTRAINT
1700 %% attach_increment
1701 %% detach_$CONSTRAINT
1702 %% attr_unify_hook
1704 %% attach_$CONSTRAINT
1705 generate_attach_detach_a_constraint_all([],[]).
1706 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1707 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1708 generate_attach_a_constraint(Constraint,Clauses1),
1709 generate_detach_a_constraint(Constraint,Clauses2)
1710 ;
1711 Clauses1 = [],
1712 Clauses2 = []
1713 ),
1714 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1715 append([Clauses1,Clauses2,Clauses3],Clauses).
1717 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1718 generate_attach_a_constraint_nil(Constraint,Clause1),
1719 generate_attach_a_constraint_cons(Constraint,Clause2).
1721 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1722 make_name('attach_',FA,Name),
1723 Atom =.. [Name,Vars,Susp].
1725 generate_attach_a_constraint_nil(FA,Clause) :-
1726 Clause = (Head :- true),
1727 attach_constraint_atom(FA,[],_,Head).
1729 generate_attach_a_constraint_cons(FA,Clause) :-
1730 Clause = (Head :- Body),
1731 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1732 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1733 Body = ( AttachBody, Subscribe, RecursiveCall ),
1734 get_max_constraint_index(N),
1735 ( N == 1 ->
1736 generate_attach_body_1(FA,Var,Susp,AttachBody)
1737 ;
1738 generate_attach_body_n(FA,Var,Susp,AttachBody)
1739 ),
1740 % SWI-Prolog specific code
1741 chr_pp_flag(solver_events,NMod),
1742 ( NMod \== none ->
1743 Args = [[Var|_],Susp],
1744 get_target_module(Mod),
1745 use_auxiliary_predicate(run_suspensions),
1746 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1747 ;
1748 Subscribe = true
1749 ).
1751 generate_attach_body_1(FA,Var,Susp,Body) :-
1752 get_target_module(Mod),
1753 Body =
1754 ( get_attr(Var, Mod, Susps) ->
1755 put_attr(Var, Mod, [Susp|Susps])
1756 ;
1757 put_attr(Var, Mod, [Susp])
1758 ).
1760 generate_attach_body_n(F/A,Var,Susp,Body) :-
1761 get_constraint_index(F/A,Position),
1762 get_max_constraint_index(Total),
1763 get_target_module(Mod),
1764 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1765 singleton_attr(Total,Susp,Position,NewAttr3),
1766 Body =
1767 ( get_attr(Var,Mod,TAttr) ->
1768 AddGoal,
1769 put_attr(Var,Mod,NTAttr)
1770 ;
1771 put_attr(Var,Mod,NewAttr3)
1772 ), !.
1774 %% detach_$CONSTRAINT
1775 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1776 generate_detach_a_constraint_nil(Constraint,Clause1),
1777 generate_detach_a_constraint_cons(Constraint,Clause2).
1779 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1780 make_name('detach_',FA,Name),
1781 Atom =.. [Name,Vars,Susp].
1783 generate_detach_a_constraint_nil(FA,Clause) :-
1784 Clause = ( Head :- true),
1785 detach_constraint_atom(FA,[],_,Head).
1787 generate_detach_a_constraint_cons(FA,Clause) :-
1788 Clause = (Head :- Body),
1789 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1790 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1791 Body = ( DetachBody, RecursiveCall ),
1792 get_max_constraint_index(N),
1793 ( N == 1 ->
1794 generate_detach_body_1(FA,Var,Susp,DetachBody)
1795 ;
1796 generate_detach_body_n(FA,Var,Susp,DetachBody)
1797 ).
1799 generate_detach_body_1(FA,Var,Susp,Body) :-
1800 get_target_module(Mod),
1801 Body =
1802 ( get_attr(Var,Mod,Susps) ->
1803 'chr sbag_del_element'(Susps,Susp,NewSusps),
1804 ( NewSusps == [] ->
1805 del_attr(Var,Mod)
1806 ;
1807 put_attr(Var,Mod,NewSusps)
1808 )
1809 ;
1810 true
1811 ).
1813 generate_detach_body_n(F/A,Var,Susp,Body) :-
1814 get_constraint_index(F/A,Position),
1815 get_max_constraint_index(Total),
1816 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1817 get_target_module(Mod),
1818 Body =
1819 ( get_attr(Var,Mod,TAttr) ->
1820 RemGoal
1821 ;
1822 true
1823 ), !.
1825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1826 %-------------------------------------------------------------------------------
1827 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1828 :- chr_constraint generate_indexed_variables_body/4.
1829 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1830 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1831 %-------------------------------------------------------------------------------
1832 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1833 get_indexing_spec(F/A,Specs),
1834 ( chr_pp_flag(term_indexing,on) ->
1835 spectermvars(Specs,Args,F,A,Body,Vars)
1836 ;
1837 get_constraint_type_det(F/A,ArgTypes),
1838 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1839 ( MaybeBody == empty ->
1840 Body = true,
1841 Vars = []
1842 ; N == 0 ->
1843 ( Args = [Term] ->
1844 true
1845 ;
1846 Term =.. [term|Args]
1847 ),
1848 Body = term_variables(Term,Vars)
1849 ;
1850 MaybeBody = Body
1851 )
1852 ).
1853 generate_indexed_variables_body(FA,_,_,_) <=>
1854 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1855 %===============================================================================
1857 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1858 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1859 J is I + 1,
1860 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1861 ( Mode == (?),
1862 is_indexed_argument(FA,I) ->
1863 ( atomic_type(Type) ->
1864 Body =
1865 (
1866 ( var(V) ->
1867 Vars = [V|Tail]
1868 ;
1869 Vars = Tail
1870 ),
1871 Continuation
1872 ),
1873 ( RBody == empty ->
1874 Continuation = true, Tail = []
1875 ;
1876 Continuation = RBody
1877 )
1878 ;
1879 ( RBody == empty ->
1880 Body = term_variables(V,Vars)
1881 ;
1882 Body = (term_variables(V,Vars,Tail),RBody)
1883 )
1884 ),
1885 N = M
1886 ; Mode == (-), is_indexed_argument(FA,I) ->
1887 ( RBody == empty ->
1888 Body = (Vars = [V])
1889 ;
1890 Body = (Vars = [V|Tail],RBody)
1891 ),
1892 N is M + 1
1893 ;
1894 Vars = Tail,
1895 Body = RBody,
1896 N is M + 1
1897 ).
1898 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1899 % EXPERIMENTAL
1900 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1901 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1903 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1904 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1905 Goal = (ArgGoal,RGoal),
1906 argspecs(Specs,I,TempArgSpecs,RSpecs),
1907 merge_argspecs(TempArgSpecs,ArgSpecs),
1908 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1909 J is I + 1,
1910 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1912 argspecs([],_,[],[]).
1913 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1914 argspecs(Rest,I,ArgSpecs,RestSpecs).
1915 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1916 ( I == J ->
1917 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1918 ( Specs = [] ->
1919 RRestSpecs = RestSpecs
1920 ;
1921 RestSpecs = [Specs|RRestSpecs]
1922 )
1923 ;
1924 ArgSpecs = RArgSpecs,
1925 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1926 ),
1927 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1929 merge_argspecs(In,Out) :-
1930 sort(In,Sorted),
1931 merge_argspecs_(Sorted,Out).
1933 merge_argspecs_([],[]).
1934 merge_argspecs_([X],R) :- !, R = [X].
1935 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1936 ( (F1 == any ; F2 == any) ->
1937 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1938 ; F1 == F2 ->
1939 append(A1,A2,A),
1940 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1941 ;
1942 R = [specinfo(I,F1,A1)|RR],
1943 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1944 ).
1946 arggoal(List,Arg,Goal,L,T) :-
1947 ( List == [] ->
1948 L = T,
1949 Goal = true
1950 ; List = [specinfo(_,any,_)] ->
1951 Goal = term_variables(Arg,L,T)
1952 ;
1953 Goal =
1954 ( var(Arg) ->
1955 L = [Arg|T]
1956 ;
1957 Cases
1958 ),
1959 arggoal_cases(List,Arg,L,T,Cases)
1960 ).
1962 arggoal_cases([],_,L,T,L=T).
1963 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1964 ( ArgSpecs == [] ->
1965 Cases = RCases
1966 ; ArgSpecs == [[]] ->
1967 Cases = RCases
1968 ; FA = F/A ->
1969 Cases = (Case ; RCases),
1970 functor(Term,F,A),
1971 Term =.. [_|Args],
1972 Case = (Arg = Term -> ArgsGoal),
1973 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1974 ),
1975 arggoal_cases(Rest,Arg,L,T,RCases).
1976 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1978 generate_extra_clauses(Constraints,List) :-
1979 generate_activate_clauses(Constraints,List,Tail0),
1980 generate_remove_clauses(Constraints,Tail0,Tail1),
1981 generate_allocate_clauses(Constraints,Tail1,Tail2),
1982 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
1983 generate_novel_production(Tail3,Tail4),
1984 generate_extend_history(Tail4,Tail5),
1985 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
1986 generate_empty_named_history_initialisations(Tail6,Tail7),
1987 Tail7 = [].
1989 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1990 % remove_constraint_internal/[1/3]
1992 generate_remove_clauses([],List,List).
1993 generate_remove_clauses([C|Cs],List,Tail) :-
1994 generate_remove_clause(C,List,List1),
1995 generate_remove_clauses(Cs,List1,Tail).
1997 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
1998 uses_state(Constraint,removed),
1999 ( chr_pp_flag(inline_insertremove,off) ->
2000 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2001 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2002 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2003 ;
2004 delay_phase_end(validate_store_type_assumptions,
2005 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2006 )
2007 ).
2009 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2010 make_name('$remove_constraint_internal_',Constraint,Name),
2011 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2012 Goal =.. [Name, Susp,Delete]
2013 ;
2014 Goal =.. [Name,Susp,Agenda,Delete]
2015 ).
2017 generate_remove_clause(Constraint,List,Tail) :-
2018 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2019 List = [RemoveClause|Tail],
2020 RemoveClause = (Head :- RemoveBody),
2021 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2022 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2023 ;
2024 List = Tail
2025 ).
2027 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2028 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2029 ( Role == active ->
2030 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2031 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2032 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2033 ; Role == partner ->
2034 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2035 GetStateValue = true,
2036 MaybeDelete = DeleteYes
2037 ),
2038 RemoveBody =
2039 (
2040 GetState,
2041 GetStateValue,
2042 UpdateState,
2043 MaybeDelete
2044 )
2045 ;
2046 static_suspension_term(Constraint,Susp2),
2047 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2048 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2049 ( chr_pp_flag(debugable,on) ->
2050 Constraint = Functor / _,
2051 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2052 ;
2053 true
2054 ),
2055 ( Role == active ->
2056 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2057 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2058 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2059 ; Role == partner ->
2060 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2061 GetStateValue = true,
2062 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2063 ),
2064 RemoveBody =
2065 (
2066 Susp = Susp2,
2067 GetStateValue,
2068 UpdateState,
2069 MaybeDelete
2070 )
2071 ).
2073 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2074 % activate_constraint/4
2076 generate_activate_clauses([],List,List).
2077 generate_activate_clauses([C|Cs],List,Tail) :-
2078 generate_activate_clause(C,List,List1),
2079 generate_activate_clauses(Cs,List1,Tail).
2081 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2082 ( chr_pp_flag(inline_insertremove,off) ->
2083 use_auxiliary_predicate(activate_constraint,Constraint),
2084 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2085 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2086 ;
2087 delay_phase_end(validate_store_type_assumptions,
2088 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2089 )
2090 ).
2092 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2093 make_name('$activate_constraint_',Constraint,Name),
2094 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2095 Goal =.. [Name,Store, Susp]
2096 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2097 Goal =.. [Name,Store, Susp, Generation]
2098 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2099 Goal =.. [Name,Store, Vars, Susp, Generation]
2100 ;
2101 Goal =.. [Name,Store, Vars, Susp]
2102 ).
2104 generate_activate_clause(Constraint,List,Tail) :-
2105 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2106 List = [Clause|Tail],
2107 Clause = (Head :- Body),
2108 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2109 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2110 ;
2111 List = Tail
2112 ).
2114 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2115 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2116 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2117 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2118 ;
2119 GenerationHandling = true
2120 ),
2121 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2122 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2123 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2124 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2125 ;
2126 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2127 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2128 ( chr_pp_flag(guard_locks,off) ->
2129 NoneLocked = true
2130 ;
2131 NoneLocked = 'chr none_locked'( Vars)
2132 ),
2133 if_used_state(Constraint,not_stored_yet,
2134 ( State == not_stored_yet ->
2135 ArgumentsGoal,
2136 IndexedVariablesBody,
2137 NoneLocked,
2138 StoreYes
2139 ;
2140 % Vars = [],
2141 StoreNo
2142 ),
2143 % (Vars = [],StoreNo),StoreVarsGoal)
2144 StoreNo,StoreVarsGoal)
2145 ),
2146 Body =
2147 (
2148 GetState,
2149 GetStateValue,
2150 UpdateState,
2151 GenerationHandling,
2152 StoreVarsGoal
2153 ).
2154 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2155 % allocate_constraint/4
2157 generate_allocate_clauses([],List,List).
2158 generate_allocate_clauses([C|Cs],List,Tail) :-
2159 generate_allocate_clause(C,List,List1),
2160 generate_allocate_clauses(Cs,List1,Tail).
2162 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2163 uses_state(Constraint,not_stored_yet),
2164 ( chr_pp_flag(inline_insertremove,off) ->
2165 use_auxiliary_predicate(allocate_constraint,Constraint),
2166 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2167 ;
2168 Goal = (Susp = Suspension, Goal0),
2169 delay_phase_end(validate_store_type_assumptions,
2170 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2171 )
2172 ).
2174 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2175 make_name('$allocate_constraint_',Constraint,Name),
2176 Goal =.. [Name,Susp|Args].
2178 generate_allocate_clause(Constraint,List,Tail) :-
2179 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2180 List = [Clause|Tail],
2181 Clause = (Head :- Body),
2182 Constraint = _/A,
2183 length(Args,A),
2184 allocate_constraint_atom(Constraint,Susp,Args,Head),
2185 allocate_constraint_body(Constraint,Susp,Args,Body)
2186 ;
2187 List = Tail
2188 ).
2190 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2191 static_suspension_term(Constraint,Suspension),
2192 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2193 ( chr_pp_flag(debugable,on) ->
2194 Constraint = Functor / _,
2195 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2196 ;
2197 true
2198 ),
2199 ( chr_pp_flag(debugable,on) ->
2200 ( may_trigger(Constraint) ->
2201 append(Args,[Susp],VarsSusp),
2202 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2203 get_target_module(Mod),
2204 Continuation = Mod : ContinuationGoal
2205 ;
2206 Continuation = true
2207 ),
2208 Init = (Susp = Suspension),
2209 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2210 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2211 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2212 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2213 Susp = Suspension, Init = true, CreateContinuation = true
2214 ;
2215 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2216 ),
2217 ( uses_history(Constraint) ->
2218 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2219 ;
2220 CreateHistory = true
2221 ),
2222 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2223 ( has_suspension_field(Constraint,id) ->
2224 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2225 GenID = 'chr gen_id'(Id)
2226 ;
2227 GenID = true
2228 ),
2229 Body =
2230 (
2231 Init,
2232 CreateContinuation,
2233 CreateGeneration,
2234 CreateHistory,
2235 CreateState,
2236 GenID
2237 ).
2239 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2240 % insert_constraint_internal
2242 generate_insert_constraint_internal_clauses([],List,List).
2243 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2244 generate_insert_constraint_internal_clause(C,List,List1),
2245 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2247 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2248 ( chr_pp_flag(inline_insertremove,off) ->
2249 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2250 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2251 ;
2252 delay_phase_end(validate_store_type_assumptions,
2253 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2254 )
2255 ).
2258 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2259 insert_constraint_internal_constraint_name(Constraint,Name),
2260 ( chr_pp_flag(debugable,on) ->
2261 Goal =.. [Name, Vars, Self, Closure | Args]
2262 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2263 Goal =.. [Name,Self | Args]
2264 ;
2265 Goal =.. [Name,Vars, Self | Args]
2266 ).
2268 insert_constraint_internal_constraint_name(Constraint,Name) :-
2269 make_name('$insert_constraint_internal_',Constraint,Name).
2271 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2272 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2273 List = [Clause|Tail],
2274 Clause = (Head :- Body),
2275 Constraint = _/A,
2276 length(Args,A),
2277 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2278 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2279 ;
2280 List = Tail
2281 ).
2284 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2285 static_suspension_term(Constraint,Suspension),
2286 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2287 ( chr_pp_flag(debugable,on) ->
2288 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2289 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2290 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2291 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2292 ;
2293 CreateGeneration = true
2294 ),
2295 ( chr_pp_flag(debugable,on) ->
2296 Constraint = Functor / _,
2297 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2298 ;
2299 true
2300 ),
2301 ( uses_history(Constraint) ->
2302 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2303 ;
2304 CreateHistory = true
2305 ),
2306 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2307 List = [Clause|Tail],
2308 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2309 suspension_term_base_fields(Constraint,BaseFields),
2310 ( has_suspension_field(Constraint,id) ->
2311 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2312 GenID = 'chr gen_id'(Id)
2313 ;
2314 GenID = true
2315 ),
2316 Body =
2317 (
2318 Susp = Suspension,
2319 CreateState,
2320 CreateGeneration,
2321 CreateHistory,
2322 GenID
2323 )
2324 ;
2325 ( has_suspension_field(Constraint,id) ->
2326 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2327 GenID = 'chr gen_id'(Id)
2328 ;
2329 GenID = true
2330 ),
2331 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2332 ( chr_pp_flag(guard_locks,off) ->
2333 NoneLocked = true
2334 ;
2335 NoneLocked = 'chr none_locked'( Vars)
2336 ),
2337 Body =
2338 (
2339 Susp = Suspension,
2340 IndexedVariablesBody,
2341 NoneLocked,
2342 CreateState,
2343 CreateGeneration,
2344 CreateHistory,
2345 GenID
2346 )
2347 ).
2349 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2350 % novel_production/2
2352 generate_novel_production(List,Tail) :-
2353 ( is_used_auxiliary_predicate(novel_production) ->
2354 List = [Clause|Tail],
2355 Clause =
2356 (
2357 '$novel_production'( Self, Tuple) :-
2358 % arg( 3, Self, Ref), % ARGXXX
2359 % 'chr get_mutable'( History, Ref),
2360 arg( 3, Self, History), % ARGXXX
2361 ( hprolog:get_ds( Tuple, History, _) ->
2362 fail
2363 ;
2364 true
2365 )
2366 )
2367 ;
2368 List = Tail
2369 ).
2371 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2372 % extend_history/2
2374 generate_extend_history(List,Tail) :-
2375 ( is_used_auxiliary_predicate(extend_history) ->
2376 List = [Clause|Tail],
2377 Clause =
2378 (
2379 '$extend_history'( Self, Tuple) :-
2380 % arg( 3, Self, Ref), % ARGXXX
2381 % 'chr get_mutable'( History, Ref),
2382 arg( 3, Self, History), % ARGXXX
2383 hprolog:put_ds( Tuple, History, x, NewHistory),
2384 setarg( 3, Self, NewHistory) % ARGXXX
2385 )
2386 ;
2387 List = Tail
2388 ).
2390 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2391 %
2392 :- chr_constraint
2393 empty_named_history_initialisations/2,
2394 generate_empty_named_history_initialisation/1,
2395 find_empty_named_histories/0.
2397 generate_empty_named_history_initialisations(List, Tail) :-
2398 empty_named_history_initialisations(List, Tail),
2399 find_empty_named_histories.
2401 find_empty_named_histories, history(_, Name, []) ==>
2402 generate_empty_named_history_initialisation(Name).
2404 generate_empty_named_history_initialisation(Name) \
2405 generate_empty_named_history_initialisation(Name) <=> true.
2406 generate_empty_named_history_initialisation(Name) \
2407 empty_named_history_initialisations(List, Tail) # Passive
2408 <=>
2409 empty_named_history_global_variable(Name, GlobalVariable),
2410 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2411 empty_named_history_initialisations(Rest, Tail)
2412 pragma passive(Passive).
2414 find_empty_named_histories \
2415 generate_empty_named_history_initialisation(_) # Passive <=> true
2416 pragma passive(Passive).
2418 find_empty_named_histories,
2419 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2420 pragma passive(Passive).
2422 find_empty_named_histories <=>
2423 chr_error(internal, 'find_empty_named_histories was not removed', []).
2426 empty_named_history_global_variable(Name, GlobalVariable) :-
2427 atom_concat('chr empty named history ', Name, GlobalVariable).
2429 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2430 empty_named_history_global_variable(Name, GlobalVariable).
2432 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2433 empty_named_history_global_variable(Name, GlobalVariable).
2436 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2437 % run_suspensions/2
2439 generate_run_suspensions_clauses([],List,List).
2440 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2441 generate_run_suspensions_clause(C,List,List1),
2442 generate_run_suspensions_clauses(Cs,List1,Tail).
2444 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2445 make_name('$run_suspensions_',Constraint,Name),
2446 Goal =.. [Name,Suspensions].
2448 generate_run_suspensions_clause(Constraint,List,Tail) :-
2449 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2450 List = [Clause1,Clause2|Tail],
2451 run_suspensions_goal(Constraint,[],Clause1),
2452 ( chr_pp_flag(debugable,on) ->
2453 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2454 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2455 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2456 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2457 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2458 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2459 Clause2 =
2460 (
2461 Clause2Head :-
2462 GetState,
2463 GetStateValue,
2464 ( State==active ->
2465 UpdateState,
2466 GetGeneration,
2467 GetGenerationValue,
2468 Generation is Gen+1,
2469 UpdateGeneration,
2470 GetContinuation,
2471 (
2472 'chr debug_event'(wake(Suspension)),
2473 call(Continuation)
2474 ;
2475 'chr debug_event'(fail(Suspension)), !,
2476 fail
2477 ),
2478 (
2479 'chr debug_event'(exit(Suspension))
2480 ;
2481 'chr debug_event'(redo(Suspension)),
2482 fail
2483 ),
2484 GetPost,
2485 GetPostValue,
2486 ( Post==triggered ->
2487 UpdatePost % catching constraints that did not do anything
2488 ;
2489 true
2490 )
2491 ;
2492 true
2493 ),
2494 Clause2Recursion
2495 )
2496 ;
2497 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2498 static_suspension_term(Constraint,SuspensionTerm),
2499 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2500 append(Arguments,[Suspension],VarsSusp),
2501 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2502 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2503 ( uses_field(Constraint,generation) ->
2504 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2505 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2506 ;
2507 GenerationHandling = true
2508 ),
2509 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2510 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2511 if_used_state(Constraint,removed,
2512 ( GetState,
2513 ( State==active
2514 -> ReactivateConstraint
2515 ; true)
2516 ),ReactivateConstraint,CondReactivate),
2517 ReactivateConstraint =
2518 (
2519 UpdateState,
2520 GenerationHandling,
2521 Continuation,
2522 GetPostState,
2523 ( Post==triggered ->
2524 UpdatePostState % catching constraints that did not do anything
2525 ;
2526 true
2527 )
2528 ),
2529 Clause2 =
2530 (
2531 Clause2Head :-
2532 Suspension = SuspensionTerm,
2533 CondReactivate,
2534 Clause2Recursion
2535 )
2536 )
2537 ;
2538 List = Tail
2539 ).
2541 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2543 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2544 generate_attach_increment(Clauses) :-
2545 get_max_constraint_index(N),
2546 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2547 Clauses = [Clause1,Clause2],
2548 generate_attach_increment_empty(Clause1),
2549 ( N == 1 ->
2550 generate_attach_increment_one(Clause2)
2551 ;
2552 generate_attach_increment_many(N,Clause2)
2553 )
2554 ;
2555 Clauses = []
2556 ).
2558 generate_attach_increment_empty((attach_increment([],_) :- true)).
2560 generate_attach_increment_one(Clause) :-
2561 Head = attach_increment([Var|Vars],Susps),
2562 get_target_module(Mod),
2563 ( chr_pp_flag(guard_locks,off) ->
2564 NotLocked = true
2565 ;
2566 NotLocked = 'chr not_locked'( Var)
2567 ),
2568 Body =
2569 (
2570 NotLocked,
2571 ( get_attr(Var,Mod,VarSusps) ->
2572 sort(VarSusps,SortedVarSusps),
2573 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2574 put_attr(Var,Mod,MergedSusps)
2575 ;
2576 put_attr(Var,Mod,Susps)
2577 ),
2578 attach_increment(Vars,Susps)
2579 ),
2580 Clause = (Head :- Body).
2582 generate_attach_increment_many(N,Clause) :-
2583 Head = attach_increment([Var|Vars],TAttr1),
2584 % writeln(merge_attributes_1_before),
2585 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2586 % writeln(merge_attributes_1_after),
2587 get_target_module(Mod),
2588 ( chr_pp_flag(guard_locks,off) ->
2589 NotLocked = true
2590 ;
2591 NotLocked = 'chr not_locked'( Var)
2592 ),
2593 Body =
2594 (
2595 NotLocked,
2596 ( get_attr(Var,Mod,TAttr2) ->
2597 MergeGoal,
2598 put_attr(Var,Mod,Attr)
2599 ;
2600 put_attr(Var,Mod,TAttr1)
2601 ),
2602 attach_increment(Vars,TAttr1)
2603 ),
2604 Clause = (Head :- Body).
2606 %% attr_unify_hook
2607 generate_attr_unify_hook(Clauses) :-
2608 get_max_constraint_index(N),
2609 ( N == 0 ->
2610 Clauses = []
2611 ;
2612 ( N == 1 ->
2613 generate_attr_unify_hook_one(Clauses)
2614 ;
2615 generate_attr_unify_hook_many(N,Clauses)
2616 )
2617 ).
2619 generate_attr_unify_hook_one([Clause]) :-
2620 Head = attr_unify_hook(Susps,Other),
2621 get_target_module(Mod),
2622 get_indexed_constraint(1,C),
2623 ( get_store_type(C,ST),
2624 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2625 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2626 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2627 ( atomic_types_suspended_constraint(C) ->
2628 SortGoal1 = true,
2629 SortedSusps = Susps,
2630 SortGoal2 = true,
2631 SortedOtherSusps = OtherSusps,
2632 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2633 NonvarBody = true
2634 ;
2635 SortGoal1 = sort(Susps, SortedSusps),
2636 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2637 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2638 use_auxiliary_predicate(attach_increment),
2639 NonvarBody =
2640 ( compound(Other) ->
2641 term_variables(Other,OtherVars),
2642 attach_increment(OtherVars, SortedSusps)
2643 ;
2644 true
2645 )
2646 ),
2647 Body =
2648 (
2649 SortGoal1,
2650 ( var(Other) ->
2651 ( get_attr(Other,Mod,OtherSusps) ->
2652 SortGoal2,
2653 MergeGoal,
2654 put_attr(Other,Mod,NewSusps),
2655 WakeNewSusps
2656 ;
2657 put_attr(Other,Mod,SortedSusps),
2658 WakeSusps
2659 )
2660 ;
2661 NonvarBody,
2662 WakeSusps
2663 )
2664 ),
2665 Clause = (Head :- Body)
2666 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2667 make_run_suspensions(List,List,WakeNewSusps),
2668 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2669 Body =
2670 ( get_attr(Other,Mod,OtherSusps) ->
2671 MergeGoal,
2672 WakeNewSusps
2673 ;
2674 put_attr(Other,Mod,Susps)
2675 ),
2676 Clause = (Head :- Body)
2677 ).
2680 generate_attr_unify_hook_many(N,[Clause]) :-
2681 chr_pp_flag(dynattr,off), !,
2682 Head = attr_unify_hook(Attr,Other),
2683 get_target_module(Mod),
2684 make_attr(N,Mask,SuspsList,Attr),
2685 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2686 list2conj(SortGoalList,SortGoals),
2687 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2688 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2689 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2690 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2691 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2692 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2693 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2694 NonvarBody = true
2695 ;
2696 use_auxiliary_predicate(attach_increment),
2697 NonvarBody =
2698 ( compound(Other) ->
2699 term_variables(Other,OtherVars),
2700 attach_increment(OtherVars,SortedAttr)
2701 ;
2702 true
2703 )
2704 ),
2705 Body =
2706 (
2707 SortGoals,
2708 ( var(Other) ->
2709 ( get_attr(Other,Mod,TOtherAttr) ->
2710 MergeGoal,
2711 put_attr(Other,Mod,MergedAttr),
2712 WakeMergedSusps
2713 ;
2714 put_attr(Other,Mod,SortedAttr),
2715 WakeSortedSusps
2716 )
2717 ;
2718 NonvarBody,
2719 WakeSortedSusps
2720 )
2721 ),
2722 Clause = (Head :- Body).
2724 % NEW
2725 generate_attr_unify_hook_many(N,Clauses) :-
2726 Head = attr_unify_hook(Attr,Other),
2727 get_target_module(Mod),
2728 normalize_attr(Attr,NormalGoal,NormalAttr),
2729 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2730 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2731 make_run_suspensions(N),
2732 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2733 NonvarBody = true
2734 ;
2735 use_auxiliary_predicate(attach_increment),
2736 NonvarBody =
2737 ( compound(Other) ->
2738 term_variables(Other,OtherVars),
2739 attach_increment(OtherVars,NormalAttr)
2740 ;
2741 true
2742 )
2743 ),
2744 Body =
2745 (
2746 NormalGoal,
2747 ( var(Other) ->
2748 ( get_attr(Other,Mod,OtherAttr) ->
2749 NormalOtherGoal,
2750 MergeGoal,
2751 put_attr(Other,Mod,MergedAttr),
2752 '$dispatch_run_suspensions'(MergedAttr)
2753 ;
2754 put_attr(Other,Mod,NormalAttr),
2755 '$dispatch_run_suspensions'(NormalAttr)
2756 )
2757 ;
2758 NonvarBody,
2759 '$dispatch_run_suspensions'(NormalAttr)
2760 )
2761 ),
2762 Clause = (Head :- Body),
2763 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2764 DispatchList1 = ('$dispatch_run_suspensions'([])),
2765 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2766 run_suspensions_dispatchers(N,[],Dispatchers).
2768 % NEW
2769 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2770 ( N > 0 ->
2771 get_indexed_constraint(N,C),
2772 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2773 ( may_trigger(C) ->
2774 run_suspensions_goal(C,List,Body)
2775 ;
2776 Body = true
2777 ),
2778 M is N - 1,
2779 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2780 ;
2781 Dispatchers = Acc
2782 ).
2784 % NEW
2785 make_run_suspensions(N) :-
2786 ( N > 0 ->
2787 ( get_indexed_constraint(N,C),
2788 may_trigger(C) ->
2789 use_auxiliary_predicate(run_suspensions,C)
2790 ;
2791 true
2792 ),
2793 M is N - 1,
2794 make_run_suspensions(M)
2795 ;
2796 true
2797 ).
2799 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2800 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2802 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2803 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2804 use_auxiliary_predicate(run_suspensions,C),
2805 ( wakes_partially(C) ->
2806 run_suspensions_goal(C,OneSusps,Goal)
2807 ;
2808 run_suspensions_goal(C,AllSusps,Goal)
2809 )
2810 ;
2811 Goal = true
2812 ).
2814 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2815 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2817 make_run_suspensions_loop([],[],_,true).
2818 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2819 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2820 J is I + 1,
2821 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2823 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2824 % $insert_in_store_F/A
2825 % $delete_from_store_F/A
2827 generate_insert_delete_constraints([],[]).
2828 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2829 ( is_stored(FA) ->
2830 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2831 ;
2832 Clauses = RestClauses
2833 ),
2834 generate_insert_delete_constraints(Rest,RestClauses).
2836 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2837 insert_constraint_clause(FA,Clauses,RestClauses1),
2838 delete_constraint_clause(FA,RestClauses1,RestClauses).
2840 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2841 % insert_in_store
2843 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2844 ( chr_pp_flag(inline_insertremove,off) ->
2845 use_auxiliary_predicate(insert_in_store,FA),
2846 insert_constraint_atom(FA,Susp,Goal)
2847 ;
2848 delay_phase_end(validate_store_type_assumptions,
2849 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2850 insert_constraint_direct_used_vars(UsedVars,Vars)
2851 )
2852 )
2853 ).
2855 insert_constraint_direct_used_vars([],_).
2856 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2857 nth1(Index,Vars,Var),
2858 insert_constraint_direct_used_vars(Rest,Vars).
2860 insert_constraint_atom(FA,Susp,Call) :-
2861 make_name('$insert_in_store_',FA,Functor),
2862 Call =.. [Functor,Susp].
2864 insert_constraint_clause(C,Clauses,RestClauses) :-
2865 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2866 Clauses = [Clause|RestClauses],
2867 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2868 insert_constraint_atom(C,Susp,Head),
2869 insert_constraint_body(C,Susp,UsedVars,Body),
2870 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2871 ( chr_pp_flag(store_counter,on) ->
2872 InsertCounterInc = '$insert_counter_inc'
2873 ;
2874 InsertCounterInc = true
2875 )
2876 ;
2877 Clauses = RestClauses
2878 ).
2880 insert_constraint_used_vars([],_,_,true).
2881 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2882 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2883 insert_constraint_used_vars(Rest,C,Susp,Goals).
2885 insert_constraint_body(C,Susp,UsedVars,Body) :-
2886 get_store_type(C,StoreType),
2887 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2889 insert_constraint_body(default,C,Susp,[],Body) :-
2890 global_list_store_name(C,StoreName),
2891 make_get_store_goal(StoreName,Store,GetStoreGoal),
2892 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2893 ( chr_pp_flag(debugable,on) ->
2894 Cell = [Susp|Store],
2895 Body =
2896 (
2897 GetStoreGoal,
2898 UpdateStoreGoal
2899 )
2900 ;
2901 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2902 Body =
2903 (
2904 GetStoreGoal,
2905 Cell = [Susp|Store],
2906 UpdateStoreGoal,
2907 ( Store = [NextSusp|_] ->
2908 SetGoal
2909 ;
2910 true
2911 )
2912 )
2913 ).
2914 % get_target_module(Mod),
2915 % get_max_constraint_index(Total),
2916 % ( Total == 1 ->
2917 % generate_attach_body_1(C,Store,Susp,AttachBody)
2918 % ;
2919 % generate_attach_body_n(C,Store,Susp,AttachBody)
2920 % ),
2921 % Body =
2922 % (
2923 % 'chr default_store'(Store),
2924 % AttachBody
2925 % ).
2926 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2927 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2928 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2929 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2930 sort_out_used_vars(MixedUsedVars,UsedVars).
2931 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2932 global_ground_store_name(C,StoreName),
2933 make_get_store_goal(StoreName,Store,GetStoreGoal),
2934 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2935 ( chr_pp_flag(debugable,on) ->
2936 Cell = [Susp|Store],
2937 Body =
2938 (
2939 GetStoreGoal,
2940 UpdateStoreGoal
2941 )
2942 ;
2943 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2944 Body =
2945 (
2946 GetStoreGoal,
2947 Cell = [Susp|Store],
2948 UpdateStoreGoal,
2949 ( Store = [NextSusp|_] ->
2950 SetGoal
2951 ;
2952 true
2953 )
2954 )
2955 ).
2956 % global_ground_store_name(C,StoreName),
2957 % make_get_store_goal(StoreName,Store,GetStoreGoal),
2958 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
2959 % Body =
2960 % (
2961 % GetStoreGoal, % nb_getval(StoreName,Store),
2962 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
2963 % ).
2964 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
2965 % TODO: generalize to more than one !!!
2966 get_target_module(Module),
2967 Body = ( get_attr(Variable,Module,AssocStore) ->
2968 insert_assoc_store(AssocStore,Key,Susp)
2969 ;
2970 new_assoc_store(AssocStore),
2971 put_attr(Variable,Module,AssocStore),
2972 insert_assoc_store(AssocStore,Key,Susp)
2973 ).
2975 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
2976 global_singleton_store_name(C,StoreName),
2977 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
2978 Body =
2979 (
2980 UpdateStoreGoal
2981 ).
2982 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
2983 find_with_var_identity(
2984 B-UV,
2985 [Susp],
2986 (
2987 member(ST,StoreTypes),
2988 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
2989 ),
2990 BodiesUsedVars
2991 ),
2992 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
2993 list2conj(Bodies,Body),
2994 sort_out_used_vars(NestedUsedVars,UsedVars).
2995 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
2996 UsedVars = [Index-Var],
2997 get_identifier_size(ISize),
2998 functor(Struct,struct,ISize),
2999 get_identifier_index(C,Index,IIndex),
3000 arg(IIndex,Struct,Susps),
3001 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3002 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3003 UsedVars = [Index-Var],
3004 type_indexed_identifier_structure(IndexType,Struct),
3005 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3006 arg(IIndex,Struct,Susps),
3007 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3009 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3010 flatten(NestedUsedVars,FlatUsedVars),
3011 sort(FlatUsedVars,SortedFlatUsedVars),
3012 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3014 sort_out_used_vars1([],[]).
3015 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3016 sort_out_used_vars1([I-X,J-Y|R],L) :-
3017 ( I == J ->
3018 X = Y,
3019 sort_out_used_vars1([I-X|R],L)
3020 ;
3021 L = [I-X|T],
3022 sort_out_used_vars1([J-Y|R],T)
3023 ).
3025 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3026 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3027 multi_hash_store_name(FA,Index,StoreName),
3028 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3029 Body =
3030 (
3031 KeyBody,
3032 nb_getval(StoreName,Store),
3033 insert_iht(Store,Key,Susp)
3034 ),
3035 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3037 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3038 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3039 multi_hash_store_name(FA,Index,StoreName),
3040 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3041 make_get_store_goal(StoreName,Store,GetStoreGoal),
3042 ( chr_pp_flag(ht_removal,on)
3043 -> ht_prev_field(Index,PrevField),
3044 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3045 SetGoal),
3046 Body =
3047 (
3048 GetStoreGoal,
3049 insert_ht(Store,Key,Susp,Result),
3050 ( Result = [_,NextSusp|_]
3051 -> SetGoal
3052 ; true
3053 )
3054 )
3055 ; Body =
3056 (
3057 GetStoreGoal,
3058 insert_ht(Store,Key,Susp)
3059 )
3060 ),
3061 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3063 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3064 % Delete
3066 delete_constraint_clause(C,Clauses,RestClauses) :-
3067 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3068 Clauses = [Clause|RestClauses],
3069 Clause = (Head :- Body),
3070 delete_constraint_atom(C,Susp,Head),
3071 C = F/A,
3072 functor(Head,F,A),
3073 delete_constraint_body(C,Head,Susp,[],Body)
3074 ;
3075 Clauses = RestClauses
3076 ).
3078 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3079 functor(Head,F,A),
3080 C = F/A,
3081 ( chr_pp_flag(inline_insertremove,off) ->
3082 use_auxiliary_predicate(delete_from_store,C),
3083 delete_constraint_atom(C,Susp,Goal)
3084 ;
3085 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3086 ).
3088 delete_constraint_atom(C,Susp,Atom) :-
3089 make_name('$delete_from_store_',C,Functor),
3090 Atom =.. [Functor,Susp].
3093 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3094 Body = (CounterBody,DeleteBody),
3095 ( chr_pp_flag(store_counter,on) ->
3096 CounterBody = '$delete_counter_inc'
3097 ;
3098 CounterBody = true
3099 ),
3100 get_store_type(C,StoreType),
3101 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3103 delete_constraint_body(default,C,_,Susp,_,Body) :-
3104 ( chr_pp_flag(debugable,on) ->
3105 global_list_store_name(C,StoreName),
3106 make_get_store_goal(StoreName,Store,GetStoreGoal),
3107 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3108 Body =
3109 (
3110 GetStoreGoal, % nb_getval(StoreName,Store),
3111 'chr sbag_del_element'(Store,Susp,NStore),
3112 UpdateStoreGoal % b_setval(StoreName,NStore)
3113 )
3114 ;
3115 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3116 global_list_store_name(C,StoreName),
3117 make_get_store_goal(StoreName,Store,GetStoreGoal),
3118 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3119 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3120 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3121 Body =
3122 (
3123 GetGoal,
3124 ( var(PredCell) ->
3125 GetStoreGoal, % nb_getval(StoreName,Store),
3126 Store = [_|Tail],
3127 UpdateStoreGoal,
3128 ( Tail = [NextSusp|_] ->
3129 SetGoal1
3130 ;
3131 true
3132 )
3133 ;
3134 PredCell = [_,_|Tail],
3135 setarg(2,PredCell,Tail),
3136 ( Tail = [NextSusp|_] ->
3137 SetGoal2
3138 ;
3139 true
3140 )
3141 )
3142 )
3143 ).
3144 % get_target_module(Mod),
3145 % get_max_constraint_index(Total),
3146 % ( Total == 1 ->
3147 % generate_detach_body_1(C,Store,Susp,DetachBody),
3148 % Body =
3149 % (
3150 % 'chr default_store'(Store),
3151 % DetachBody
3152 % )
3153 % ;
3154 % generate_detach_body_n(C,Store,Susp,DetachBody),
3155 % Body =
3156 % (
3157 % 'chr default_store'(Store),
3158 % DetachBody
3159 % )
3160 % ).
3161 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3162 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3163 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3164 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3165 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3166 ( chr_pp_flag(debugable,on) ->
3167 global_ground_store_name(C,StoreName),
3168 make_get_store_goal(StoreName,Store,GetStoreGoal),
3169 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3170 Body =
3171 (
3172 GetStoreGoal, % nb_getval(StoreName,Store),
3173 'chr sbag_del_element'(Store,Susp,NStore),
3174 UpdateStoreGoal % b_setval(StoreName,NStore)
3175 )
3176 ;
3177 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3178 global_ground_store_name(C,StoreName),
3179 make_get_store_goal(StoreName,Store,GetStoreGoal),
3180 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3181 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3182 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3183 Body =
3184 (
3185 GetGoal,
3186 ( var(PredCell) ->
3187 GetStoreGoal, % nb_getval(StoreName,Store),
3188 Store = [_|Tail],
3189 UpdateStoreGoal,
3190 ( Tail = [NextSusp|_] ->
3191 SetGoal1
3192 ;
3193 true
3194 )
3195 ;
3196 PredCell = [_,_|Tail],
3197 setarg(2,PredCell,Tail),
3198 ( Tail = [NextSusp|_] ->
3199 SetGoal2
3200 ;
3201 true
3202 )
3203 )
3204 )
3205 ).
3206 % global_ground_store_name(C,StoreName),
3207 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3208 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3209 % Body =
3210 % (
3211 % GetStoreGoal, % nb_getval(StoreName,Store),
3212 % 'chr sbag_del_element'(Store,Susp,NStore),
3213 % UpdateStoreGoal % b_setval(StoreName,NStore)
3214 % ).
3215 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3216 get_target_module(Module),
3217 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3218 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3219 Body = (
3220 VariableGoal,
3221 get_attr(Variable,Module,AssocStore),
3222 KeyGoal,
3223 delete_assoc_store(AssocStore,Key,Susp)
3224 ).
3225 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3226 global_singleton_store_name(C,StoreName),
3227 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3228 Body =
3229 (
3230 UpdateStoreGoal % b_setval(StoreName,[])
3231 ).
3232 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3233 find_with_var_identity(
3234 B,
3235 [Susp/VarDict/Head],
3236 (
3237 member(ST,StoreTypes),
3238 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3239 ),
3240 Bodies
3241 ),
3242 list2conj(Bodies,Body).
3243 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3244 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3245 get_identifier_size(ISize),
3246 functor(Struct,struct,ISize),
3247 get_identifier_index(C,Index,IIndex),
3248 arg(IIndex,Struct,Susps),
3249 Body = (
3250 VariableGoal,
3251 Variable = Struct,
3252 'chr sbag_del_element'(Susps,Susp,NSusps),
3253 setarg(IIndex,Variable,NSusps)
3254 ).
3255 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3256 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3257 type_indexed_identifier_structure(IndexType,Struct),
3258 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3259 arg(IIndex,Struct,Susps),
3260 Body = (
3261 VariableGoal,
3262 Variable = Struct,
3263 'chr sbag_del_element'(Susps,Susp,NSusps),
3264 setarg(IIndex,Variable,NSusps)
3265 ).
3267 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3268 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3269 multi_hash_store_name(FA,Index,StoreName),
3270 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3271 Body =
3272 (
3273 KeyBody,
3274 nb_getval(StoreName,Store),
3275 delete_iht(Store,Key,Susp)
3276 ),
3277 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3278 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3279 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3280 multi_hash_store_name(C,Index,StoreName),
3281 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3282 make_get_store_goal(StoreName,Store,GetStoreGoal),
3283 ( chr_pp_flag(ht_removal,on)
3284 -> ht_prev_field(Index,PrevField),
3285 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3286 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3287 SetGoal1),
3288 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3289 SetGoal2),
3290 Body =
3291 (
3292 GetGoal,
3293 ( var(Prev)
3294 -> GetStoreGoal,
3295 KeyBody,
3296 delete_first_ht(Store,Key,Values),
3297 ( Values = [NextSusp|_]
3298 -> SetGoal1
3299 ; true
3300 )
3301 ; Prev = [_,_|Values],
3302 setarg(2,Prev,Values),
3303 ( Values = [NextSusp|_]
3304 -> SetGoal2
3305 ; true
3306 )
3307 )
3308 )
3309 ; Body =
3310 (
3311 KeyBody,
3312 GetStoreGoal, % nb_getval(StoreName,Store),
3313 delete_ht(Store,Key,Susp)
3314 )
3315 ),
3316 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3318 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3320 :- chr_constraint
3321 module_initializer/1,
3322 module_initializers/1.
3324 module_initializers(G), module_initializer(Initializer) <=>
3325 G = (Initializer,Initializers),
3326 module_initializers(Initializers).
3328 module_initializers(G) <=>
3329 G = true.
3331 generate_attach_code(Constraints,[Enumerate|L]) :-
3332 enumerate_stores_code(Constraints,Enumerate),
3333 generate_attach_code(Constraints,L,T),
3334 module_initializers(Initializers),
3335 prolog_global_variables_code(PrologGlobalVariables),
3336 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3338 generate_attach_code([],L,L).
3339 generate_attach_code([C|Cs],L,T) :-
3340 get_store_type(C,StoreType),
3341 generate_attach_code(StoreType,C,L,L1),
3342 generate_attach_code(Cs,L1,T).
3344 generate_attach_code(default,C,L,T) :-
3345 global_list_store_initialisation(C,L,T).
3346 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3347 multi_inthash_store_initialisations(Indexes,C,L,L1),
3348 multi_inthash_via_lookups(Indexes,C,L1,T).
3349 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3350 multi_hash_store_initialisations(Indexes,C,L,L1),
3351 multi_hash_via_lookups(Indexes,C,L1,T).
3352 generate_attach_code(global_ground,C,L,T) :-
3353 global_ground_store_initialisation(C,L,T).
3354 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3355 use_auxiliary_module(chr_assoc_store).
3356 generate_attach_code(global_singleton,C,L,T) :-
3357 global_singleton_store_initialisation(C,L,T).
3358 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3359 multi_store_generate_attach_code(StoreTypes,C,L,T).
3360 generate_attach_code(identifier_store(Index),C,L,T) :-
3361 get_identifier_index(C,Index,IIndex),
3362 ( IIndex == 2 ->
3363 get_identifier_size(ISize),
3364 functor(Struct,struct,ISize),
3365 Struct =.. [_,Label|Stores],
3366 set_elems(Stores,[]),
3367 Clause1 = new_identifier(Label,Struct),
3368 functor(Struct2,struct,ISize),
3369 arg(1,Struct2,Label2),
3370 Clause2 =
3371 ( user:portray(Struct2) :-
3372 write('<id:'),
3373 print(Label2),
3374 write('>')
3375 ),
3376 functor(Struct3,struct,ISize),
3377 arg(1,Struct3,Label3),
3378 Clause3 = identifier_label(Struct3,Label3),
3379 L = [Clause1,Clause2,Clause3|T]
3380 ;
3381 L = T
3382 ).
3383 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3384 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3385 ( IIndex == 2 ->
3386 identifier_store_initialization(IndexType,L,L1),
3387 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3388 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3389 get_type_indexed_identifier_size(IndexType,ISize),
3390 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3391 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3392 type_indexed_identifier_structure(IndexType,Struct),
3393 Struct =.. [_,Label|Stores],
3394 set_elems(Stores,[]),
3395 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3396 Clause1 =.. [Name1,Label,Struct],
3397 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3398 Goal1 =.. [Name1,Label1b,S1b],
3399 type_indexed_identifier_structure(IndexType,Struct1b),
3400 Struct1b =.. [_,Label1b|Stores1b],
3401 set_elems(Stores1b,[]),
3402 Expansion1 = (S1b = Struct1b),
3403 Clause1b = user:goal_expansion(Goal1,Expansion1),
3404 % writeln(Clause1-Clause1b),
3405 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3406 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3407 type_indexed_identifier_structure(IndexType,Struct2),
3408 arg(1,Struct2,Label2),
3409 Clause2 =
3410 ( user:portray(Struct2) :-
3411 write('<id:'),
3412 print(Label2),
3413 write('>')
3414 ),
3415 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3416 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3417 type_indexed_identifier_structure(IndexType,Struct3),
3418 arg(1,Struct3,Label3),
3419 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3420 Clause3 =.. [Name3,Struct3,Label3],
3421 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3422 Goal3b =.. [Name3,S3b,L3b],
3423 type_indexed_identifier_structure(IndexType,Struct3b),
3424 arg(1,Struct3b,L3b),
3425 Expansion3b = (S3 = Struct3b),
3426 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3427 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3428 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3429 identifier_store_name(IndexType,GlobalVariable),
3430 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3431 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3432 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3433 Clause4 =
3434 ( LookupAtom :-
3435 nb_getval(GlobalVariable,HT),
3436 ( lookup_ht(HT,X,[IX]) ->
3437 true
3438 ;
3439 NewIdentifierGoal,
3440 insert_ht(HT,X,IX)
3441 )
3442 ),
3443 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3444 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3445 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3446 ;
3447 L = T
3448 ).
3450 lookup_identifier_atom(Key,X,IX,Atom) :-
3451 atom_concat('lookup_identifier_',Key,LookupFunctor),
3452 Atom =.. [LookupFunctor,X,IX].
3454 identifier_label_atom(IndexType,IX,X,Atom) :-
3455 type_indexed_identifier_name(IndexType,identifier_label,Name),
3456 Atom =.. [Name,IX,X].
3458 multi_store_generate_attach_code([],_,L,L).
3459 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3460 generate_attach_code(ST,C,L,L1),
3461 multi_store_generate_attach_code(STs,C,L1,T).
3463 multi_inthash_store_initialisations([],_,L,L).
3464 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3465 use_auxiliary_module(chr_integertable_store),
3466 multi_hash_store_name(FA,Index,StoreName),
3467 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3468 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3469 L1 = L,
3470 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3471 multi_hash_store_initialisations([],_,L,L).
3472 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3473 use_auxiliary_module(chr_hashtable_store),
3474 multi_hash_store_name(FA,Index,StoreName),
3475 prolog_global_variable(StoreName),
3476 make_init_store_goal(StoreName,HT,InitStoreGoal),
3477 module_initializer((new_ht(HT),InitStoreGoal)),
3478 L1 = L,
3479 multi_hash_store_initialisations(Indexes,FA,L1,T).
3481 global_list_store_initialisation(C,L,T) :-
3482 ( is_stored(C) ->
3483 global_list_store_name(C,StoreName),
3484 prolog_global_variable(StoreName),
3485 make_init_store_goal(StoreName,[],InitStoreGoal),
3486 module_initializer(InitStoreGoal)
3487 ;
3488 true
3489 ),
3490 L = T.
3491 global_ground_store_initialisation(C,L,T) :-
3492 global_ground_store_name(C,StoreName),
3493 prolog_global_variable(StoreName),
3494 make_init_store_goal(StoreName,[],InitStoreGoal),
3495 module_initializer(InitStoreGoal),
3496 L = T.
3497 global_singleton_store_initialisation(C,L,T) :-
3498 global_singleton_store_name(C,StoreName),
3499 prolog_global_variable(StoreName),
3500 make_init_store_goal(StoreName,[],InitStoreGoal),
3501 module_initializer(InitStoreGoal),
3502 L = T.
3503 identifier_store_initialization(IndexType,L,T) :-
3504 use_auxiliary_module(chr_hashtable_store),
3505 identifier_store_name(IndexType,StoreName),
3506 prolog_global_variable(StoreName),
3507 make_init_store_goal(StoreName,HT,InitStoreGoal),
3508 module_initializer((new_ht(HT),InitStoreGoal)),
3509 L = T.
3512 multi_inthash_via_lookups([],_,L,L).
3513 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3514 multi_hash_via_lookup_head(C,Index,Key,SuspsList,Head),
3515 multi_hash_store_name(C,Index,StoreName),
3516 Body =
3517 (
3518 nb_getval(StoreName,HT),
3519 lookup_iht(HT,Key,SuspsList)
3520 ),
3521 L = [(Head :- Body)|L1],
3522 multi_inthash_via_lookups(Indexes,C,L1,T).
3523 multi_hash_via_lookups([],_,L,L).
3524 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
3525 multi_hash_via_lookup_head(C,Index,Key,SuspsList,Head),
3526 multi_hash_via_lookup_goal(C,Index,Key,SuspsList,Body),
3527 L = [(Head :- Body)|L1],
3528 multi_hash_via_lookups(Indexes,C,L1,T).
3530 multi_hash_via_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3531 multi_hash_via_lookup_name(ConstraintSymbol,Index,Name),
3532 Head =.. [Name,Key,SuspsList].
3534 %% multi_hash_via_lookup_goal(+ConstraintSymbol,+Index,+Key,+SuspsList,-Goal) is det.
3535 %
3536 % Returns goal that performs hash table lookup.
3537 multi_hash_via_lookup_goal(ConstraintSymbol,Index,Key,SuspsList,Goal) :-
3538 % INLINED:
3539 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3540 make_get_store_goal(StoreName,HT,GetStoreGoal),
3541 ( specialized_hash_term_call(Key,Hash,HashCall) ->
3542 Goal =
3543 (
3544 GetStoreGoal, % nb_getval(StoreName,HT),
3545 HashCall, % hash_term(Key,Hash),
3546 lookup_ht1(HT,Hash,Key,SuspsList)
3547 )
3548 ;
3549 Goal =
3550 (
3551 GetStoreGoal, % nb_getval(StoreName,HT),
3552 hash_term(Key,Hash),
3553 lookup_ht(HT,Key,SuspsList)
3554 )
3555 ).
3557 specialized_hash_term_call(Key,Hash,Call) :-
3558 ( ground(Key) ->
3559 % This is based on a property of SWI-Prolog's
3560 % hash_term/2 predicate:
3561 % the hash value is stable over repeated invocations
3562 % of SWI-Prolog
3563 hash_term(Key,Hash),
3564 Call = true
3565 ;
3566 nonvar(Key),
3567 specialize_hash_term(Key,NewKey),
3568 NewKey \== Key,
3569 Call = hash_term(NewKey,Hash)
3570 ).
3572 specialize_hash_term(Term,NewTerm) :-
3573 ( ground(Term) ->
3574 hash_term(Term,NewTerm)
3575 ; var(Term) ->
3576 NewTerm = Term
3577 ;
3578 Term =.. [F|Args],
3579 maplist(specialize_hash_term,Args,NewArgs),
3580 NewTerm =.. [F|NewArgs]
3581 ).
3583 %% multi_hash_via_lookup_name(+ConstraintSymbol,+Index,-Name)
3584 %
3585 % Returns predicate name of hash table lookup predicate.
3586 multi_hash_via_lookup_name(F/A,Index,Name) :-
3587 ( integer(Index) ->
3588 IndexName = Index
3589 ; is_list(Index) ->
3590 atom_concat_list(Index,IndexName)
3591 ),
3592 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3594 multi_hash_store_name(F/A,Index,Name) :-
3595 get_target_module(Mod),
3596 ( integer(Index) ->
3597 IndexName = Index
3598 ; is_list(Index) ->
3599 atom_concat_list(Index,IndexName)
3600 ),
3601 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3603 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3604 ( ( integer(Index) ->
3605 I = Index
3606 ;
3607 Index = [I]
3608 ) ->
3609 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3610 ; is_list(Index) ->
3611 sort(Index,Indexes),
3612 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3613 once(pairup(Bodies,Keys,ArgKeyPairs)),
3614 Key =.. [k|Keys],
3615 list2conj(Bodies,KeyBody)
3616 ).
3618 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3619 ( ( integer(Index) ->
3620 I = Index
3621 ;
3622 Index = [I]
3623 ) ->
3624 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3625 ; is_list(Index) ->
3626 sort(Index,Indexes),
3627 find_with_var_identity(
3628 Goal-KeyI,
3629 [Susp/Head/VarDict],
3630 (
3631 member(I,Indexes),
3632 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3633 ),
3634 ArgKeyPairs
3635 ),
3636 once(pairup(Bodies,Keys,ArgKeyPairs)),
3637 Key =.. [k|Keys],
3638 list2conj(Bodies,KeyBody)
3639 ).
3641 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3642 arg(Index,Head,OriginalArg),
3643 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3644 Goal = true
3645 ;
3646 functor(Head,F,A),
3647 C = F/A,
3648 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3649 ).
3651 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3652 ( ( integer(Index) ->
3653 I = Index
3654 ;
3655 Index = [I]
3656 ) ->
3657 UsedVars = [I-Key]
3658 ; is_list(Index) ->
3659 sort(Index,Indexes),
3660 pairup(Indexes,Keys,UsedVars),
3661 Key =.. [k|Keys]
3662 ).
3664 multi_hash_key_args(Index,Head,KeyArgs) :-
3665 ( integer(Index) ->
3666 arg(Index,Head,Arg),
3667 KeyArgs = [Arg]
3668 ; is_list(Index) ->
3669 sort(Index,Indexes),
3670 term_variables(Head,Vars),
3671 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3672 ).
3674 global_list_store_name(F/A,Name) :-
3675 get_target_module(Mod),
3676 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
3677 global_ground_store_name(F/A,Name) :-
3678 get_target_module(Mod),
3679 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
3680 global_singleton_store_name(F/A,Name) :-
3681 get_target_module(Mod),
3682 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
3684 identifier_store_name(TypeName,Name) :-
3685 get_target_module(Mod),
3686 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
3688 :- chr_constraint prolog_global_variable/1.
3689 :- chr_option(mode,prolog_global_variable(+)).
3691 :- chr_constraint prolog_global_variables/1.
3692 :- chr_option(mode,prolog_global_variables(-)).
3694 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
3696 prolog_global_variables(List), prolog_global_variable(Name) <=>
3697 List = [Name|Tail],
3698 prolog_global_variables(Tail).
3699 prolog_global_variables(List) <=> List = [].
3701 %% SWI begin
3702 prolog_global_variables_code(Code) :-
3703 prolog_global_variables(Names),
3704 ( Names == [] ->
3705 Code = []
3706 ;
3707 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
3708 Code = [(:- dynamic user:exception/3),
3709 (:- multifile user:exception/3),
3710 (user:exception(undefined_global_variable,Name,retry) :-
3711 (
3712 '$chr_prolog_global_variable'(Name),
3713 '$chr_initialization'
3714 )
3715 )
3716 |
3717 NameDeclarations
3718 ]
3719 ).
3720 %% SWI end
3721 %% SICStus begin
3722 % prolog_global_variables_code([]).
3723 %% SICStus end
3724 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3725 %sbag_member_call(S,L,sysh:mem(S,L)).
3726 sbag_member_call(S,L,'chr sbag_member'(S,L)).
3727 %sbag_member_call(S,L,member(S,L)).
3728 update_mutable_call(A,B,'chr update_mutable'( A, B)).
3729 %update_mutable_call(A,B,setarg(1, B, A)).
3730 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
3731 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
3733 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
3734 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
3735 % create_get_mutable(Value,Field,Get1).
3736 %
3737 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
3738 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
3739 % update_mutable_call(NewValue,Field,Set).
3740 %
3741 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
3742 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
3743 % create_get_mutable_ref(Value,Field,Get1),
3744 % update_mutable_call(NewValue,Field,Set).
3745 %
3746 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
3747 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
3748 % create_mutable_call(Value,Field,Create).
3749 %
3750 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
3751 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
3752 % create_get_mutable(Value,Field,Get).
3753 %
3754 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
3755 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
3756 % create_get_mutable_ref(Value,Field,Get),
3757 % update_mutable_call(NewValue,Field,Set).
3759 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
3760 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
3762 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
3763 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3765 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
3766 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
3767 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3769 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
3770 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
3772 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
3773 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
3775 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
3776 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
3777 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3779 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3781 enumerate_stores_code(Constraints,Clause) :-
3782 Head = '$enumerate_constraints'(Constraint),
3783 enumerate_store_bodies(Constraints,Constraint,Bodies),
3784 list2disj(Bodies,Body),
3785 Clause = (Head :- Body).
3787 enumerate_store_bodies([],_,[]).
3788 enumerate_store_bodies([C|Cs],Constraint,L) :-
3789 ( is_stored(C) ->
3790 get_store_type(C,StoreType),
3791 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
3792 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
3793 C = F/_,
3794 Constraint0 =.. [F|Arguments],
3795 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
3796 L = [Body|T]
3797 ;
3798 L = T
3799 ),
3800 enumerate_store_bodies(Cs,Constraint,T).
3802 enumerate_store_body(default,C,Susp,Body) :-
3803 global_list_store_name(C,StoreName),
3804 sbag_member_call(Susp,List,Sbag),
3805 make_get_store_goal(StoreName,List,GetStoreGoal),
3806 Body =
3807 (
3808 GetStoreGoal, % nb_getval(StoreName,List),
3809 Sbag
3810 ).
3811 % get_constraint_index(C,Index),
3812 % get_target_module(Mod),
3813 % get_max_constraint_index(MaxIndex),
3814 % Body1 =
3815 % (
3816 % 'chr default_store'(GlobalStore),
3817 % get_attr(GlobalStore,Mod,Attr)
3818 % ),
3819 % ( MaxIndex > 1 ->
3820 % NIndex is Index + 1,
3821 % sbag_member_call(Susp,List,Sbag),
3822 % Body2 =
3823 % (
3824 % arg(NIndex,Attr,List),
3825 % Sbag
3826 % )
3827 % ;
3828 % sbag_member_call(Susp,Attr,Sbag),
3829 % Body2 = Sbag
3830 % ),
3831 % Body = (Body1,Body2).
3832 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
3833 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
3834 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
3835 multi_hash_enumerate_store_body(Index,C,Susp,Body).
3836 enumerate_store_body(global_ground,C,Susp,Body) :-
3837 global_ground_store_name(C,StoreName),
3838 sbag_member_call(Susp,List,Sbag),
3839 make_get_store_goal(StoreName,List,GetStoreGoal),
3840 Body =
3841 (
3842 GetStoreGoal, % nb_getval(StoreName,List),
3843 Sbag
3844 ).
3845 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
3846 Body = fail.
3847 enumerate_store_body(global_singleton,C,Susp,Body) :-
3848 global_singleton_store_name(C,StoreName),
3849 make_get_store_goal(StoreName,Susp,GetStoreGoal),
3850 Body =
3851 (
3852 GetStoreGoal, % nb_getval(StoreName,Susp),
3853 Susp \== []
3854 ).
3855 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
3856 once((
3857 member(ST,STs),
3858 enumerate_store_body(ST,C,Susp,Body)
3859 )).
3860 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
3861 Body = fail.
3862 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
3863 Body = fail.
3865 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
3866 multi_hash_store_name(C,I,StoreName),
3867 B =
3868 (
3869 nb_getval(StoreName,HT),
3870 value_iht(HT,Susp)
3871 ).
3872 multi_hash_enumerate_store_body(I,C,Susp,B) :-
3873 multi_hash_store_name(C,I,StoreName),
3874 make_get_store_goal(StoreName,HT,GetStoreGoal),
3875 B =
3876 (
3877 GetStoreGoal, % nb_getval(StoreName,HT),
3878 value_ht(HT,Susp)
3879 ).
3881 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3884 :- chr_constraint
3885 prev_guard_list/8,
3886 prev_guard_list/6,
3887 simplify_guards/1,
3888 set_all_passive/1.
3890 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
3891 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
3892 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
3893 :- chr_option(mode,simplify_guards(+)).
3894 :- chr_option(mode,set_all_passive(+)).
3896 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3897 % GUARD SIMPLIFICATION
3898 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3899 % If the negation of the guards of earlier rules entails (part of)
3900 % the current guard, the current guard can be simplified. We can only
3901 % use earlier rules with a head that matches if the head of the current
3902 % rule does, and which make it impossible for the current rule to match
3903 % if they fire (i.e. they shouldn't be propagation rules and their
3904 % head constraints must be subsets of those of the current rule).
3905 % At this point, we know for sure that the negation of the guard
3906 % of such a rule has to be true (otherwise the earlier rule would have
3907 % fired, because of the refined operational semantics), so we can use
3908 % that information to simplify the guard by replacing all entailed
3909 % conditions by true/0. As a consequence, the never-stored analysis
3910 % (in a further phase) will detect more cases of never-stored constraints.
3911 %
3912 % e.g. c(X),d(Y) <=> X > 0 | ...
3913 % e(X) <=> X < 0 | ...
3914 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
3915 % \____________/
3916 % true
3918 guard_simplification :-
3919 ( chr_pp_flag(guard_simplification,on) ->
3920 precompute_head_matchings,
3921 simplify_guards(1)
3922 ;
3923 true
3924 ).
3926 % for every rule, we create a prev_guard_list where the last argument
3927 % eventually is a list of the negations of earlier guards
3928 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
3929 <=>
3930 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
3931 append(Head1,Head2,Heads),
3932 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
3933 multiple_occ_constraints_checked([]),
3934 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
3936 append(IDs1,IDs2,IDs),
3937 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
3938 empty_q(EmptyHeap),
3939 insert_list_q(HeapData,EmptyHeap,Heap),
3940 next_prev_rule(Heap,_,Heap1),
3941 next_prev_rule(Heap1,PrevRuleNb,NHeap),
3942 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
3943 NextRule is RuleNb+1,
3944 simplify_guards(NextRule).
3946 next_prev_rule(Heap,RuleNb,NHeap) :-
3947 ( find_min_q(Heap,_-Priority) ->
3948 Priority = (-RuleNb),
3949 normalize_heap(Heap,Priority,NHeap)
3950 ;
3951 RuleNb = 0,
3952 NHeap = Heap
3953 ).
3955 normalize_heap(Heap,Priority,NHeap) :-
3956 ( find_min_q(Heap,_-Priority) ->
3957 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
3958 ( O > 1 ->
3959 NO is O -1,
3960 get_occurrence(C,NO,RuleNb,_),
3961 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
3962 ;
3963 Heap2 = Heap1
3964 ),
3965 normalize_heap(Heap2,Priority,NHeap)
3966 ;
3967 NHeap = Heap
3968 ).
3970 % no more rule
3971 simplify_guards(_)
3972 <=>
3973 true.
3975 % The negation of the guard of a non-propagation rule is added
3976 % if its kept head constraints are a subset of the kept constraints of
3977 % the rule we're working on, and its removed head constraints (at least one)
3978 % are a subset of the removed constraints.
3980 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
3981 <=>
3982 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
3983 H1 \== [],
3984 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
3985 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
3986 |
3987 append(H1,H2,Heads),
3988 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
3989 append(GuardList,DerivedInfo,GL1),
3990 normalize_conj_list(GL1,GL),
3991 append(GH_New1,GH,GH1),
3992 normalize_conj_list(GH1,GH_New),
3993 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
3994 % PrevPrevRuleNb is PrevRuleNb-1,
3995 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
3997 % if this isn't the case, we skip this one and try the next rule
3998 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
3999 <=>
4000 ( N > 0 ->
4001 next_prev_rule(Heap,N1,NHeap),
4002 % N1 is N-1,
4003 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4004 ;
4005 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4006 ).
4008 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4009 <=>
4010 GH \== []
4011 |
4012 head_types_modes_condition(GH,H,TypeInfo),
4013 conj2list(TypeInfo,TI),
4014 term_variables(H,HeadVars),
4015 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4016 normalize_conj_list(Info,InfoL),
4017 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4019 head_types_modes_condition([],H,true).
4020 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4021 types_modes_condition(H,GH,TI1),
4022 head_types_modes_condition(GHs,H,TI2).
4024 %%
4025 %
4026 % when all earlier guards are added or skipped, we simplify the guard.
4027 % if it's different from the original one, we change the rule
4029 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4030 <=>
4031 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4032 G \== true, % let's not try to simplify this ;)
4033 append(M,GuardList,Info),
4034 simplify_guard(G,B,Info,SimpleGuard,NB),
4035 G \== SimpleGuard
4036 |
4037 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4038 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4040 %% normalize_conj_list(+List,-NormalList) is det.
4041 %
4042 % Removes =true= elements and flattens out conjunctions.
4044 normalize_conj_list(List,NormalList) :-
4045 list2conj(List,Conj),
4046 conj2list(Conj,NormalList).
4048 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4049 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4050 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4052 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4053 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4054 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4055 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4056 append(Renaming1,ExtraRenaming,Renaming2),
4057 list2conj(PrevMatchings,Match),
4058 negate_b(Match,HeadsDontMatch),
4059 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4060 list2conj(HeadsMatch,HeadsMatchBut),
4061 term_variables(Renaming2,RenVars),
4062 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4063 new_vars(MGVars,RenVars,ExtraRenaming2),
4064 append(Renaming2,ExtraRenaming2,Renaming),
4065 ( PrevGuard == true -> % true can't fail
4066 Info_ = HeadsDontMatch
4067 ;
4068 negate_b(PrevGuard,TheGuardFailed),
4069 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4070 ),
4071 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4072 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4073 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4074 list2conj(RenamedMatchings_,RenamedMatchings),
4075 apply_guard_wrt_term(H,RenamedG2,GH2),
4076 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4077 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4079 simplify_guard(G,B,Info,SG,NB) :-
4080 conj2list(G,LG),
4081 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4082 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4083 list2conj(SGL,SG).
4086 new_vars([],_,[]).
4087 new_vars([A|As],RV,ER) :-
4088 ( memberchk_eq(A,RV) ->
4089 new_vars(As,RV,ER)
4090 ;
4091 ER = [A-NewA,NewA-A|ER2],
4092 new_vars(As,RV,ER2)
4093 ).
4095 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4096 %
4097 % check if a list of constraints is a subset of another list of constraints
4098 % (multiset-subset), meanwhile computing a variable renaming to convert
4099 % one into the other.
4100 head_subset(H,Head,Renaming) :-
4101 head_subset(H,Head,Renaming,[],_).
4103 head_subset([],Remainder,Renaming,Renaming,Remainder).
4104 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4105 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4106 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4108 % check if A is in the list, remove it from Headleft
4109 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4110 ( variable_replacement(A,X,Acc,Renaming),
4111 Remainder = Xs
4112 ;
4113 Remainder = [X|RRemainder],
4114 head_member(Xs,A,Renaming,Acc,RRemainder)
4115 ).
4116 %-------------------------------------------------------------------------------%
4117 % memoing code to speed up repeated computation
4119 :- chr_constraint precompute_head_matchings/0.
4121 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4122 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4123 append(H1,H2,Heads),
4124 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4125 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4126 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4128 precompute_head_matchings <=> true.
4130 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4131 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4133 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4134 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4136 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4137 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4138 <=>
4139 Q1 = NHeads,
4140 Q2 = Matchings.
4141 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4143 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4144 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4145 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4146 %-------------------------------------------------------------------------------%
4148 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4149 extract_arguments(Heads,Arguments),
4150 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4151 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4153 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4154 extract_arguments(Heads,Arguments),
4155 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4156 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4158 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4159 extract_arguments(Heads,Arguments1),
4160 extract_arguments(MatchingFreeHeads,Arguments2),
4161 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4163 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4164 %
4165 % Returns list of arguments of given list of constraints.
4166 extract_arguments([],[]).
4167 extract_arguments([Constraint|Constraints],AllArguments) :-
4168 Constraint =.. [_|Arguments],
4169 append(Arguments,RestArguments,AllArguments),
4170 extract_arguments(Constraints,RestArguments).
4172 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4173 %
4174 % Substitutes arguments of constraints with those in the given list.
4176 substitute_arguments([],[],[]).
4177 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4178 functor(Constraint,F,N),
4179 split_at(N,Variables,Arguments,RestVariables),
4180 NConstraint =.. [F|Arguments],
4181 substitute_arguments(Constraints,RestVariables,NConstraints).
4183 make_matchings_explicit([],[],_,MC,MC,[]).
4184 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4185 ( var(Arg) ->
4186 ( memberchk_eq(Arg,VarAcc) ->
4187 list2disj(MatchingCondition,MatchingCondition_disj),
4188 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4189 NVarAcc = VarAcc
4190 ;
4191 Matchings = RestMatchings,
4192 NewVar = Arg,
4193 NVarAcc = [Arg|VarAcc]
4194 ),
4195 MatchingCondition2 = MatchingCondition
4196 ;
4197 functor(Arg,F,A),
4198 Arg =.. [F|RecArgs],
4199 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4200 FlatArg =.. [F|RecVars],
4201 ( RecMatchings == [] ->
4202 Matchings = [functor(NewVar,F,A)|RestMatchings]
4203 ;
4204 list2conj(RecMatchings,ArgM_conj),
4205 list2disj(MatchingCondition,MatchingCondition_disj),
4206 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4207 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4208 ),
4209 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4210 term_variables(Args,ArgVars),
4211 append(ArgVars,VarAcc,NVarAcc)
4212 ),
4213 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4216 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4217 %
4218 % Returns list of new variables and list of pairwise unifications between given list and variables.
4220 make_matchings_explicit_not_negated([],[],[]).
4221 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4222 Matchings = [Var = X|RMatchings],
4223 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4225 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4226 %
4227 % (Partially) applies substitutions of =Goal= to given list.
4229 apply_guard_wrt_term([],_Guard,[]).
4230 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4231 ( var(Term) ->
4232 apply_guard_wrt_variable(Guard,Term,NTerm)
4233 ;
4234 Term =.. [F|HArgs],
4235 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4236 NTerm =.. [F|NewHArgs]
4237 ),
4238 apply_guard_wrt_term(RH,Guard,RGH).
4240 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4241 %
4242 % (Partially) applies goal =Guard= wrt variable.
4244 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4245 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4246 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4247 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4248 ( Guard = (X = Y), Variable == X ->
4249 NVariable = Y
4250 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4251 functor(NVariable,Functor,Arity)
4252 ;
4253 NVariable = Variable
4254 ).
4256 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4257 % ALWAYS FAILING HEADS
4258 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4260 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4261 <=>
4262 chr_pp_flag(check_impossible_rules,on),
4263 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4264 append(M,GuardList,Info),
4265 guard_entailment:entails_guard(Info,fail)
4266 |
4267 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4268 set_all_passive(RuleNb).
4270 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4271 % HEAD SIMPLIFICATION
4272 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4274 % now we check the head matchings (guard may have been simplified meanwhile)
4275 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4276 <=>
4277 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4278 simplify_heads(M,GuardList,G,B,NewM,NewB),
4279 NewM \== [],
4280 extract_arguments(Head1,VH1),
4281 extract_arguments(Head2,VH2),
4282 extract_arguments(H,VH),
4283 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4284 substitute_arguments(Head1,H1,NewH1),
4285 substitute_arguments(Head2,H2,NewH2),
4286 append(NewB,NewB_,NewBody),
4287 list2conj(NewBody,BodyMatchings),
4288 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4289 (Head1 \== NewH1 ; Head2 \== NewH2 )
4290 |
4291 rule(RuleNb,NewRule).
4293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4294 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4295 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4297 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4298 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4299 ( NH == M ->
4300 H2_ = M,
4301 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4302 ;
4303 (M = functor(X,F,A), NH == X ->
4304 length(A_args,A),
4305 (var(H2) ->
4306 NewB1 = [],
4307 H2_ =.. [F|A_args]
4308 ;
4309 H2 =.. [F|OrigArgs],
4310 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4311 H2_ =.. [F|A_args_]
4312 ),
4313 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4314 append(NewB1,NewB2,NewB)
4315 ;
4316 H2_ = H2,
4317 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4318 )
4319 ).
4321 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4322 ( NH == M ->
4323 H1_ = M,
4324 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4325 ;
4326 (M = functor(X,F,A), NH == X ->
4327 length(A_args,A),
4328 (var(H1) ->
4329 NewB1 = [],
4330 H1_ =.. [F|A_args]
4331 ;
4332 H1 =.. [F|OrigArgs],
4333 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4334 H1_ =.. [F|A_args_]
4335 ),
4336 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4337 append(NewB1,NewB2,NewB)
4338 ;
4339 H1_ = H1,
4340 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4341 )
4342 ).
4344 use_same_args([],[],[],_,_,[]).
4345 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4346 var(OA),!,
4347 Out = OA,
4348 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4349 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4350 nonvar(OA),!,
4351 ( common_variables(OA,Body) ->
4352 NewB = [NA = OA|NextB]
4353 ;
4354 NewB = NextB
4355 ),
4356 Out = NA,
4357 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4360 simplify_heads([],_GuardList,_G,_Body,[],[]).
4361 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4362 M = (A = B),
4363 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4364 guard_entailment:entails_guard(GuardList,(A=B)) ->
4365 ( common_variables(B,G-RM-GuardList) ->
4366 NewB = NextB,
4367 NewM = NextM
4368 ;
4369 ( common_variables(B,Body) ->
4370 NewB = [A = B|NextB]
4371 ;
4372 NewB = NextB
4373 ),
4374 NewM = [A|NextM]
4375 )
4376 ;
4377 ( nonvar(B), functor(B,BFu,BAr),
4378 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4379 NewB = NextB,
4380 ( common_variables(B,G-RM-GuardList) ->
4381 NewM = NextM
4382 ;
4383 NewM = [functor(A,BFu,BAr)|NextM]
4384 )
4385 ;
4386 NewM = NextM,
4387 NewB = NextB
4388 )
4389 ),
4390 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4392 common_variables(B,G) :-
4393 term_variables(B,BVars),
4394 term_variables(G,GVars),
4395 intersect_eq(BVars,GVars,L),
4396 L \== [].
4399 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4400 % ALWAYS FAILING GUARDS
4401 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4403 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4404 set_all_passive(_) <=> true.
4406 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4407 ==>
4408 chr_pp_flag(check_impossible_rules,on),
4409 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4410 conj2list(G,GL),
4411 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4412 guard_entailment:entails_guard(GL,fail)
4413 |
4414 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4415 set_all_passive(RuleNb).
4419 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4420 % OCCURRENCE SUBSUMPTION
4421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4423 :- chr_constraint
4424 first_occ_in_rule/4,
4425 next_occ_in_rule/6.
4427 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4428 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4430 :- chr_constraint multiple_occ_constraints_checked/1.
4431 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4433 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4434 occurrence(C,O,RuleNb,ID,_),
4435 occurrence(C,O2,RuleNb,ID2,_),
4436 rule(RuleNb,Rule)
4437 \
4438 multiple_occ_constraints_checked(Done)
4439 <=>
4440 O < O2,
4441 chr_pp_flag(occurrence_subsumption,on),
4442 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4443 H1 \== [],
4444 \+ memberchk_eq(C,Done)
4445 |
4446 first_occ_in_rule(RuleNb,C,O,ID),
4447 multiple_occ_constraints_checked([C|Done]).
4449 % Find first occurrence of constraint =C= in rule =RuleNb=
4450 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4451 <=>
4452 O < O2
4453 |
4454 first_occ_in_rule(RuleNb,C,O,ID).
4456 first_occ_in_rule(RuleNb,C,O,ID_o1)
4457 <=>
4458 C = F/A,
4459 functor(FreshHead,F,A),
4460 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4462 % Skip passive occurrences.
4463 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4464 <=>
4465 O2 is O+1
4466 |
4467 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4469 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)
4470 <=>
4471 O2 is O+1,
4472 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4473 |
4474 append(H1,H2,Heads),
4475 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4476 ( ExtraCond == [chr_pp_void_info] ->
4477 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4478 ;
4479 append(ExtraCond,Cond,NewCond),
4480 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4481 copy_term(GuardList,FGuardList),
4482 variable_replacement(GuardList,FGuardList,GLRepl),
4483 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4484 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4485 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4486 append(NewCond,GuardList2,BigCond),
4487 append(BigCond,GuardList3,BigCond2),
4488 copy_with_variable_replacement(M,M2,Repl),
4489 copy_with_variable_replacement(M,M3,Repl2),
4490 append(M3,BigCond2,BigCond3),
4491 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4492 list2conj(CheckCond,OccSubsum),
4493 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4494 ( OccSubsum \= chr_pp_void_info ->
4495 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4496 passive(RuleNb,ID_o2)
4497 ;
4498 true
4499 )
4500 ;
4501 true
4502 ),!,
4503 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4504 ).
4507 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4508 <=>
4509 true.
4511 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4512 <=>
4513 true.
4515 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4516 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4517 append(ID2,ID1,IDs),
4518 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4519 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4520 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4521 copy_with_variable_replacement(G,FG,Repl),
4522 extract_explicit_matchings(FG,FG2),
4523 negate_b(FG2,NotFG),
4524 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4525 ( safely_unifiable(FH,FH2), FH=FH2 ->
4526 FailCond = [(NotFG;FMPCond)]
4527 ;
4528 % in this case, not much can be done
4529 % e.g. c(f(...)), c(g(...)) <=> ...
4530 FailCond = [chr_pp_void_info]
4531 ).
4533 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4534 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4535 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4536 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4537 Cond = (chr_pp_not_in_store(H);Cond1),
4538 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4540 extract_explicit_matchings((A,B),D) :- !,
4541 ( extract_explicit_matchings(A) ->
4542 extract_explicit_matchings(B,D)
4543 ;
4544 D = (A,E),
4545 extract_explicit_matchings(B,E)
4546 ).
4547 extract_explicit_matchings(A,D) :- !,
4548 ( extract_explicit_matchings(A) ->
4549 D = true
4550 ;
4551 D = A
4552 ).
4554 extract_explicit_matchings(A=B) :-
4555 var(A), var(B), !, A=B.
4556 extract_explicit_matchings(A==B) :-
4557 var(A), var(B), !, A=B.
4559 safely_unifiable(H,I) :- var(H), !.
4560 safely_unifiable([],[]) :- !.
4561 safely_unifiable([H|Hs],[I|Is]) :- !,
4562 safely_unifiable(H,I),
4563 safely_unifiable(Hs,Is).
4564 safely_unifiable(H,I) :-
4565 nonvar(H),
4566 nonvar(I),
4567 H =.. [F|HA],
4568 I =.. [F|IA],
4569 safely_unifiable(HA,IA).
4573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4574 % TYPE INFORMATION
4575 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4577 :- chr_constraint
4578 type_definition/2,
4579 type_alias/2,
4580 constraint_type/2,
4581 get_type_definition/2,
4582 get_constraint_type/2.
4585 :- chr_option(mode,type_definition(?,?)).
4586 :- chr_option(mode,get_type_definition(?,?)).
4587 :- chr_option(mode,type_alias(?,?)).
4588 :- chr_option(mode,constraint_type(+,+)).
4589 :- chr_option(mode,get_constraint_type(+,-)).
4591 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4592 % Consistency checks of type aliases
4594 type_alias(T,T2) <=>
4595 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4596 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4597 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4599 type_alias(T1,A1), type_alias(T2,A2) <=>
4600 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4601 \+ (T1\=T2) |
4602 copy_term_nat(T1,T1_),
4603 copy_term_nat(T2,T2_),
4604 T1_ = T2_,
4605 chr_error(type_error,
4606 '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_]).
4608 type_alias(T,B) \ type_alias(X,T2) <=>
4609 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4610 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4611 chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4612 type_alias(X2,D1).
4614 oneway_unification(X,Y) :-
4615 term_variables(X,XVars),
4616 chr_runtime:lockv(XVars),
4617 X=Y,
4618 chr_runtime:unlockv(XVars).
4620 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4621 % Consistency checks of type definitions
4623 type_definition(T1,_), type_definition(T2,_)
4624 <=>
4625 functor(T1,F,A), functor(T2,F,A)
4626 |
4627 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
4629 type_definition(T1,_), type_alias(T2,_)
4630 <=>
4631 functor(T1,F,A), functor(T2,F,A)
4632 |
4633 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
4635 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4636 %% get_type_definition(+Type,-Definition) is semidet.
4637 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4639 get_type_definition(T,Def)
4640 <=>
4641 \+ ground(T)
4642 |
4643 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
4645 type_alias(T,D) \ get_type_definition(T2,Def)
4646 <=>
4647 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4648 copy_term_nat((T,D),(T1,D1)),T1=T2
4649 |
4650 ( get_type_definition(D1,Def) ->
4651 true
4652 ;
4653 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
4654 ).
4656 type_definition(T,D) \ get_type_definition(T2,Def)
4657 <=>
4658 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4659 copy_term_nat((T,D),(T1,D1)),T1=T2
4660 |
4661 Def = D1.
4663 get_type_definition(Type,Def)
4664 <=>
4665 atomic_builtin_type(Type,_,_)
4666 |
4667 Def = [Type].
4669 get_type_definition(Type,Def)
4670 <=>
4671 compound_builtin_type(Type,_,_)
4672 |
4673 Def = [Type].
4675 get_type_definition(X,Y) <=> fail.
4677 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4678 %% get_type_definition_det(+Type,-Definition) is det.
4679 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4680 get_type_definition_det(Type,Definition) :-
4681 ( get_type_definition(Type,Definition) ->
4682 true
4683 ;
4684 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
4685 ).
4687 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4688 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
4689 %
4690 % Return argument types of =ConstraintSymbol=, but fails if none where
4691 % declared.
4692 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4693 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
4694 get_constraint_type(_,_) <=> fail.
4696 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4697 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
4698 %
4699 % Like =get_constraint_type/2=, but returns list of =any= types when
4700 % no types are declared.
4701 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4702 get_constraint_type_det(ConstraintSymbol,Types) :-
4703 ( get_constraint_type(ConstraintSymbol,Types) ->
4704 true
4705 ;
4706 ConstraintSymbol = _ / N,
4707 replicate(N,any,Types)
4708 ).
4709 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4710 %% unalias_type(+Alias,-Type) is det.
4711 %
4712 % Follows alias chain until base type is reached.
4713 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4714 :- chr_constraint unalias_type/2.
4716 unalias_var @
4717 unalias_type(Alias,BaseType)
4718 <=>
4719 var(Alias)
4720 |
4721 BaseType = Alias.
4723 unalias_alias @
4724 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
4725 <=>
4726 nonvar(AliasProtoType),
4727 nonvar(Alias),
4728 functor(AliasProtoType,F,A),
4729 functor(Alias,F,A),
4730 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
4731 Alias = AliasInstance
4732 |
4733 unalias_type(Type,BaseType).
4735 unalias_type_definition @
4736 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
4737 <=>
4738 nonvar(ProtoType),
4739 nonvar(Alias),
4740 functor(ProtoType,F,A),
4741 functor(Alias,F,A)
4742 |
4743 BaseType = Alias.
4745 unalias_atomic_builtin @
4746 unalias_type(Alias,BaseType)
4747 <=>
4748 atomic_builtin_type(Alias,_,_)
4749 |
4750 BaseType = Alias.
4752 unalias_compound_builtin @
4753 unalias_type(Alias,BaseType)
4754 <=>
4755 compound_builtin_type(Alias,_,_)
4756 |
4757 BaseType = Alias.
4759 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4760 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
4761 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4762 :- chr_constraint types_modes_condition/3.
4763 :- chr_option(mode,types_modes_condition(+,+,?)).
4764 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
4766 types_modes_condition([],[],T) <=> T=true.
4768 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
4769 <=>
4770 functor(Head,F,A)
4771 |
4772 Head =.. [_|Args],
4773 Condition = (ModesCondition, TypesCondition, RestCondition),
4774 modes_condition(Modes,Args,ModesCondition),
4775 get_constraint_type_det(F/A,Types),
4776 UnrollHead =.. [_|RealArgs],
4777 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
4778 types_modes_condition(Heads,UnrollHeads,RestCondition).
4780 types_modes_condition([Head|_],_,_)
4781 <=>
4782 functor(Head,F,A),
4783 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
4786 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4787 %% modes_condition(+Modes,+Args,-Condition) is det.
4788 %
4789 % Return =Condition= on =Args= that checks =Modes=.
4790 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4791 modes_condition([],[],true).
4792 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
4793 ( Mode == (+) ->
4794 Condition = ( ground(Arg) , RCondition )
4795 ; Mode == (-) ->
4796 Condition = ( var(Arg) , RCondition )
4797 ;
4798 Condition = RCondition
4799 ),
4800 modes_condition(Modes,Args,RCondition).
4802 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4803 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
4804 %
4805 % Return =Condition= on =Args= that checks =Types= given =Modes=.
4806 % =UnrollArgs= controls the depth of type definition unrolling.
4807 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4808 types_condition([],[],[],[],true).
4809 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
4810 ( Mode == (-) ->
4811 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
4812 ;
4813 get_type_definition_det(Type,Def),
4814 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
4815 ( Mode == (+) ->
4816 TypeConditionList = TypeConditionList1
4817 ;
4818 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
4819 )
4820 ),
4821 list2disj(TypeConditionList,DisjTypeConditionList),
4822 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
4824 type_condition([],_,_,_,[]).
4825 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
4826 ( var(DefCase) ->
4827 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
4828 ; atomic_builtin_type(DefCase,Arg,Condition) ->
4829 true
4830 ; compound_builtin_type(DefCase,Arg,Condition) ->
4831 true
4832 ;
4833 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
4834 ),
4835 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
4837 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4838 :- chr_type atomic_builtin_type ---> any
4839 ; number
4840 ; float
4841 ; int
4842 ; natural
4843 ; dense_int
4844 ; chr_identifier
4845 ; chr_identifier(any).
4846 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4848 atomic_builtin_type(any,_Arg,true).
4849 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
4850 atomic_builtin_type(int,Arg,integer(Arg)).
4851 atomic_builtin_type(number,Arg,number(Arg)).
4852 atomic_builtin_type(float,Arg,float(Arg)).
4853 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
4854 atomic_builtin_type(chr_identifier,_Arg,true).
4856 compound_builtin_type(chr_identifier(_),_Arg,true).
4858 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
4859 ( nonvar(DefCase) ->
4860 functor(DefCase,F,A),
4861 ( A == 0 ->
4862 Condition = (Arg = DefCase)
4863 ; var(UnrollArg) ->
4864 Condition = functor(Arg,F,A)
4865 ; functor(UnrollArg,F,A) ->
4866 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
4867 DefCase =.. [_|ArgTypes],
4868 UnrollArg =.. [_|UnrollArgs],
4869 functor(Template,F,A),
4870 Template =.. [_|TemplateArgs],
4871 replicate(A,Mode,ArgModes),
4872 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
4873 ;
4874 Condition = functor(Arg,F,A)
4875 )
4876 ;
4877 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
4878 ).
4881 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4882 % Static type checking
4883 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4884 % Checks head constraints and CHR constraint calls in bodies.
4885 %
4886 % TODO:
4887 % - type clashes involving built-in types
4888 % - Prolog built-ins in guard and body
4889 % - indicate position in terms in error messages
4890 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4891 :- chr_constraint
4892 static_type_check/0.
4894 :- chr_type type_error_src ---> head(any) ; body(any).
4896 rule(_,Rule), static_type_check
4897 ==>
4898 copy_term_nat(Rule,RuleCopy),
4899 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
4900 (
4901 catch(
4902 ( static_type_check_heads(Head1),
4903 static_type_check_heads(Head2),
4904 conj2list(Body,GoalList),
4905 static_type_check_body(GoalList)
4906 ),
4907 type_error(Error),
4908 ( Error = invalid_functor(Src,Term,Type) ->
4909 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
4910 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
4911 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
4912 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
4913 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
4914 )
4915 ),
4916 fail % cleanup constraints
4917 ;
4918 true
4919 ).
4922 static_type_check <=> true.
4924 static_type_check_heads([]).
4925 static_type_check_heads([Head|Heads]) :-
4926 static_type_check_head(Head),
4927 static_type_check_heads(Heads).
4929 static_type_check_head(Head) :-
4930 functor(Head,F,A),
4931 get_constraint_type_det(F/A,Types),
4932 Head =..[_|Args],
4933 maplist(static_type_check_term(head(Head)),Args,Types).
4935 static_type_check_body([]).
4936 static_type_check_body([Goal|Goals]) :-
4937 functor(Goal,F,A),
4938 get_constraint_type_det(F/A,Types),
4939 Goal =..[_|Args],
4940 maplist(static_type_check_term(body(Goal)),Args,Types),
4941 static_type_check_body(Goals).
4943 :- chr_constraint static_type_check_term/3.
4944 :- chr_option(mode,static_type_check_term(?,?,?)).
4945 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
4947 static_type_check_term(Src,Term,Type)
4948 <=>
4949 var(Term)
4950 |
4951 static_type_check_var(Src,Term,Type).
4952 static_type_check_term(Src,Term,Type)
4953 <=>
4954 atomic_builtin_type(Type,Term,Goal)
4955 |
4956 ( call(Goal) ->
4957 true
4958 ;
4959 throw(type_error(invalid_functor(Src,Term,Type)))
4960 ).
4961 static_type_check_term(Src,Term,Type)
4962 <=>
4963 compound_builtin_type(Type,Term,Goal)
4964 |
4965 ( call(Goal) ->
4966 true
4967 ;
4968 throw(type_error(invalid_functor(Src,Term,Type)))
4969 ).
4970 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
4971 <=>
4972 functor(Type,F,A),
4973 functor(AType,F,A)
4974 |
4975 copy_term_nat(AType-ADef,Type-Def),
4976 static_type_check_term(Src,Term,Def).
4978 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
4979 <=>
4980 functor(Type,F,A),
4981 functor(AType,F,A)
4982 |
4983 copy_term_nat(AType-ADef,Type-Variants),
4984 functor(Term,TF,TA),
4985 ( member(Variant,Variants), functor(Variant,TF,TA) ->
4986 Term =.. [_|Args],
4987 Variant =.. [_|Types],
4988 maplist(static_type_check_term(Src),Args,Types)
4989 ;
4990 throw(type_error(invalid_functor(Src,Term,Type)))
4991 ).
4993 static_type_check_term(Src,Term,Type)
4994 <=>
4995 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
4997 :- chr_constraint static_type_check_var/3.
4998 :- chr_option(mode,static_type_check_var(?,-,?)).
4999 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5001 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5002 <=>
5003 functor(AType,F,A),
5004 functor(Type,F,A)
5005 |
5006 copy_term_nat(AType-ADef,Type-Def),
5007 static_type_check_var(Src,Var,Def).
5009 static_type_check_var(Src,Var,Type)
5010 <=>
5011 atomic_builtin_type(Type,_,_)
5012 |
5013 static_atomic_builtin_type_check_var(Src,Var,Type).
5015 static_type_check_var(Src,Var,Type)
5016 <=>
5017 compound_builtin_type(Type,_,_)
5018 |
5019 true.
5022 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5023 <=>
5024 Type1 \== Type2
5025 |
5026 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5028 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5029 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5030 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5031 :- chr_constraint static_atomic_builtin_type_check_var/3.
5032 :- chr_option(mode,static_type_check_var(?,-,+)).
5033 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5035 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5036 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5037 <=>
5038 true.
5039 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5040 <=>
5041 true.
5042 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5043 <=>
5044 true.
5045 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5046 <=>
5047 true.
5048 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5049 <=>
5050 true.
5051 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5052 <=>
5053 true.
5054 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5055 <=>
5056 true.
5057 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5058 <=>
5059 true.
5060 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5061 <=>
5062 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5064 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5065 %% format_src(+type_error_src) is det.
5066 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5067 format_src(head(Head)) :- format('head ~w',[Head]).
5068 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5070 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5071 % Dynamic type checking
5072 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5074 :- chr_constraint
5075 dynamic_type_check/0,
5076 dynamic_type_check_clauses/1,
5077 get_dynamic_type_check_clauses/1.
5079 generate_dynamic_type_check_clauses(Clauses) :-
5080 ( chr_pp_flag(debugable,on) ->
5081 dynamic_type_check,
5082 get_dynamic_type_check_clauses(Clauses0),
5083 append(Clauses0,
5084 [('$dynamic_type_check'(Type,Term) :-
5085 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5086 )],
5087 Clauses)
5088 ;
5089 Clauses = []
5090 ).
5092 type_definition(T,D), dynamic_type_check
5093 ==>
5094 copy_term_nat(T-D,Type-Definition),
5095 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5096 dynamic_type_check_clauses(DynamicChecks).
5097 type_alias(A,B), dynamic_type_check
5098 ==>
5099 copy_term_nat(A-B,Alias-Body),
5100 dynamic_type_check_alias_clause(Alias,Body,Clause),
5101 dynamic_type_check_clauses([Clause]).
5103 dynamic_type_check <=>
5104 findall(
5105 ('$dynamic_type_check'(Type,Term) :- Goal),
5106 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
5107 BuiltinChecks
5108 ),
5109 dynamic_type_check_clauses(BuiltinChecks).
5111 dynamic_type_check_clause(T,DC,Clause) :-
5112 copy_term(T-DC,Type-DefinitionClause),
5113 functor(DefinitionClause,F,A),
5114 functor(Term,F,A),
5115 DefinitionClause =.. [_|DCArgs],
5116 Term =.. [_|TermArgs],
5117 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5118 list2conj(RecursiveCallList,RecursiveCalls),
5119 Clause = (
5120 '$dynamic_type_check'(Type,Term) :-
5121 RecursiveCalls
5122 ).
5124 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5125 Clause = (
5126 '$dynamic_type_check'(Alias,Term) :-
5127 '$dynamic_type_check'(Body,Term)
5128 ).
5130 dynamic_type_check_call(Type,Term,Call) :-
5131 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5132 % Call = when(nonvar(Term),Goal)
5133 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5134 % Call = when(nonvar(Term),Goal)
5135 % ;
5136 ( Type == any ->
5137 Call = true
5138 ;
5139 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5140 )
5141 % )
5142 .
5144 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5145 <=>
5146 append(C1,C2,C),
5147 dynamic_type_check_clauses(C).
5149 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5150 <=>
5151 Q = C.
5152 get_dynamic_type_check_clauses(Q)
5153 <=>
5154 Q = [].
5156 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5157 % Atomic Types
5158 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5159 % Some optimizations can be applied for atomic types...
5160 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5162 atomic_types_suspended_constraint(C) :-
5163 C = _/N,
5164 get_constraint_type(C,ArgTypes),
5165 get_constraint_mode(C,ArgModes),
5166 findall(I,between(1,N,I),Indexes),
5167 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5169 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5170 ( is_indexed_argument(C,Index) ->
5171 ( Mode == (?) ->
5172 atomic_type(Type)
5173 ;
5174 true
5175 )
5176 ;
5177 true
5178 ).
5180 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5181 %% atomic_type(+Type) is semidet.
5182 %
5183 % Succeeds when all values of =Type= are atomic.
5184 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5185 :- chr_constraint atomic_type/1.
5187 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5189 type_definition(TypePat,Def) \ atomic_type(Type)
5190 <=>
5191 functor(Type,F,A), functor(TypePat,F,A)
5192 |
5193 forall(member(Term,Def),atomic(Term)).
5195 type_alias(TypePat,Alias) \ atomic_type(Type)
5196 <=>
5197 functor(Type,F,A), functor(TypePat,F,A)
5198 |
5199 atomic(Alias),
5200 copy_term_nat(TypePat-Alias,Type-NType),
5201 atomic_type(NType).
5203 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5205 :- chr_constraint
5206 stored/3, % constraint,occurrence,(yes/no/maybe)
5207 stored_completing/3,
5208 stored_complete/3,
5209 is_stored/1,
5210 is_finally_stored/1,
5211 check_all_passive/2.
5213 :- chr_option(mode,stored(+,+,+)).
5214 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5215 :- chr_type storedinfo ---> yes ; no ; maybe.
5216 :- chr_option(mode,stored_complete(+,+,+)).
5217 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5218 :- chr_option(mode,guard_list(+,+,+,+)).
5219 :- chr_option(mode,check_all_passive(+,+)).
5220 :- chr_option(type_declaration,check_all_passive(any,list)).
5222 % change yes in maybe when yes becomes passive
5223 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5224 stored(C,O,yes), stored_complete(C,RO,Yesses)
5225 <=> O < RO | NYesses is Yesses - 1,
5226 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5227 % change yes in maybe when not observed
5228 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5229 <=> O < RO |
5230 NYesses is Yesses - 1,
5231 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5233 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5234 ==> RO =< MO2 | % C2 is never stored
5235 passive(RuleNb,ID).
5240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5242 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5243 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5244 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5246 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5247 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5248 check_all_passive(RuleNb,IDs2).
5250 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5251 check_all_passive(RuleNb,IDs).
5253 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5254 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5256 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5258 % collect the storage information
5259 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5260 <=> NO is O + 1, NYesses is Yesses + 1,
5261 stored_completing(C,NO,NYesses).
5262 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5263 <=> NO is O + 1,
5264 stored_completing(C,NO,Yesses).
5266 stored(C,O,no) \ stored_completing(C,O,Yesses)
5267 <=> stored_complete(C,O,Yesses).
5268 stored_completing(C,O,Yesses)
5269 <=> stored_complete(C,O,Yesses).
5271 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5272 O2 > O | passive(RuleNb,Id).
5274 % decide whether a constraint is stored
5275 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5276 <=> RO =< MO | fail.
5277 is_stored(C) <=> true.
5279 % decide whether a constraint is suspends after occurrences
5280 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5281 <=> RO =< MO | fail.
5282 is_finally_stored(C) <=> true.
5284 storage_analysis(Constraints) :-
5285 ( chr_pp_flag(storage_analysis,on) ->
5286 check_constraint_storages(Constraints)
5287 ;
5288 true
5289 ).
5291 check_constraint_storages([]).
5292 check_constraint_storages([C|Cs]) :-
5293 check_constraint_storage(C),
5294 check_constraint_storages(Cs).
5296 check_constraint_storage(C) :-
5297 get_max_occurrence(C,MO),
5298 check_occurrences_storage(C,1,MO).
5300 check_occurrences_storage(C,O,MO) :-
5301 ( O > MO ->
5302 stored_completing(C,1,0)
5303 ;
5304 check_occurrence_storage(C,O),
5305 NO is O + 1,
5306 check_occurrences_storage(C,NO,MO)
5307 ).
5309 check_occurrence_storage(C,O) :-
5310 get_occurrence(C,O,RuleNb,ID),
5311 ( is_passive(RuleNb,ID) ->
5312 stored(C,O,maybe)
5313 ;
5314 get_rule(RuleNb,PragmaRule),
5315 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5316 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5317 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5318 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5319 check_storage_head2(Head2,O,Heads1,Body)
5320 )
5321 ).
5323 check_storage_head1(Head,O,H1,H2,G) :-
5324 functor(Head,F,A),
5325 C = F/A,
5326 ( H1 == [Head],
5327 H2 == [],
5328 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5329 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5330 Head =.. [_|L],
5331 no_matching(L,[]) ->
5332 stored(C,O,no)
5333 ;
5334 stored(C,O,maybe)
5335 ).
5337 no_matching([],_).
5338 no_matching([X|Xs],Prev) :-
5339 var(X),
5340 \+ memberchk_eq(X,Prev),
5341 no_matching(Xs,[X|Prev]).
5343 check_storage_head2(Head,O,H1,B) :-
5344 functor(Head,F,A),
5345 C = F/A,
5346 ( %(
5347 ( H1 \== [], B == true )
5348 %;
5349 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5350 %)
5351 ->
5352 stored(C,O,maybe)
5353 ;
5354 stored(C,O,yes)
5355 ).
5357 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5360 %% ____ _ ____ _ _ _ _
5361 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5362 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5363 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5364 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5365 %% |_|
5367 constraints_code(Constraints,Clauses) :-
5368 (chr_pp_flag(reduced_indexing,on),
5369 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5370 none_suspended_on_variables
5371 ;
5372 true
5373 ),
5374 constraints_code1(Constraints,Clauses,[]).
5376 %===============================================================================
5377 :- chr_constraint constraints_code1/3.
5378 :- chr_option(mode,constraints_code1(+,+,+)).
5379 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5380 %-------------------------------------------------------------------------------
5381 constraints_code1([],L,T) <=> L = T.
5382 constraints_code1([C|RCs],L,T)
5383 <=>
5384 constraint_code(C,L,T1),
5385 constraints_code1(RCs,T1,T).
5386 %===============================================================================
5387 :- chr_constraint constraint_code/3.
5388 :- chr_option(mode,constraint_code(+,+,+)).
5389 %-------------------------------------------------------------------------------
5390 %% Generate code for a single CHR constraint
5391 constraint_code(Constraint, L, T)
5392 <=> true
5393 | ( (chr_pp_flag(debugable,on) ;
5394 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5395 ( may_trigger(Constraint) ;
5396 get_allocation_occurrence(Constraint,AO),
5397 get_max_occurrence(Constraint,MO), MO >= AO ) )
5398 ->
5399 constraint_prelude(Constraint,Clause),
5400 add_dummy_location(Clause,LocatedClause),
5401 L = [LocatedClause | L1]
5402 ;
5403 L = L1
5404 ),
5405 Id = [0],
5406 occurrences_code(Constraint,1,Id,NId,L1,L2),
5407 gen_cond_attach_clause(Constraint,NId,L2,T).
5409 %===============================================================================
5410 %% Generate prelude predicate for a constraint.
5411 %% f(...) :- f/a_0(...,Susp).
5412 constraint_prelude(F/A, Clause) :-
5413 vars_susp(A,Vars,Susp,VarsSusp),
5414 Head =.. [ F | Vars],
5415 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5416 build_head(F,A,[0],VarsSusp,Delegate),
5417 ( chr_pp_flag(debugable,on) ->
5418 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5419 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5420 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5421 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5423 ( get_constraint_type(F/A,ArgTypeList) ->
5424 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5425 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5426 ;
5427 DynamicTypeChecks = true
5428 ),
5430 Clause =
5431 ( Head :-
5432 DynamicTypeChecks,
5433 InsertGoal,
5434 InsertCall,
5435 AttachCall,
5436 Inactive,
5437 'chr debug_event'(insert(Head#Susp)),
5438 (
5439 'chr debug_event'(call(Susp)),
5440 Delegate
5441 ;
5442 'chr debug_event'(fail(Susp)), !,
5443 fail
5444 ),
5445 (
5446 'chr debug_event'(exit(Susp))
5447 ;
5448 'chr debug_event'(redo(Susp)),
5449 fail
5450 )
5451 )
5452 ; get_allocation_occurrence(F/A,0) ->
5453 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5454 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5455 Clause = ( Head :- Goal, Inactive, Delegate )
5456 ;
5457 Clause = ( Head :- Delegate )
5458 ).
5460 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5461 ( may_trigger(F/A) ->
5462 build_head(F,A,[0],VarsSusp,Delegate),
5463 ( chr_pp_flag(debugable,off) ->
5464 Goal = Delegate
5465 ;
5466 get_target_module(Mod),
5467 Goal = Mod:Delegate
5468 )
5469 ;
5470 Goal = true
5471 ).
5473 %===============================================================================
5474 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5475 :- chr_option(mode,has_active_occurrence(+)).
5476 :- chr_option(mode,has_active_occurrence(+,+)).
5477 %-------------------------------------------------------------------------------
5478 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5480 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5481 O > MO | fail.
5482 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5483 has_active_occurrence(C,O) <=>
5484 NO is O + 1,
5485 has_active_occurrence(C,NO).
5486 has_active_occurrence(C,O) <=> true.
5487 %===============================================================================
5489 gen_cond_attach_clause(F/A,Id,L,T) :-
5490 ( is_finally_stored(F/A) ->
5491 get_allocation_occurrence(F/A,AllocationOccurrence),
5492 get_max_occurrence(F/A,MaxOccurrence),
5493 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5494 ( only_ground_indexed_arguments(F/A) ->
5495 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5496 ;
5497 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5498 )
5499 ; vars_susp(A,Args,Susp,AllArgs),
5500 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5501 ),
5502 build_head(F,A,Id,AllArgs,Head),
5503 Clause = ( Head :- Body ),
5504 add_dummy_location(Clause,LocatedClause),
5505 L = [LocatedClause | T]
5506 ;
5507 L = T
5508 ).
5510 :- chr_constraint use_auxiliary_predicate/1.
5511 :- chr_option(mode,use_auxiliary_predicate(+)).
5513 :- chr_constraint use_auxiliary_predicate/2.
5514 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5516 :- chr_constraint is_used_auxiliary_predicate/1.
5517 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5519 :- chr_constraint is_used_auxiliary_predicate/2.
5520 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5523 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5525 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5527 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5529 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5531 is_used_auxiliary_predicate(P) <=> fail.
5533 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5534 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5536 is_used_auxiliary_predicate(P,C) <=> fail.
5538 %------------------------------------------------------------------------------%
5539 % Only generate import statements for actually used modules.
5540 %------------------------------------------------------------------------------%
5542 :- chr_constraint use_auxiliary_module/1.
5543 :- chr_option(mode,use_auxiliary_module(+)).
5545 :- chr_constraint is_used_auxiliary_module/1.
5546 :- chr_option(mode,is_used_auxiliary_module(+)).
5549 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5551 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5553 is_used_auxiliary_module(P) <=> fail.
5555 % only called for constraints with
5556 % at least one
5557 % non-ground indexed argument
5558 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5559 vars_susp(A,Args,Susp,AllArgs),
5560 make_suspension_continuation_goal(F/A,AllArgs,Closure),
5561 ( get_store_type(F/A,var_assoc_store(_,_)) ->
5562 Attach = true
5563 ;
5564 attach_constraint_atom(F/A,Vars,Susp,Attach)
5565 ),
5566 FTerm =.. [F|Args],
5567 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5568 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5569 ( may_trigger(F/A) ->
5570 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
5571 Goal =
5572 (
5573 ( var(Susp) ->
5574 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
5575 InsertCall,
5576 Attach
5577 ;
5578 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
5579 )
5580 )
5581 ;
5582 Goal =
5583 (
5584 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
5585 InsertCall,
5586 Attach
5587 )
5588 ).
5590 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
5591 vars_susp(A,Args,Susp,AllArgs),
5592 make_suspension_continuation_goal(F/A,AllArgs,Cont),
5593 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
5594 attach_constraint_atom(F/A,Vars,Susp,Attach)
5595 ;
5596 Attach = true
5597 ),
5598 FTerm =.. [F|Args],
5599 insert_constraint_goal(F/A,Susp,Args,InsertCall),
5600 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
5601 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
5602 Goal =
5603 (
5604 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
5605 InsertCall
5606 )
5607 ;
5608 Goal =
5609 (
5610 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
5611 InsertCall,
5612 Attach
5613 )
5614 ).
5616 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
5617 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5618 attach_constraint_atom(FA,Vars,Susp,Attach)
5619 ;
5620 Attach = true
5621 ),
5622 insert_constraint_goal(FA,Susp,Args,InsertCall),
5623 ( chr_pp_flag(late_allocation,on) ->
5624 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
5625 ;
5626 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
5627 ).
5629 %-------------------------------------------------------------------------------
5630 :- chr_constraint occurrences_code/6.
5631 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
5632 %-------------------------------------------------------------------------------
5633 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
5634 <=> O > MO
5635 | NId = Id, L = T.
5636 occurrences_code(C,O,Id,NId,L,T)
5637 <=>
5638 occurrence_code(C,O,Id,Id1,L,L1),
5639 NO is O + 1,
5640 occurrences_code(C,NO,Id1,NId,L1,T).
5641 %-------------------------------------------------------------------------------
5642 :- chr_constraint occurrence_code/6.
5643 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
5644 %-------------------------------------------------------------------------------
5645 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
5646 <=>
5647 ( named_history(RuleNb,_,_) ->
5648 does_use_history(C,O)
5649 ;
5650 true
5651 ),
5652 NId = Id,
5653 L = T.
5654 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
5655 <=> true |
5656 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
5657 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5658 NId = Id,
5659 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
5660 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5661 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
5662 inc_id(Id,NId),
5663 ( unconditional_occurrence(C,O) ->
5664 L1 = T
5665 ;
5666 gen_alloc_inc_clause(C,O,Id,L1,T)
5667 )
5668 ).
5670 occurrence_code(C,O,_,_,_,_)
5671 <=>
5672 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
5673 %-------------------------------------------------------------------------------
5675 %% Generate code based on one removed head of a CHR rule
5676 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5677 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5678 Rule = rule(_,Head2,_,_),
5679 ( Head2 == [] ->
5680 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5681 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
5682 ;
5683 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5684 ).
5686 %% Generate code based on one persistent head of a CHR rule
5687 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5688 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5689 Rule = rule(Head1,_,_,_),
5690 ( Head1 == [] ->
5691 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5692 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
5693 ;
5694 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5695 ).
5697 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
5698 vars_susp(A,Vars,Susp,VarsSusp),
5699 build_head(F,A,Id,VarsSusp,Head),
5700 inc_id(Id,IncId),
5701 build_head(F,A,IncId,VarsSusp,CallHead),
5702 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
5703 Clause =
5704 (
5705 Head :-
5706 ConditionalAlloc,
5707 CallHead
5708 ),
5709 add_dummy_location(Clause,LocatedClause),
5710 L = [LocatedClause|T].
5712 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
5713 get_allocation_occurrence(FA,AO),
5714 ( chr_pp_flag(debugable,off), O == AO ->
5715 allocate_constraint_goal(FA,Susp,Vars,Goal0),
5716 ( may_trigger(FA) ->
5717 Goal = (var(Susp) -> Goal0 ; true)
5718 ;
5719 Goal = Goal0
5720 )
5721 ;
5722 Goal = true
5723 ).
5725 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
5726 get_allocation_occurrence(FA,AO),
5727 ( chr_pp_flag(debugable,off), O < AO ->
5728 allocate_constraint_goal(FA,Susp,Vars,Goal0),
5729 ( may_trigger(FA) ->
5730 Goal = (var(Susp) -> Goal0 ; true)
5731 ;
5732 Goal = Goal0
5733 )
5734 ;
5735 Goal = true
5736 ).
5738 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5740 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5741 %
5742 % Reorders guard goals with respect to partner constraint retrieval goals and
5743 % active constraint. Returns combined partner retrieval + guard goal.
5745 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
5746 ( chr_pp_flag(guard_via_reschedule,on) ->
5747 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
5748 list2conj(ScheduleSkeleton,GoalSkeleton)
5749 ;
5750 length(Retrievals,RL), length(LookupSkeleton,RL),
5751 length(GuardList,GL), length(GuardListSkeleton,GL),
5752 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
5753 list2conj(GoalListSkeleton,GoalSkeleton)
5754 ).
5755 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
5756 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
5757 initialize_unit_dictionary(ActiveHead,Dict),
5758 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
5759 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
5760 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
5761 dependency_reorder(Units,NUnits),
5762 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
5763 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
5764 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
5766 wrap_in_functor(Functor,X,Term) :-
5767 Term =.. [Functor,X].
5769 wrappedunits2lists([],[],[],[]).
5770 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
5771 Ss = [GoalCopy|TSs],
5772 ( WrappedGoal = lookup(Goal) ->
5773 Ls = [GoalCopy|TLs],
5774 Gs = TGs
5775 ; WrappedGoal = guard(Goal) ->
5776 Gs = [N-GoalCopy|TGs],
5777 Ls = TLs
5778 ),
5779 wrappedunits2lists(Units,TGs,TLs,TSs).
5781 guard_splitting(Rule,SplitGuardList) :-
5782 Rule = rule(H1,H2,Guard,_),
5783 append(H1,H2,Heads),
5784 conj2list(Guard,GuardList),
5785 term_variables(Heads,HeadVars),
5786 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
5787 append(GuardPrefix,[RestGuard],SplitGuardList),
5788 term_variables(RestGuardList,GuardVars1),
5789 % variables that are declared to be ground don't need to be locked
5790 ground_vars(Heads,GroundVars),
5791 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
5792 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
5793 ( chr_pp_flag(guard_locks,on),
5794 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
5795 once(pairup(Locks,Unlocks,LocksUnlocks))
5796 ;
5797 Locks = [],
5798 Unlocks = []
5799 ),
5800 list2conj(Locks,LockPhase),
5801 list2conj(Unlocks,UnlockPhase),
5802 list2conj(RestGuardList,RestGuard1),
5803 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
5805 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
5806 Rule = rule(_,_,_,Body),
5807 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
5808 my_term_copy(Body,VarDict2,BodyCopy).
5811 split_off_simple_guard_new([],_,[],[]).
5812 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
5813 ( simple_guard_new(G,VarDict) ->
5814 S = [G|Ss],
5815 split_off_simple_guard_new(Gs,VarDict,Ss,C)
5816 ;
5817 S = [],
5818 C = [G|Gs]
5819 ).
5821 % simple guard: cheap and benign (does not bind variables)
5822 simple_guard_new(G,Vars) :-
5823 builtin_binds_b(G,BoundVars),
5824 \+ (( member(V,BoundVars),
5825 memberchk_eq(V,Vars)
5826 )).
5828 dependency_reorder(Units,NUnits) :-
5829 dependency_reorder(Units,[],NUnits).
5831 dependency_reorder([],Acc,Result) :-
5832 reverse(Acc,Result).
5834 dependency_reorder([Unit|Units],Acc,Result) :-
5835 Unit = unit(_GID,_Goal,Type,GIDs),
5836 ( Type == fixed ->
5837 NAcc = [Unit|Acc]
5838 ;
5839 dependency_insert(Acc,Unit,GIDs,NAcc)
5840 ),
5841 dependency_reorder(Units,NAcc,Result).
5843 dependency_insert([],Unit,_,[Unit]).
5844 dependency_insert([X|Xs],Unit,GIDs,L) :-
5845 X = unit(GID,_,_,_),
5846 ( memberchk(GID,GIDs) ->
5847 L = [Unit,X|Xs]
5848 ;
5849 L = [X | T],
5850 dependency_insert(Xs,Unit,GIDs,T)
5851 ).
5853 build_units(Retrievals,Guard,InitialDict,Units) :-
5854 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
5855 build_guard_units(Guard,N,Dict,Tail).
5857 build_retrieval_units([],N,N,Dict,Dict,L,L).
5858 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
5859 term_variables(U,Vs),
5860 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
5861 L = [unit(N,U,fixed,GIDs)|L1],
5862 N1 is N + 1,
5863 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
5865 initialize_unit_dictionary(Term,Dict) :-
5866 term_variables(Term,Vars),
5867 pair_all_with(Vars,0,Dict).
5869 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
5870 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
5871 ( lookup_eq(Dict,V,GID) ->
5872 ( (GID == This ; memberchk(GID,GIDs) ) ->
5873 GIDs1 = GIDs
5874 ;
5875 GIDs1 = [GID|GIDs]
5876 ),
5877 Dict1 = Dict
5878 ;
5879 Dict1 = [V - This|Dict],
5880 GIDs1 = GIDs
5881 ),
5882 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
5884 build_guard_units(Guard,N,Dict,Units) :-
5885 ( Guard = [Goal] ->
5886 Units = [unit(N,Goal,fixed,[])]
5887 ; Guard = [Goal|Goals] ->
5888 term_variables(Goal,Vs),
5889 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
5890 Units = [unit(N,Goal,movable,GIDs)|RUnits],
5891 N1 is N + 1,
5892 build_guard_units(Goals,N1,NDict,RUnits)
5893 ).
5895 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
5896 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
5897 ( lookup_eq(Dict,V,GID) ->
5898 ( (GID == This ; memberchk(GID,GIDs) ) ->
5899 GIDs1 = GIDs
5900 ;
5901 GIDs1 = [GID|GIDs]
5902 ),
5903 Dict1 = [V - This|Dict]
5904 ;
5905 Dict1 = [V - This|Dict],
5906 GIDs1 = GIDs
5907 ),
5908 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
5910 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5912 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5913 %% ____ _ ____ _ _
5914 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
5915 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
5916 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
5917 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
5918 %%
5919 %% _ _ _ ___ __
5920 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
5921 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
5922 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
5923 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
5924 %% |_|
5925 :- chr_constraint
5926 functional_dependency/4,
5927 get_functional_dependency/4.
5929 :- chr_option(mode,functional_dependency(+,+,?,?)).
5930 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
5932 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
5933 <=>
5934 RuleNb > 1, AO > O
5935 |
5936 functional_dependency(C,1,Pattern,Key).
5938 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
5939 <=>
5940 RuleNb2 >= RuleNb1
5941 |
5942 QPattern = Pattern, QKey = Key.
5943 get_functional_dependency(_,_,_,_)
5944 <=>
5945 fail.
5947 functional_dependency_analysis(Rules) :-
5948 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
5949 functional_dependency_analysis_main(Rules)
5950 ;
5951 true
5952 ).
5954 functional_dependency_analysis_main([]).
5955 functional_dependency_analysis_main([PRule|PRules]) :-
5956 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
5957 functional_dependency(C,RuleNb,Pattern,Key)
5958 ;
5959 true
5960 ),
5961 functional_dependency_analysis_main(PRules).
5963 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
5964 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
5965 Rule = rule(H1,H2,Guard,_),
5966 ( H1 = [C1],
5967 H2 = [C2] ->
5968 true
5969 ; H1 = [C1,C2],
5970 H2 == [] ->
5971 true
5972 ),
5973 check_unique_constraints(C1,C2,Guard,RuleNb,List),
5974 term_variables(C1,Vs),
5975 \+ (
5976 member(V1,Vs),
5977 lookup_eq(List,V1,V2),
5978 memberchk_eq(V2,Vs)
5979 ),
5980 select_pragma_unique_variables(Vs,List,Key1),
5981 copy_term_nat(C1-Key1,Pattern-Key),
5982 functor(C1,F,A).
5984 select_pragma_unique_variables([],_,[]).
5985 select_pragma_unique_variables([V|Vs],List,L) :-
5986 ( lookup_eq(List,V,_) ->
5987 L = T
5988 ;
5989 L = [V|T]
5990 ),
5991 select_pragma_unique_variables(Vs,List,T).
5993 % depends on functional dependency analysis
5994 % and shape of rule: C1 \ C2 <=> true.
5995 set_semantics_rules(Rules) :-
5996 ( fail, chr_pp_flag(set_semantics_rule,on) ->
5997 set_semantics_rules_main(Rules)
5998 ;
5999 true
6000 ).
6002 set_semantics_rules_main([]).
6003 set_semantics_rules_main([R|Rs]) :-
6004 set_semantics_rule_main(R),
6005 set_semantics_rules_main(Rs).
6007 set_semantics_rule_main(PragmaRule) :-
6008 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6009 ( Rule = rule([C1],[C2],true,_),
6010 IDs = ids([ID1],[ID2]),
6011 \+ is_passive(RuleNb,ID1),
6012 functor(C1,F,A),
6013 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6014 copy_term_nat(Pattern-Key,C1-Key1),
6015 copy_term_nat(Pattern-Key,C2-Key2),
6016 Key1 == Key2 ->
6017 passive(RuleNb,ID2)
6018 ;
6019 true
6020 ).
6022 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6023 \+ any_passive_head(RuleNb),
6024 variable_replacement(C1-C2,C2-C1,List),
6025 copy_with_variable_replacement(G,OtherG,List),
6026 negate_b(G,NotG),
6027 once(entails_b(NotG,OtherG)).
6029 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6030 % where C1 and C2 are symmteric constraints
6031 symmetry_analysis(Rules) :-
6032 ( chr_pp_flag(check_unnecessary_active,off) ->
6033 true
6034 ;
6035 symmetry_analysis_main(Rules)
6036 ).
6038 symmetry_analysis_main([]).
6039 symmetry_analysis_main([R|Rs]) :-
6040 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6041 Rule = rule(H1,H2,_,_),
6042 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6043 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6044 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6045 ;
6046 true
6047 ),
6048 symmetry_analysis_main(Rs).
6050 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6051 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6052 ( \+ is_passive(RuleNb,ID),
6053 member2(PreHs,PreIDs,PreH-PreID),
6054 \+ is_passive(RuleNb,PreID),
6055 variable_replacement(PreH,H,List),
6056 copy_with_variable_replacement(Rule,Rule2,List),
6057 identical_guarded_rules(Rule,Rule2) ->
6058 passive(RuleNb,ID)
6059 ;
6060 true
6061 ),
6062 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6064 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6065 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6066 ( \+ is_passive(RuleNb,ID),
6067 member2(PreHs,PreIDs,PreH-PreID),
6068 \+ is_passive(RuleNb,PreID),
6069 variable_replacement(PreH,H,List),
6070 copy_with_variable_replacement(Rule,Rule2,List),
6071 identical_rules(Rule,Rule2) ->
6072 passive(RuleNb,ID)
6073 ;
6074 true
6075 ),
6076 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6078 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6080 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6081 %% ____ _ _ _ __ _ _ _
6082 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6083 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6084 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6085 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6086 %% |_|
6088 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6089 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6090 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6091 build_head(F,A,Id,HeadVars,ClauseHead),
6092 get_constraint_mode(F/A,Mode),
6093 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6096 guard_splitting(Rule,GuardList0),
6097 ( is_stored_in_guard(F/A, RuleNb) ->
6098 GuardList = [Hole1|GuardList0]
6099 ;
6100 GuardList = GuardList0
6101 ),
6102 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6104 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6106 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6108 ( is_stored_in_guard(F/A, RuleNb) ->
6109 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6110 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6111 GuardCopyList = [Hole1Copy|_],
6112 Hole1Copy = (Allocation, Attachment)
6113 ;
6114 true
6115 ),
6118 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6119 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6121 ( chr_pp_flag(debugable,on) ->
6122 Rule = rule(_,_,Guard,Body),
6123 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6124 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6125 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6126 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6127 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6128 ;
6129 Cut = ActualCut
6130 ),
6131 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6132 Clause = ( ClauseHead :-
6133 FirstMatching,
6134 RescheduledTest,
6135 Cut,
6136 SuspsDetachments,
6137 SuspDetachment,
6138 BodyCopy
6139 ),
6140 add_location(Clause,RuleNb,LocatedClause),
6141 L = [LocatedClause | T].
6143 add_location(Clause,RuleNb,NClause) :-
6144 ( chr_pp_flag(line_numbers,on) ->
6145 get_chr_source_file(File),
6146 get_line_number(RuleNb,LineNb),
6147 NClause = '$source_location'(File,LineNb):Clause
6148 ;
6149 NClause = Clause
6150 ).
6152 add_dummy_location(Clause,NClause) :-
6153 ( chr_pp_flag(line_numbers,on) ->
6154 get_chr_source_file(File),
6155 NClause = '$source_location'(File,1):Clause
6156 ;
6157 NClause = Clause
6158 ).
6159 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6160 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6161 %
6162 % Return goal matching newly introduced variables with variables in
6163 % previously looked-up heads.
6164 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6165 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6166 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6168 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6169 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6170 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6171 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6172 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6173 list2conj(GoalList,Goal).
6175 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6176 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6177 ( var(Arg) ->
6178 ( lookup_eq(VarDict,Arg,OtherVar) ->
6179 ( Mode = (+) ->
6180 ( memberchk_eq(Arg,GroundVars) ->
6181 GoalList = [Var = OtherVar | RestGoalList],
6182 GroundVars1 = GroundVars
6183 ;
6184 GoalList = [Var == OtherVar | RestGoalList],
6185 GroundVars1 = [Arg|GroundVars]
6186 )
6187 ;
6188 GoalList = [Var == OtherVar | RestGoalList],
6189 GroundVars1 = GroundVars
6190 ),
6191 VarDict1 = VarDict
6192 ;
6193 VarDict1 = [Arg-Var | VarDict],
6194 GoalList = RestGoalList,
6195 ( Mode = (+) ->
6196 GroundVars1 = [Arg|GroundVars]
6197 ;
6198 GroundVars1 = GroundVars
6199 )
6200 ),
6201 Pairs = Rest,
6202 RestModes = Modes
6203 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6204 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6205 GoalList = [Goal|RestGoalList],
6206 VarDict = VarDict1,
6207 GroundVars1 = GroundVars,
6208 Pairs = Rest,
6209 RestModes = Modes
6210 ; atomic(Arg) ->
6211 ( Mode = (+) ->
6212 GoalList = [ Var = Arg | RestGoalList]
6213 ;
6214 GoalList = [ Var == Arg | RestGoalList]
6215 ),
6216 VarDict = VarDict1,
6217 GroundVars1 = GroundVars,
6218 Pairs = Rest,
6219 RestModes = Modes
6220 ; Mode == (+), is_ground(GroundVars,Arg) ->
6221 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6222 GoalList = [ Var = ArgCopy | RestGoalList],
6223 VarDict = VarDict1,
6224 GroundVars1 = GroundVars,
6225 Pairs = Rest,
6226 RestModes = Modes
6227 ; Arg =.. [_|Args],
6228 functor(Arg,Fct,N),
6229 functor(Term,Fct,N),
6230 Term =.. [_|Vars],
6231 ( Mode = (+) ->
6232 GoalList = [ Var = Term | RestGoalList ]
6233 ;
6234 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6235 ),
6236 pairup(Args,Vars,NewPairs),
6237 append(NewPairs,Rest,Pairs),
6238 replicate(N,Mode,NewModes),
6239 append(NewModes,Modes,RestModes),
6240 VarDict1 = VarDict,
6241 GroundVars1 = GroundVars
6242 ),
6243 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6245 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6246 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6247 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6248 add_heads_types([],VarTypes,VarTypes).
6249 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6250 add_head_types(Head,VarTypes,VarTypes1),
6251 add_heads_types(Heads,VarTypes1,NVarTypes).
6253 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6254 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6255 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6256 add_head_types(Head,VarTypes,NVarTypes) :-
6257 functor(Head,F,A),
6258 get_constraint_type_det(F/A,ArgTypes),
6259 Head =.. [_|Args],
6260 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6262 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6263 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6264 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6265 add_args_types([],[],VarTypes,VarTypes).
6266 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6267 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6268 add_args_types(Args,Types,VarTypes1,NVarTypes).
6270 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6271 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6272 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6273 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6274 ( var(Term) ->
6275 ( lookup_eq(VarTypes,Term,_) ->
6276 NVarTypes = VarTypes
6277 ;
6278 NVarTypes = [Term-Type|VarTypes]
6279 )
6280 ; ground(Term) ->
6281 NVarTypes = VarTypes
6282 ; % TODO improve approximation!
6283 term_variables(Term,Vars),
6284 length(Vars,VarNb),
6285 replicate(VarNb,any,Types),
6286 add_args_types(Vars,Types,VarTypes,NVarTypes)
6287 ).
6291 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6292 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6293 %
6294 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6295 add_heads_ground_variables([],GroundVars,GroundVars).
6296 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6297 add_head_ground_variables(Head,GroundVars,GroundVars1),
6298 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6300 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6301 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6302 %
6303 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6304 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6305 functor(Head,F,A),
6306 get_constraint_mode(F/A,ArgModes),
6307 Head =.. [_|Args],
6308 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6311 add_arg_ground_variables([],[],GroundVars,GroundVars).
6312 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6313 ( Mode == (+) ->
6314 term_variables(Arg,Vars),
6315 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6316 ;
6317 GroundVars = GroundVars1
6318 ),
6319 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6321 add_var_ground_variables([],GroundVars,GroundVars).
6322 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6323 ( memberchk_eq(Var,GroundVars) ->
6324 GroundVars1 = GroundVars
6325 ;
6326 GroundVars1 = [Var|GroundVars]
6327 ),
6328 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6329 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6330 %% is_ground(+GroundVars,+Term) is semidet.
6331 %
6332 % Determine whether =Term= is always ground.
6333 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6334 is_ground(GroundVars,Term) :-
6335 ( ground(Term) ->
6336 true
6337 ; compound(Term) ->
6338 Term =.. [_|Args],
6339 maplist(is_ground(GroundVars),Args)
6340 ;
6341 memberchk_eq(Term,GroundVars)
6342 ).
6344 %% check_ground(+GroundVars,+Term,-Goal) is det.
6345 %
6346 % Return runtime check to see whether =Term= is ground.
6347 check_ground(GroundVars,Term,Goal) :-
6348 term_variables(Term,Variables),
6349 check_ground_variables(Variables,GroundVars,Goal).
6351 check_ground_variables([],_,true).
6352 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6353 ( memberchk_eq(Var,GroundVars) ->
6354 check_ground_variables(Vars,GroundVars,Goal)
6355 ;
6356 Goal = (ground(Var), RGoal),
6357 check_ground_variables(Vars,GroundVars,RGoal)
6358 ).
6360 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6361 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6363 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6364 ( Heads = [_|_] ->
6365 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6366 ;
6367 GoalList = [],
6368 Susps = [],
6369 VarDict = NVarDict,
6370 GroundVars = NGroundVars
6371 ).
6373 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6374 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6375 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6376 functor(H,F,A),
6377 head_info(H,A,Vars,_,_,Pairs),
6378 get_store_type(F/A,StoreType),
6379 ( StoreType == default ->
6380 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6381 delay_phase_end(validate_store_type_assumptions,
6382 ( static_suspension_term(F/A,Suspension),
6383 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6384 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6385 )
6386 ),
6387 % create_get_mutable_ref(active,State,GetMutable),
6388 get_constraint_mode(F/A,Mode),
6389 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6390 NPairs = Pairs,
6391 sbag_member_call(Susp,VarSusps,Sbag),
6392 ExistentialLookup = (
6393 ViaGoal,
6394 Sbag,
6395 Susp = Suspension, % not inlined
6396 GetState
6397 )
6398 ;
6399 delay_phase_end(validate_store_type_assumptions,
6400 ( static_suspension_term(F/A,Suspension),
6401 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6402 )
6403 ),
6404 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6405 get_constraint_mode(F/A,Mode),
6406 filter_mode(NPairs,Pairs,Mode,NMode),
6407 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6408 ),
6409 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6410 append(NPairs,VarDict1,DA_), % order important here
6411 translate(GroundVars1,DA_,GroundVarsA),
6412 translate(GroundVars1,VarDict1,GroundVarsB),
6413 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6414 Goal =
6415 (
6416 ExistentialLookup,
6417 DiffSuspGoals,
6418 MatchingGoal2
6419 ),
6420 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6422 inline_matching_goal(A==B,true,GVA,GVB) :-
6423 memberchk_eq(A,GVA),
6424 memberchk_eq(B,GVB),
6425 A=B, !.
6427 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6428 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6429 inline_matching_goal(A,A2,GVA,GVB),
6430 inline_matching_goal(B,B2,GVA,GVB).
6431 inline_matching_goal(X,X,_,_).
6434 filter_mode([],_,_,[]).
6435 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6436 ( Var == V ->
6437 Modes = [M|MT],
6438 filter_mode(Rest,R,Ms,MT)
6439 ;
6440 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6441 ).
6443 check_unique_keys([],_).
6444 check_unique_keys([V|Vs],Dict) :-
6445 lookup_eq(Dict,V,_),
6446 check_unique_keys(Vs,Dict).
6448 % Generates tests to ensure the found constraint differs from previously found constraints
6449 % TODO: detect more cases where constraints need be different
6450 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6451 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6452 list2conj(DiffSuspGoalList,DiffSuspGoals).
6454 different_from_other_susps_(_,[],_,_,[]) :- !.
6455 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6456 ( functor(Head,F,A), functor(PreHead,F,A),
6457 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6458 \+ \+ PreHeadCopy = HeadCopy ->
6460 List = [Susp \== PreSusp | Tail]
6461 ;
6462 List = Tail
6463 ),
6464 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6466 % passive_head_via(in,in,in,in,out,out,out) :-
6467 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6468 functor(Head,F,A),
6469 get_constraint_index(F/A,Pos),
6470 common_variables(Head,PrevHeads,CommonVars),
6471 global_list_store_name(F/A,Name),
6472 GlobalGoal = nb_getval(Name,AllSusps),
6473 get_constraint_mode(F/A,ArgModes),
6474 ( Vars == [] ->
6475 Goal = GlobalGoal
6476 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6477 translate([CommonVar],VarDict,[Var]),
6478 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6479 Goal = AttrGoal
6480 ;
6481 translate(CommonVars,VarDict,Vars),
6482 add_heads_types(PrevHeads,[],TypeDict),
6483 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6484 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6485 Goal =
6486 ( ViaGoal ->
6487 AttrGoal
6488 ;
6489 GlobalGoal
6490 )
6491 ).
6493 common_variables(T,Ts,Vs) :-
6494 term_variables(T,V1),
6495 term_variables(Ts,V2),
6496 intersect_eq(V1,V2,Vs).
6498 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6499 get_target_module(Mod),
6500 ( Vars = [A] ->
6501 lookup_eq(TypeDict,A,Type),
6502 ( atomic_type(Type) ->
6503 ViaGoal = var(A),
6504 A = V
6505 ;
6506 ViaGoal = 'chr newvia_1'(A,V)
6507 )
6508 ; Vars = [A,B] ->
6509 ViaGoal = 'chr newvia_2'(A,B,V)
6510 ;
6511 ViaGoal = 'chr newvia'(Vars,V)
6512 ),
6513 AttrGoal =
6514 ( get_attr(V,Mod,TSusps),
6515 TSuspsEqSusps % TSusps = Susps
6516 ),
6517 get_max_constraint_index(N),
6518 ( N == 1 ->
6519 TSuspsEqSusps = true, % TSusps = Susps
6520 AllSusps = TSusps
6521 ;
6522 get_constraint_index(FA,Pos),
6523 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6524 ).
6525 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6526 get_target_module(Mod),
6527 AttrGoal =
6528 ( get_attr(Var,Mod,TSusps),
6529 TSuspsEqSusps % TSusps = Susps
6530 ),
6531 get_max_constraint_index(N),
6532 ( N == 1 ->
6533 TSuspsEqSusps = true, % TSusps = Susps
6534 AllSusps = TSusps
6535 ;
6536 get_constraint_index(FA,Pos),
6537 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
6538 ).
6540 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6541 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6542 list2conj(GuardCopyList,GuardCopy).
6544 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6545 Rule = rule(H,_,Guard,Body),
6546 conj2list(Guard,GuardList),
6547 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6548 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6550 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6551 term_variables(RestGuardList,GuardVars),
6552 term_variables(RestGuardListCopyCore,GuardCopyVars),
6553 % variables that are declared to be ground don't need to be locked
6554 ground_vars(H,GroundVars),
6555 list_difference_eq(GuardVars,GroundVars,GuardVars_),
6556 ( chr_pp_flag(guard_locks,on),
6557 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6558 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
6559 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
6560 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
6561 ),
6562 LocksUnlocks) ->
6563 once(pairup(Locks,Unlocks,LocksUnlocks))
6564 ;
6565 Locks = [],
6566 Unlocks = []
6567 ),
6568 list2conj(Locks,LockPhase),
6569 list2conj(Unlocks,UnlockPhase),
6570 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
6571 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
6572 my_term_copy(Body,VarDict2,BodyCopy).
6575 split_off_simple_guard([],_,[],[]).
6576 split_off_simple_guard([G|Gs],VarDict,S,C) :-
6577 ( simple_guard(G,VarDict) ->
6578 S = [G|Ss],
6579 split_off_simple_guard(Gs,VarDict,Ss,C)
6580 ;
6581 S = [],
6582 C = [G|Gs]
6583 ).
6585 % simple guard: cheap and benign (does not bind variables)
6586 simple_guard(G,VarDict) :-
6587 binds_b(G,Vars),
6588 \+ (( member(V,Vars),
6589 lookup_eq(VarDict,V,_)
6590 )).
6592 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
6593 functor(Head,F,A),
6594 C = F/A,
6595 ( is_stored(C) ->
6596 (
6597 (
6598 Id == [0], chr_pp_flag(store_in_guards, off)
6599 ;
6600 ( get_allocation_occurrence(C,AO),
6601 get_max_occurrence(C,MO),
6602 MO < AO )
6603 ),
6604 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
6605 SuspDetachment = true
6606 ;
6607 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
6608 ( chr_pp_flag(late_allocation,on) ->
6609 SuspDetachment =
6610 ( var(Susp) ->
6611 true
6612 ;
6613 UnCondSuspDetachment
6614 )
6615 ;
6616 SuspDetachment = UnCondSuspDetachment
6617 )
6618 )
6619 ;
6620 SuspDetachment = true
6621 ).
6623 partner_constraint_detachments([],[],_,true).
6624 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
6625 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
6626 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
6628 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
6629 functor(Head,F,A),
6630 C = F/A,
6631 ( is_stored(C) ->
6632 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
6633 ( chr_pp_flag(debugable,on) ->
6634 DebugEvent = 'chr debug_event'(remove(Susp))
6635 ;
6636 DebugEvent = true
6637 ),
6638 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
6639 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
6640 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
6641 detach_constraint_atom(C,Vars,Susp,Detach)
6642 ;
6643 Detach = true
6644 )
6645 ;
6646 SuspDetachment = true
6647 ).
6649 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6651 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6652 %% ____ _ _ _ _
6653 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
6654 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
6655 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
6656 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
6657 %% |_| |___/
6659 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
6660 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
6661 Rule = rule(_Heads,Heads2,Guard,Body),
6663 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
6664 get_constraint_mode(F/A,Mode),
6665 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6667 build_head(F,A,Id,HeadVars,ClauseHead),
6669 append(RestHeads,Heads2,Heads),
6670 append(OtherIDs,Heads2IDs,IDs),
6671 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
6673 guard_splitting(Rule,GuardList0),
6674 ( is_stored_in_guard(F/A, RuleNb) ->
6675 GuardList = [Hole1|GuardList0]
6676 ;
6677 GuardList = GuardList0
6678 ),
6679 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6681 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6682 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
6684 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6686 ( is_stored_in_guard(F/A, RuleNb) ->
6687 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6688 GuardCopyList = [Hole1Copy|_],
6689 Hole1Copy = Attachment
6690 ;
6691 true
6692 ),
6694 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
6695 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
6696 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6698 ( chr_pp_flag(debugable,on) ->
6699 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6700 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
6701 sort_by_key(Susps2,Susps2IDs,KeptSusps),
6702 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
6703 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
6704 instrument_goal((!),DebugTry,DebugApply,Cut)
6705 ;
6706 Cut = (!)
6707 ),
6709 Clause = ( ClauseHead :-
6710 FirstMatching,
6711 RescheduledTest,
6712 Cut,
6713 SuspsDetachments,
6714 SuspDetachment,
6715 BodyCopy
6716 ),
6717 add_location(Clause,RuleNb,LocatedClause),
6718 L = [LocatedClause | T].
6720 split_by_ids([],[],_,[],[]).
6721 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
6722 ( memberchk_eq(I,I1s) ->
6723 S1s = [S | R1s],
6724 S2s = R2s
6725 ;
6726 S1s = R1s,
6727 S2s = [S | R2s]
6728 ),
6729 split_by_ids(Is,Ss,I1s,R1s,R2s).
6731 split_by_ids([],[],_,[],[],[],[]).
6732 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
6733 ( memberchk_eq(I,I1s) ->
6734 S1s = [S | R1s],
6735 SI1s = [I|RSI1s],
6736 S2s = R2s,
6737 SI2s = RSI2s
6738 ;
6739 S1s = R1s,
6740 SI1s = RSI1s,
6741 S2s = [S | R2s],
6742 SI2s = [I|RSI2s]
6743 ),
6744 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
6745 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6748 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6749 %% ____ _ _ _ ____
6750 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
6751 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
6752 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
6753 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
6754 %% |_| |___/
6756 %% Genereate prelude + worker predicate
6757 %% prelude calls worker
6758 %% worker iterates over one type of removed constraints
6759 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
6760 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
6761 Rule = rule(Heads1,_,Guard,Body),
6762 append(Heads1,RestHeads2,Heads),
6763 append(IDs1,RestIDs,IDs),
6764 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
6765 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
6766 extend_id(Id,Id1),
6767 ( memberchk_eq(NID,IDs2) ->
6768 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
6769 ;
6770 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
6771 ),
6772 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
6773 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
6775 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
6776 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
6777 Heads = [Head|RHeads],
6778 inc_id(Id,Id1),
6779 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
6780 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
6781 ( memberchk_eq(ID,IDs2) ->
6782 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
6783 ;
6784 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
6785 ).
6787 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6788 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
6789 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
6790 build_head(F,A,Id1,VarsSusp,ClauseHead),
6791 get_constraint_mode(F/A,Mode),
6792 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
6794 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
6796 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
6798 extend_id(Id1,DelegateId),
6799 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
6800 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
6801 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
6803 PreludeClause =
6804 ( ClauseHead :-
6805 FirstMatching,
6806 ModConstraintsGoal,
6807 !,
6808 ConstraintAllocationGoal,
6809 Delegate
6810 ),
6811 add_dummy_location(PreludeClause,LocatedPreludeClause),
6812 L = [LocatedPreludeClause|T].
6814 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
6815 Term =.. [_|Args],
6816 delegate_variables(Term,Terms,VarDict,Args,Vars).
6818 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
6819 term_variables(PrevTerms,PrevVars),
6820 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
6822 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
6823 term_variables(Term,V1),
6824 term_variables(Terms,V2),
6825 intersect_eq(V1,V2,V3),
6826 list_difference_eq(V3,PrevVars,V4),
6827 translate(V4,VarDict,Vars).
6830 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6831 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
6832 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
6833 Rule = rule(_,_,Guard,Body),
6834 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
6836 gen_var(OtherSusp),
6837 gen_var(OtherSusps),
6839 functor(CurrentHead,OtherF,OtherA),
6840 gen_vars(OtherA,OtherVars),
6841 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
6842 get_constraint_mode(OtherF/OtherA,Mode),
6843 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
6845 delay_phase_end(validate_store_type_assumptions,
6846 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
6847 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
6848 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
6849 )
6850 ),
6851 % create_get_mutable_ref(active,State,GetMutable),
6852 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
6853 CurrentSuspTest = (
6854 OtherSusp = OtherSuspension,
6855 GetState,
6856 DiffSuspGoals,
6857 FirstMatching
6858 ),
6860 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6861 build_head(F,A,Id,ClauseVars,ClauseHead),
6863 guard_splitting(Rule,GuardList0),
6864 ( is_stored_in_guard(F/A, RuleNb) ->
6865 GuardList = [Hole1|GuardList0]
6866 ;
6867 GuardList = GuardList0
6868 ),
6869 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
6871 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
6872 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
6873 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
6875 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
6877 RecursiveVars = [OtherSusps|PreVarsAndSusps],
6878 build_head(F,A,Id,RecursiveVars,RecursiveCall),
6879 RecursiveVars2 = [[]|PreVarsAndSusps],
6880 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
6882 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
6883 ( is_stored_in_guard(F/A, RuleNb) ->
6884 GuardCopyList = [GuardAttachment|_] % once( ) ??
6885 ;
6886 true
6887 ),
6889 ( is_observed(F/A,O) ->
6890 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
6891 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
6892 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
6893 ;
6894 Attachment = true,
6895 ConditionalRecursiveCall = RecursiveCall,
6896 ConditionalRecursiveCall2 = RecursiveCall2
6897 ),
6899 ( chr_pp_flag(debugable,on) ->
6900 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6901 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
6902 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
6903 ;
6904 DebugTry = true,
6905 DebugApply = true
6906 ),
6908 ( is_stored_in_guard(F/A, RuleNb) ->
6909 GuardAttachment = Attachment,
6910 BodyAttachment = true
6911 ;
6912 GuardAttachment = true,
6913 BodyAttachment = Attachment % will be true if not observed at all
6914 ),
6916 ( member(unique(ID1,UniqueKeys), Pragmas),
6917 check_unique_keys(UniqueKeys,VarDict) ->
6918 Clause =
6919 ( ClauseHead :-
6920 ( CurrentSuspTest ->
6921 ( RescheduledTest,
6922 DebugTry ->
6923 DebugApply,
6924 Susps1Detachments,
6925 BodyAttachment,
6926 BodyCopy,
6927 ConditionalRecursiveCall2
6928 ;
6929 RecursiveCall2
6930 )
6931 ;
6932 RecursiveCall
6933 )
6934 )
6935 ;
6936 Clause =
6937 ( ClauseHead :-
6938 ( CurrentSuspTest,
6939 RescheduledTest,
6940 DebugTry ->
6941 DebugApply,
6942 Susps1Detachments,
6943 BodyAttachment,
6944 BodyCopy,
6945 ConditionalRecursiveCall
6946 ;
6947 RecursiveCall
6948 )
6949 )
6950 ),
6951 add_location(Clause,RuleNb,LocatedClause),
6952 L = [LocatedClause | T].
6954 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
6955 ( may_trigger(FA) ->
6956 does_use_field(FA,generation),
6957 delay_phase_end(validate_store_type_assumptions,
6958 ( static_suspension_term(FA,Suspension),
6959 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
6960 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
6961 get_static_suspension_term_field(arguments,FA,Suspension,Args)
6962 )
6963 )
6964 ;
6965 delay_phase_end(validate_store_type_assumptions,
6966 ( static_suspension_term(FA,Suspension),
6967 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
6968 get_static_suspension_term_field(arguments,FA,Suspension,Args)
6969 )
6970 ),
6971 GetGeneration = true
6972 ),
6973 ConditionalCall =
6974 ( Susp = Suspension,
6975 GetState,
6976 GetGeneration ->
6977 UpdateState,
6978 Call
6979 ;
6980 true
6981 ).
6983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6986 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6987 %% ____ _ _
6988 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
6989 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
6990 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
6991 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
6992 %% |_| |___/
6994 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
6995 ( RestHeads == [] ->
6996 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
6997 ;
6998 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
6999 ).
7000 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7001 %% Single headed propagation
7002 %% everything in a single clause
7003 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7004 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7005 build_head(F,A,Id,VarsSusp,ClauseHead),
7007 inc_id(Id,NextId),
7008 build_head(F,A,NextId,VarsSusp,NextHead),
7010 get_constraint_mode(F/A,Mode),
7011 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7012 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7014 % - recursive call -
7015 RecursiveCall = NextHead,
7017 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7018 ActualCut = true
7019 ;
7020 ActualCut = !
7021 ),
7023 Rule = rule(_,_,Guard,Body),
7024 ( chr_pp_flag(debugable,on) ->
7025 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7026 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7027 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7028 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7029 ;
7030 Cut = ActualCut
7031 ),
7032 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7033 use_auxiliary_predicate(novel_production),
7034 use_auxiliary_predicate(extend_history),
7035 does_use_history(F/A,O),
7036 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7038 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7039 ( HistoryIDs == [] ->
7040 empty_named_history_novel_production(HistoryName,NovelProduction),
7041 empty_named_history_extend_history(HistoryName,ExtendHistory)
7042 ;
7043 Tuple = HistoryName
7044 )
7045 ;
7046 Tuple = RuleNb
7047 ),
7049 ( var(NovelProduction) ->
7050 NovelProduction = '$novel_production'(Susp,Tuple),
7051 ExtendHistory = '$extend_history'(Susp,Tuple)
7052 ;
7053 true
7054 ),
7056 ( is_observed(F/A,O) ->
7057 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7058 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7059 ;
7060 Attachment = true,
7061 ConditionalRecursiveCall = RecursiveCall
7062 )
7063 ;
7064 Allocation = true,
7065 NovelProduction = true,
7066 ExtendHistory = true,
7068 ( is_observed(F/A,O) ->
7069 get_allocation_occurrence(F/A,AllocO),
7070 ( O == AllocO ->
7071 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7072 Generation = 0
7073 ; % more room for improvement?
7074 Attachment = (Attachment1, Attachment2),
7075 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7076 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7077 ),
7078 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7079 ;
7080 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7081 ConditionalRecursiveCall = RecursiveCall
7082 )
7083 ),
7085 ( is_stored_in_guard(F/A, RuleNb) ->
7086 GuardAttachment = Attachment,
7087 BodyAttachment = true
7088 ;
7089 GuardAttachment = true,
7090 BodyAttachment = Attachment % will be true if not observed at all
7091 ),
7093 Clause = (
7094 ClauseHead :-
7095 HeadMatching,
7096 Allocation,
7097 NovelProduction,
7098 GuardAttachment,
7099 GuardCopy,
7100 Cut,
7101 ExtendHistory,
7102 BodyAttachment,
7103 BodyCopy,
7104 ConditionalRecursiveCall
7105 ),
7106 add_location(Clause,RuleNb,LocatedClause),
7107 ProgramList = [LocatedClause | ProgramTail].
7109 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7110 %% multi headed propagation
7111 %% prelude + predicates to accumulate the necessary combinations of suspended
7112 %% constraints + predicate to execute the body
7113 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7114 RestHeads = [First|Rest],
7115 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7116 extend_id(Id,ExtendedId),
7117 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7119 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7120 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7121 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7122 build_head(F,A,Id,VarsSusp,PreludeHead),
7123 get_constraint_mode(F/A,Mode),
7124 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7125 Rule = rule(_,_,Guard,Body),
7126 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7128 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7130 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7132 extend_id(Id,NestedId),
7133 append([Susps|VarsSusp],ExtraVars,NestedVars),
7134 build_head(F,A,NestedId,NestedVars,NestedHead),
7135 NestedCall = NestedHead,
7137 Prelude = (
7138 PreludeHead :-
7139 FirstMatching,
7140 FirstSuspGoal,
7141 !,
7142 CondAllocation,
7143 NestedCall
7144 ),
7145 add_dummy_location(Prelude,LocatedPrelude),
7146 L = [LocatedPrelude|T].
7148 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7149 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7150 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
7151 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7153 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7154 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
7155 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
7156 inc_id(Id,IncId),
7157 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7159 %check_fd_lookup_condition(_,_,_,_) :- fail.
7160 check_fd_lookup_condition(F,A,_,_) :-
7161 get_store_type(F/A,global_singleton), !.
7162 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7163 \+ may_trigger(F/A),
7164 get_functional_dependency(F/A,1,P,K),
7165 copy_term(P-K,CurrentHead-Key),
7166 term_variables(PreHeads,PreVars),
7167 intersect_eq(Key,PreVars,Key),!.
7169 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7170 Rule = rule(_,H2,Guard,Body),
7171 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7172 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7173 init(AllSusps,RestSusps),
7174 last(AllSusps,Susp),
7175 gen_var(OtherSusp),
7176 gen_var(OtherSusps),
7177 functor(CurrentHead,OtherF,OtherA),
7178 gen_vars(OtherA,OtherVars),
7179 delay_phase_end(validate_store_type_assumptions,
7180 ( static_suspension_term(OtherF/OtherA,Suspension),
7181 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7182 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7183 )
7184 ),
7185 % create_get_mutable_ref(active,State,GetMutable),
7186 CurrentSuspTest = (
7187 OtherSusp = Suspension,
7188 GetState
7189 ),
7190 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7191 build_head(F,A,Id,ClauseVars,ClauseHead),
7192 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7193 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
7194 RecursiveVars = PreVarsAndSusps1
7195 ;
7196 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7197 PrevId = Id
7198 ),
7199 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7200 RecursiveCall = RecursiveHead,
7201 CurrentHead =.. [_|OtherArgs],
7202 pairup(OtherArgs,OtherVars,OtherPairs),
7203 get_constraint_mode(OtherF/OtherA,Mode),
7204 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7206 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7207 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7208 get_occurrence(F/A,O,_,ID),
7210 ( is_observed(F/A,O) ->
7211 init(FirstVarsSusp,FirstVars),
7212 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7213 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7214 ;
7215 Attachment = true,
7216 ConditionalRecursiveCall = RecursiveCall
7217 ),
7218 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7219 NovelProduction = true,
7220 ExtendHistory = true
7221 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7222 NovelProduction = true,
7223 ExtendHistory = true
7224 ;
7225 get_occurrence(F/A,O,_,ID),
7226 use_auxiliary_predicate(novel_production),
7227 use_auxiliary_predicate(extend_history),
7228 does_use_history(F/A,O),
7229 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7230 ( HistoryIDs == [] ->
7231 empty_named_history_novel_production(HistoryName,NovelProduction),
7232 empty_named_history_extend_history(HistoryName,ExtendHistory)
7233 ;
7234 reverse([OtherSusp|RestSusps],NamedSusps),
7235 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7236 HistorySusps = [HistorySusp|_],
7238 ( length(HistoryIDs, 1) ->
7239 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7240 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7241 ;
7242 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7243 Tuple =.. [t,HistoryName|HistorySusps]
7244 )
7245 )
7246 ;
7247 HistorySusp = Susp,
7248 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7249 sort([ID|RestIDs],HistoryIDs),
7250 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7251 Tuple =.. [t,RuleNb|HistorySusps]
7252 ),
7254 ( var(NovelProduction) ->
7255 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7256 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7257 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7258 ;
7259 true
7260 )
7261 ),
7264 ( chr_pp_flag(debugable,on) ->
7265 Rule = rule(_,_,Guard,Body),
7266 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7267 get_occurrence(F/A,O,_,ID),
7268 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7269 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7270 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7271 ;
7272 DebugTry = true,
7273 DebugApply = true
7274 ),
7276 ( is_stored_in_guard(F/A, RuleNb) ->
7277 GuardAttachment = Attachment,
7278 BodyAttachment = true
7279 ;
7280 GuardAttachment = true,
7281 BodyAttachment = Attachment % will be true if not observed at all
7282 ),
7284 Clause = (
7285 ClauseHead :-
7286 ( CurrentSuspTest,
7287 DiffSuspGoals,
7288 Matching,
7289 NovelProduction,
7290 GuardAttachment,
7291 GuardCopy,
7292 DebugTry ->
7293 DebugApply,
7294 ExtendHistory,
7295 BodyAttachment,
7296 BodyCopy,
7297 ConditionalRecursiveCall
7298 ; RecursiveCall
7299 )
7300 ),
7301 add_location(Clause,RuleNb,LocatedClause),
7302 L = [LocatedClause|T].
7304 novel_production_calls([],[],[],_,_,true).
7305 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7306 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7307 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7308 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7310 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7311 reverse(ReversedRestSusps,RestSusps),
7312 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7314 named_history_susps([],_,_,[]).
7315 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7316 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7317 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7321 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7322 !,
7323 functor(Head,F,A),
7324 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7325 get_constraint_mode(F/A,Mode),
7326 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7327 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7328 append(VarsSusp,ExtraVars,HeadVars).
7329 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7330 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7331 functor(Head,F,A),
7332 gen_var(Susps),
7333 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7334 get_constraint_mode(F/A,Mode),
7335 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7336 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7337 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7339 % returns
7340 % VarDict for the copies of variables in the original heads
7341 % VarsSuspsList list of lists of arguments for the successive heads
7342 % FirstVarsSusp top level arguments
7343 % SuspList list of all suspensions
7344 % Iterators list of all iterators
7345 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7346 !,
7347 functor(Head,F,A),
7348 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7349 get_constraint_mode(F/A,Mode),
7350 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7351 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7352 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7353 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7354 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7355 functor(Head,F,A),
7356 gen_var(Susps),
7357 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7358 get_constraint_mode(F/A,Mode),
7359 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7360 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7361 append(HeadVars,[Susp,Susps],Vars).
7363 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7364 !,
7365 functor(Head,F,A),
7366 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7367 get_constraint_mode(F/A,Mode),
7368 head_arg_matches(Pairs,Mode,[],_,VarDict),
7369 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7370 append(VarsSusp,ExtraVars,HeadVars).
7371 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7372 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7373 functor(Head,F,A),
7374 gen_var(Susps),
7375 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7376 get_constraint_mode(F/A,Mode),
7377 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7378 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7379 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7381 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7383 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7384 %% ____ _ _ _ _
7385 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7386 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7387 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7388 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7389 %%
7390 %% ____ _ _ _
7391 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7392 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7393 %% | _ < __/ |_| | | | __/\ V / (_| | |
7394 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7395 %%
7396 %% ____ _ _
7397 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7398 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7399 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7400 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7401 %% |___/
7403 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7404 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7405 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7406 ;
7407 NRestHeads = RestHeads,
7408 NRestIDs = RestIDs
7409 ).
7411 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7412 term_variables(Head,Vars),
7413 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7414 copy_term_nat(InitialData,InitialDataCopy),
7415 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7416 InitialDataCopy = InitialData,
7417 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7418 reverse(RNRestHeads,NRestHeads),
7419 reverse(RNRestIDs,NRestIDs).
7421 final_data(Entry) :-
7422 Entry = entry(_,_,_,_,[],_).
7424 expand_data(Entry,NEntry,Cost) :-
7425 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7426 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7427 term_variables([Head1|Vars],Vars1),
7428 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7429 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7431 % Assigns score to head based on known variables and heads to lookup
7432 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7433 functor(Head,F,A),
7434 get_store_type(F/A,StoreType),
7435 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7437 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7438 term_variables(Head,HeadVars),
7439 term_variables(RestHeads,RestVars),
7440 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7441 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7442 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7443 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7444 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7445 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7446 term_variables(Head,HeadVars),
7447 term_variables(RestHeads,RestVars),
7448 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7449 Score is Score_ * 2.
7450 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7451 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7452 Score = 1. % guaranteed O(1)
7454 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7455 find_with_var_identity(
7456 S,
7457 t(Head,KnownVars,RestHeads),
7458 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7459 Scores
7460 ),
7461 min_list(Scores,Score).
7462 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7463 Score = 10.
7464 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7465 Score = 10.
7467 order_score_indexes([],_,_,Score,NScore) :-
7468 Score > 0, NScore = 100.
7469 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7470 multi_hash_key_args(I,Head,Args),
7471 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7472 Score1 is Score + 1
7473 ;
7474 Score1 = Score
7475 ),
7476 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7478 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7479 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7480 ( K-R-O == 0-0-0 ->
7481 Score = 0
7482 ; K > 0 ->
7483 Score is max(10 - K,0)
7484 ; R > 0 ->
7485 Score is max(10 - R,1) * 10
7486 ;
7487 Score is max(10-O,1) * 100
7488 ).
7489 order_score_count_vars([],_,_,0-0-0).
7490 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7491 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7492 ( memberchk_eq(V,KnownVars) ->
7493 NK is K + 1,
7494 NR = R, NO = O
7495 ; memberchk_eq(V,RestVars) ->
7496 NR is R + 1,
7497 NK = K, NO = O
7498 ;
7499 NO is O + 1,
7500 NK = K, NR = R
7501 ).
7503 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7504 %% ___ _ _ _
7505 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
7506 %% | || '_ \| | | '_ \| | '_ \ / _` |
7507 %% | || | | | | | | | | | | | | (_| |
7508 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7509 %% |___/
7511 %% SWI begin
7512 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7513 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7514 %% SWI end
7516 %% SICStus begin
7517 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7518 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7519 %% SICStus end
7521 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7523 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7524 %% _ _ _ _ _ _ _
7525 %% | | | | |_(_) (_) |_ _ _
7526 %% | | | | __| | | | __| | | |
7527 %% | |_| | |_| | | | |_| |_| |
7528 %% \___/ \__|_|_|_|\__|\__, |
7529 %% |___/
7531 % Create a fresh variable.
7532 gen_var(_).
7534 % Create =N= fresh variables.
7535 gen_vars(N,Xs) :-
7536 length(Xs,N).
7538 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7539 vars_susp(A,Vars,Susp,VarsSusp),
7540 Head =.. [_|Args],
7541 pairup(Args,Vars,HeadPairs).
7543 inc_id([N|Ns],[O|Ns]) :-
7544 O is N + 1.
7545 dec_id([N|Ns],[M|Ns]) :-
7546 M is N - 1.
7548 extend_id(Id,[0|Id]).
7550 next_id([_,N|Ns],[O|Ns]) :-
7551 O is N + 1.
7553 % return clause Head
7554 % for F/A constraint symbol, predicate identifier Id and arguments Head
7555 build_head(F,A,Id,Args,Head) :-
7556 buildName(F,A,Id,Name),
7557 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
7558 ( may_trigger(F/A) ;
7559 get_allocation_occurrence(F/A,AO),
7560 get_max_occurrence(F/A,MO),
7561 MO >= AO ) ) ->
7562 Head =.. [Name|Args]
7563 ;
7564 init(Args,ArgsWOSusp), % XXX not entirely correct!
7565 Head =.. [Name|ArgsWOSusp]
7566 ).
7568 % return predicate name Result
7569 % for Fct/Aty constraint symbol and predicate identifier List
7570 buildName(Fct,Aty,List,Result) :-
7571 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
7572 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
7573 MO >= AO ) ; List \= [0])) ) ) ->
7574 atom_concat(Fct, '___' ,FctSlash),
7575 atomic_concat(FctSlash,Aty,FctSlashAty),
7576 buildName_(List,FctSlashAty,Result)
7577 ;
7578 Result = Fct
7579 ).
7581 buildName_([],Name,Name).
7582 buildName_([N|Ns],Name,Result) :-
7583 buildName_(Ns,Name,Name1),
7584 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
7585 atomic_concat(NameDash,N,Result).
7587 vars_susp(A,Vars,Susp,VarsSusp) :-
7588 length(Vars,A),
7589 append(Vars,[Susp],VarsSusp).
7591 or_pattern(Pos,Pat) :-
7592 Pow is Pos - 1,
7593 Pat is 1 << Pow. % was 2 ** X
7595 and_pattern(Pos,Pat) :-
7596 X is Pos - 1,
7597 Y is 1 << X, % was 2 ** X
7598 Pat is (-1)*(Y + 1).
7600 make_name(Prefix,F/A,Name) :-
7601 atom_concat_list([Prefix,F,'___',A],Name).
7603 %===============================================================================
7604 % Attribute for attributed variables
7606 make_attr(N,Mask,SuspsList,Attr) :-
7607 length(SuspsList,N),
7608 Attr =.. [v,Mask|SuspsList].
7610 get_all_suspensions2(N,Attr,SuspensionsList) :-
7611 chr_pp_flag(dynattr,off), !,
7612 make_attr(N,_,SuspensionsList,Attr).
7614 % NEW
7615 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
7616 % writeln(get_all_suspensions2),
7617 length(SuspensionsList,N),
7618 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
7621 % NEW
7622 normalize_attr(Attr,NormalGoal,NormalAttr) :-
7623 % writeln(normalize_attr),
7624 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
7626 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
7627 chr_pp_flag(dynattr,off), !,
7628 make_attr(N,_,SuspsList,Attr),
7629 nth1(Position,SuspsList,Suspensions).
7631 % NEW
7632 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
7633 % writeln(get_suspensions),
7634 Goal =
7635 ( memberchk(Position-Suspensions,TAttr) ->
7636 true
7637 ;
7638 Suspensions = []
7639 ).
7641 %-------------------------------------------------------------------------------
7642 % +N: number of constraint symbols
7643 % +Suspension: source-level variable, for suspension
7644 % +Position: constraint symbol number
7645 % -Attr: source-level term, for new attribute
7646 singleton_attr(N,Suspension,Position,Attr) :-
7647 chr_pp_flag(dynattr,off), !,
7648 or_pattern(Position,Pattern),
7649 make_attr(N,Pattern,SuspsList,Attr),
7650 nth1(Position,SuspsList,[Suspension]),
7651 chr_delete(SuspsList,[Suspension],RestSuspsList),
7652 set_elems(RestSuspsList,[]).
7654 % NEW
7655 singleton_attr(N,Suspension,Position,Attr) :-
7656 % writeln(singleton_attr),
7657 Attr = [Position-[Suspension]].
7659 %-------------------------------------------------------------------------------
7660 % +N: number of constraint symbols
7661 % +Suspension: source-level variable, for suspension
7662 % +Position: constraint symbol number
7663 % +TAttr: source-level variable, for old attribute
7664 % -Goal: goal for creating new attribute
7665 % -NTAttr: source-level variable, for new attribute
7666 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7667 chr_pp_flag(dynattr,off), !,
7668 make_attr(N,Mask,SuspsList,Attr),
7669 or_pattern(Position,Pattern),
7670 nth1(Position,SuspsList,Susps),
7671 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
7672 make_attr(N,Mask,SuspsList1,NewAttr1),
7673 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
7674 make_attr(N,NewMask,SuspsList2,NewAttr2),
7675 Goal = (
7676 TAttr = Attr,
7677 ( Mask /\ Pattern =:= Pattern ->
7678 NTAttr = NewAttr1
7679 ;
7680 NewMask is Mask \/ Pattern,
7681 NTAttr = NewAttr2
7682 )
7683 ), !.
7685 % NEW
7686 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
7687 % writeln(add_attr),
7688 Goal =
7689 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
7690 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
7691 ;
7692 NTAttr = [Position-[Suspension]|TAttr]
7693 ).
7695 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
7696 chr_pp_flag(dynattr,off), !,
7697 or_pattern(Position,Pattern),
7698 and_pattern(Position,DelPattern),
7699 make_attr(N,Mask,SuspsList,Attr),
7700 nth1(Position,SuspsList,Susps),
7701 substitute_eq(Susps,SuspsList,[],SuspsList1),
7702 make_attr(N,NewMask,SuspsList1,Attr1),
7703 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
7704 make_attr(N,Mask,SuspsList2,Attr2),
7705 get_target_module(Mod),
7706 Goal = (
7707 TAttr = Attr,
7708 ( Mask /\ Pattern =:= Pattern ->
7709 'chr sbag_del_element'(Susps,Suspension,NewSusps),
7710 ( NewSusps == [] ->
7711 NewMask is Mask /\ DelPattern,
7712 ( NewMask == 0 ->
7713 del_attr(Var,Mod)
7714 ;
7715 put_attr(Var,Mod,Attr1)
7716 )
7717 ;
7718 put_attr(Var,Mod,Attr2)
7719 )
7720 ;
7721 true
7722 )
7723 ), !.
7725 % NEW
7726 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
7727 % writeln(rem_attr),
7728 get_target_module(Mod),
7729 Goal =
7730 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
7731 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
7732 ( NSuspensions == [] ->
7733 ( RAttr == [] ->
7734 del_attr(Var,Mod)
7735 ;
7736 put_attr(Var,Mod,RAttr)
7737 )
7738 ;
7739 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
7740 )
7741 ;
7742 true
7743 ).
7745 %-------------------------------------------------------------------------------
7746 % +N: number of constraint symbols
7747 % +TAttr1: source-level variable, for attribute
7748 % +TAttr2: source-level variable, for other attribute
7749 % -Goal: goal for merging the two attributes
7750 % -Attr: source-level term, for merged attribute
7751 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
7752 chr_pp_flag(dynattr,off), !,
7753 make_attr(N,Mask1,SuspsList1,Attr1),
7754 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
7755 Goal = (
7756 TAttr1 = Attr1,
7757 Goal2
7758 ).
7760 % NEW
7761 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
7762 % writeln(merge_attributes),
7763 Goal = (
7764 sort(TAttr1,Sorted1),
7765 sort(TAttr2,Sorted2),
7766 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
7767 ).
7770 %-------------------------------------------------------------------------------
7771 % +N: number of constraint symbols
7772 % +Mask1: ...
7773 % +SuspsList1: static term, for suspensions list
7774 % +TAttr2: source-level variable, for other attribute
7775 % -Goal: goal for merging the two attributes
7776 % -Attr: source-level term, for merged attribute
7777 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
7778 make_attr(N,Mask2,SuspsList2,Attr2),
7779 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
7780 list2conj(Gs,SortGoals),
7781 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
7782 make_attr(N,Mask,SuspsList,Attr),
7783 Goal = (
7784 TAttr2 = Attr2,
7785 SortGoals,
7786 Mask is Mask1 \/ Mask2
7787 ).
7790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7791 % Storetype dependent lookup
7793 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7794 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
7795 %% -Goal,-SuspensionList) is det.
7796 %
7797 % Create a universal lookup goal for given head.
7798 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7799 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
7800 functor(Head,F,A),
7801 get_store_type(F/A,StoreType),
7802 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
7804 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7805 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
7806 %% -Goal,-SuspensionList) is det.
7807 %
7808 % Create a universal lookup goal for given head.
7809 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7810 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7811 functor(Head,F,A),
7812 get_store_type(F/A,StoreType),
7813 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
7815 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7816 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
7817 %% +GroundVars,-Goal,-SuspensionList) is det.
7818 %
7819 % Create a universal lookup goal for given head.
7820 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7821 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
7822 functor(Head,F,A),
7823 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
7824 update_store_type(F/A,default).
7825 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7826 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
7827 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7828 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
7829 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
7830 functor(Head,F,A),
7831 global_ground_store_name(F/A,StoreName),
7832 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
7833 update_store_type(F/A,global_ground).
7834 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
7835 arg(VarIndex,Head,OVar),
7836 arg(KeyIndex,Head,OKey),
7837 translate([OVar,OKey],VarDict,[Var,Key]),
7838 get_target_module(Module),
7839 Goal = (
7840 get_attr(Var,Module,AssocStore),
7841 lookup_assoc_store(AssocStore,Key,AllSusps)
7842 ).
7843 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
7844 functor(Head,F,A),
7845 global_singleton_store_name(F/A,StoreName),
7846 make_get_store_goal(StoreName,Susp,GetStoreGoal),
7847 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
7848 update_store_type(F/A,global_singleton).
7849 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7850 once((
7851 member(ST,StoreTypes),
7852 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
7853 )).
7854 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7855 functor(Head,F,A),
7856 arg(Index,Head,Var),
7857 translate([Var],VarDict,[KeyVar]),
7858 delay_phase_end(validate_store_type_assumptions,
7859 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
7860 ),
7861 update_store_type(F/A,identifier_store(Index)),
7862 get_identifier_index(F/A,Index,_).
7863 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7864 functor(Head,F,A),
7865 arg(Index,Head,Var),
7866 ( var(Var) ->
7867 translate([Var],VarDict,[KeyVar]),
7868 Goal = StructGoal
7869 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
7870 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
7871 Goal = (LookupGoal,StructGoal)
7872 ),
7873 delay_phase_end(validate_store_type_assumptions,
7874 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
7875 ),
7876 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
7877 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
7879 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
7880 get_identifier_size(ISize),
7881 functor(Struct,struct,ISize),
7882 get_identifier_index(C,Index,IIndex),
7883 arg(IIndex,Struct,AllSusps),
7884 Goal = (KeyVar = Struct).
7886 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
7887 type_indexed_identifier_structure(IndexType,Struct),
7888 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
7889 arg(IIndex,Struct,AllSusps),
7890 Goal = (KeyVar = Struct).
7892 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7893 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
7894 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
7895 %
7896 % Create a universal hash lookup goal for given head.
7897 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7898 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
7899 once((
7900 member(Index,Indexes),
7901 multi_hash_key_args(Index,Head,KeyArgs),
7902 (
7903 translate(KeyArgs,VarDict,KeyArgCopies)
7904 ;
7905 ground(KeyArgs), KeyArgCopies = KeyArgs
7906 )
7907 )),
7908 ( KeyArgCopies = [KeyCopy] ->
7909 true
7910 ;
7911 KeyCopy =.. [k|KeyArgCopies]
7912 ),
7913 functor(Head,F,A),
7914 multi_hash_via_lookup_goal(F/A,Index,KeyCopy,AllSusps,LookupGoal),
7916 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
7917 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
7919 Goal = (GroundCheck,LookupGoal),
7921 ( HashType == inthash ->
7922 update_store_type(F/A,multi_inthash([Index]))
7923 ;
7924 update_store_type(F/A,multi_hash([Index]))
7925 ).
7927 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7928 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
7929 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
7930 %% +VarArgDict,-NewVarArgDict) is det.
7931 %
7932 % Create existential lookup goal for given head.
7933 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7934 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
7935 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
7936 sbag_member_call(Susp,AllSusps,Sbag),
7937 functor(Head,F,A),
7938 delay_phase_end(validate_store_type_assumptions,
7939 ( static_suspension_term(F/A,SuspTerm),
7940 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7941 )
7942 ),
7943 Goal = (
7944 UniversalGoal,
7945 Sbag,
7946 Susp = SuspTerm,
7947 GetState
7948 ).
7949 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
7950 functor(Head,F,A),
7951 global_singleton_store_name(F/A,StoreName),
7952 make_get_store_goal(StoreName,Susp,GetStoreGoal),
7953 Goal = (
7954 GetStoreGoal, % nb_getval(StoreName,Susp),
7955 Susp \== [],
7956 Susp = SuspTerm
7957 ),
7958 update_store_type(F/A,global_singleton).
7959 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7960 once((
7961 member(ST,StoreTypes),
7962 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
7963 )).
7964 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7965 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
7966 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7967 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
7968 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7969 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
7970 hash_index_filter(Pairs,Index,NPairs),
7972 functor(Head,F,A),
7973 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
7974 Sbag = (AllSusps = [Susp])
7975 ;
7976 sbag_member_call(Susp,AllSusps,Sbag)
7977 ),
7978 delay_phase_end(validate_store_type_assumptions,
7979 ( static_suspension_term(F/A,SuspTerm),
7980 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7981 )
7982 ),
7983 Goal = (
7984 LookupGoal,
7985 Sbag,
7986 Susp = SuspTerm, % not inlined
7987 GetState
7988 ).
7989 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7990 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
7991 hash_index_filter(Pairs,Index,NPairs),
7993 functor(Head,F,A),
7994 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
7995 Sbag = (AllSusps = [Susp])
7996 ;
7997 sbag_member_call(Susp,AllSusps,Sbag)
7998 ),
7999 delay_phase_end(validate_store_type_assumptions,
8000 ( static_suspension_term(F/A,SuspTerm),
8001 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8002 )
8003 ),
8004 Goal = (
8005 LookupGoal,
8006 Sbag,
8007 Susp = SuspTerm, % not inlined
8008 GetState
8009 ).
8010 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8011 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8012 sbag_member_call(Susp,Susps,Sbag),
8013 functor(Head,F,A),
8014 delay_phase_end(validate_store_type_assumptions,
8015 ( static_suspension_term(F/A,SuspTerm),
8016 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8017 )
8018 ),
8019 Goal = (
8020 UGoal,
8021 Sbag,
8022 Susp = SuspTerm, % not inlined
8023 GetState
8024 ).
8026 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8027 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8028 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8029 %% +VarArgDict,-NewVarArgDict) is det.
8030 %
8031 % Create existential hash lookup goal for given head.
8032 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8033 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8034 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8036 hash_index_filter(Pairs,Index,NPairs),
8038 functor(Head,F,A),
8039 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8040 Sbag = (AllSusps = [Susp])
8041 ;
8042 sbag_member_call(Susp,AllSusps,Sbag)
8043 ),
8044 delay_phase_end(validate_store_type_assumptions,
8045 ( static_suspension_term(F/A,SuspTerm),
8046 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8047 )
8048 ),
8049 Goal = (
8050 LookupGoal,
8051 Sbag,
8052 Susp = SuspTerm, % not inlined
8053 GetState
8054 ).
8056 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8057 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8058 %
8059 % Filter out pairs already covered by given hash index.
8060 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8061 hash_index_filter(Pairs,Index,NPairs) :-
8062 ( integer(Index) ->
8063 NIndex = [Index]
8064 ;
8065 NIndex = Index
8066 ),
8067 hash_index_filter(Pairs,NIndex,1,NPairs).
8069 hash_index_filter([],_,_,[]).
8070 hash_index_filter([P|Ps],Index,N,NPairs) :-
8071 ( Index = [I|Is] ->
8072 NN is N + 1,
8073 ( I > N ->
8074 NPairs = [P|NPs],
8075 hash_index_filter(Ps,[I|Is],NN,NPs)
8076 ; I == N ->
8077 hash_index_filter(Ps,Is,NN,NPairs)
8078 )
8079 ;
8080 NPairs = [P|Ps]
8081 ).
8083 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8084 %------------------------------------------------------------------------------%
8085 %% assume_constraint_stores(+ConstraintSymbols) is det.
8086 %
8087 % Compute all constraint store types that are possible for the given
8088 % =ConstraintSymbols=.
8089 %------------------------------------------------------------------------------%
8090 assume_constraint_stores([]).
8091 assume_constraint_stores([C|Cs]) :-
8092 ( chr_pp_flag(debugable,off),
8093 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8094 is_stored(C),
8095 get_store_type(C,default) ->
8096 get_indexed_arguments(C,AllIndexedArgs),
8097 get_constraint_mode(C,Modes),
8098 findall(Index,(member(Index,AllIndexedArgs),
8099 nth(Index,Modes,+)),IndexedArgs),
8100 length(IndexedArgs,NbIndexedArgs),
8101 % Construct Index Combinations
8102 ( NbIndexedArgs > 10 ->
8103 findall([Index],member(Index,IndexedArgs),Indexes)
8104 ;
8105 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8106 predsort(longer_list,UnsortedIndexes,Indexes)
8107 ),
8108 % Choose Index Type
8109 ( get_functional_dependency(C,1,Pattern,Key),
8110 all_distinct_var_args(Pattern), Key == [] ->
8111 assumed_store_type(C,global_singleton)
8112 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8113 get_constraint_type_det(C,ArgTypes),
8114 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8116 ( IntHashIndexes = [] ->
8117 Stores = Stores1
8118 ;
8119 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8120 ),
8121 ( HashIndexes = [] ->
8122 Stores1 = Stores2
8123 ;
8124 Stores1 = [multi_hash(HashIndexes)|Stores2]
8125 ),
8126 ( IdentifierIndexes = [] ->
8127 Stores2 = Stores3
8128 ;
8129 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8130 append(WrappedIdentifierIndexes,Stores3,Stores2)
8131 ),
8132 append(CompoundIdentifierIndexes,Stores4,Stores3),
8133 ( only_ground_indexed_arguments(C)
8134 -> Stores4 = [global_ground]
8135 ; Stores4 = [default]
8136 ),
8137 assumed_store_type(C,multi_store(Stores))
8138 ; true
8139 )
8140 ;
8141 true
8142 ),
8143 assume_constraint_stores(Cs).
8145 %------------------------------------------------------------------------------%
8146 %% partition_indexes(+Indexes,+Types,
8147 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8148 %------------------------------------------------------------------------------%
8149 partition_indexes([],_,[],[],[],[]).
8150 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8151 ( Index = [I],
8152 nth(I,Types,Type),
8153 unalias_type(Type,UnAliasedType),
8154 UnAliasedType == chr_identifier ->
8155 IdentifierIndexes = [I|RIdentifierIndexes],
8156 IntHashIndexes = RIntHashIndexes,
8157 HashIndexes = RHashIndexes,
8158 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8159 ; Index = [I],
8160 nth(I,Types,Type),
8161 unalias_type(Type,UnAliasedType),
8162 nonvar(UnAliasedType),
8163 UnAliasedType = chr_identifier(IndexType) ->
8164 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8165 IdentifierIndexes = RIdentifierIndexes,
8166 IntHashIndexes = RIntHashIndexes,
8167 HashIndexes = RHashIndexes
8168 ; Index = [I],
8169 nth(I,Types,Type),
8170 unalias_type(Type,UnAliasedType),
8171 UnAliasedType == dense_int ->
8172 IntHashIndexes = [Index|RIntHashIndexes],
8173 HashIndexes = RHashIndexes,
8174 IdentifierIndexes = RIdentifierIndexes,
8175 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8176 ; member(I,Index),
8177 nth(I,Types,Type),
8178 unalias_type(Type,UnAliasedType),
8179 nonvar(UnAliasedType),
8180 UnAliasedType = chr_identifier(_) ->
8181 % don't use chr_identifiers in hash indexes
8182 IntHashIndexes = RIntHashIndexes,
8183 HashIndexes = RHashIndexes,
8184 IdentifierIndexes = RIdentifierIndexes,
8185 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8186 ;
8187 IntHashIndexes = RIntHashIndexes,
8188 HashIndexes = [Index|RHashIndexes],
8189 IdentifierIndexes = RIdentifierIndexes,
8190 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8191 ),
8192 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8194 longer_list(R,L1,L2) :-
8195 length(L1,N1),
8196 length(L2,N2),
8197 compare(Rt,N2,N1),
8198 ( Rt == (=) ->
8199 compare(R,L1,L2)
8200 ;
8201 R = Rt
8202 ).
8204 all_distinct_var_args(Term) :-
8205 Term =.. [_|Args],
8206 copy_term_nat(Args,NArgs),
8207 all_distinct_var_args_(NArgs).
8209 all_distinct_var_args_([]).
8210 all_distinct_var_args_([X|Xs]) :-
8211 var(X),
8212 X = t,
8213 all_distinct_var_args_(Xs).
8215 get_indexed_arguments(C,IndexedArgs) :-
8216 C = F/A,
8217 get_indexed_arguments(1,A,C,IndexedArgs).
8219 get_indexed_arguments(I,N,C,L) :-
8220 ( I > N ->
8221 L = []
8222 ; ( is_indexed_argument(C,I) ->
8223 L = [I|T]
8224 ;
8225 L = T
8226 ),
8227 J is I + 1,
8228 get_indexed_arguments(J,N,C,T)
8229 ).
8231 validate_store_type_assumptions([]).
8232 validate_store_type_assumptions([C|Cs]) :-
8233 validate_store_type_assumption(C),
8234 validate_store_type_assumptions(Cs).
8236 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8237 % new code generation
8238 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
8239 Rule = rule(H1,_,Guard,Body),
8240 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8241 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8242 flatten(VarsAndSuspsList,VarsAndSusps),
8243 Vars = [ [] | VarsAndSusps],
8244 build_head(F,A,Id,Vars,Head),
8245 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8246 Clause = ( Head :- PredecessorCall),
8247 add_dummy_location(Clause,LocatedClause),
8248 L = [LocatedClause | T].
8249 % ( H1 == [],
8250 % functor(CurrentHead,CF,CA),
8251 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8252 % L = T
8253 % ;
8254 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8255 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8256 % flatten(VarsAndSuspsList,VarsAndSusps),
8257 % Vars = [ [] | VarsAndSusps],
8258 % build_head(F,A,Id,Vars,Head),
8259 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8260 % Clause = ( Head :- PredecessorCall),
8261 % L = [Clause | T]
8262 % ).
8264 % skips back intelligently over global_singleton lookups
8265 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8266 ( Id = [0|_] ->
8267 next_id(Id,PrevId),
8268 PrevVarsAndSusps = BaseCallArgs
8269 ;
8270 VarsAndSuspsList = [_|AllButFirstList],
8271 dec_id(Id,PrevId1),
8272 ( PrevHeads = [PrevHead|PrevHeads1],
8273 functor(PrevHead,F,A),
8274 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8275 PrevIterators = [_|PrevIterators1],
8276 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8277 ;
8278 PrevId = PrevId1,
8279 flatten(AllButFirstList,AllButFirst),
8280 PrevIterators = [PrevIterator|_],
8281 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8282 )
8283 ).
8285 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
8286 Rule = rule(_,_,Guard,Body),
8287 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8288 init(AllSusps,PreSusps),
8289 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8290 gen_var(OtherSusps),
8291 functor(CurrentHead,OtherF,OtherA),
8292 gen_vars(OtherA,OtherVars),
8293 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8294 get_constraint_mode(OtherF/OtherA,Mode),
8295 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8297 delay_phase_end(validate_store_type_assumptions,
8298 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8299 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8300 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8301 )
8302 ),
8304 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8305 % create_get_mutable_ref(active,State,GetMutable),
8306 CurrentSuspTest = (
8307 OtherSusp = OtherSuspension,
8308 GetState,
8309 DiffSuspGoals,
8310 FirstMatching
8311 ),
8312 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8313 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8314 inc_id(Id,NestedId),
8315 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8316 build_head(F,A,Id,ClauseVars,ClauseHead),
8317 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8318 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8319 build_head(F,A,NestedId,NestedVars,NestedHead),
8321 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8322 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
8323 RecursiveVars = PreVarsAndSusps1
8324 ;
8325 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8326 PrevId = Id
8327 ),
8328 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8330 Clause = (
8331 ClauseHead :-
8332 ( CurrentSuspTest,
8333 NextSuspGoal
8334 ->
8335 NestedHead
8336 ; RecursiveHead
8337 )
8338 ),
8339 add_dummy_location(Clause,LocatedClause),
8340 L = [LocatedClause|T].
8342 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8344 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8345 % Observation Analysis
8346 %
8347 % CLASSIFICATION
8348 % Enabled
8349 %
8350 % Analysis based on Abstract Interpretation paper.
8351 %
8352 % TODO:
8353 % stronger analysis domain [research]
8355 :- chr_constraint
8356 initial_call_pattern/1,
8357 call_pattern/1,
8358 call_pattern_worker/1,
8359 final_answer_pattern/2,
8360 abstract_constraints/1,
8361 depends_on/2,
8362 depends_on_ap/4,
8363 depends_on_goal/2,
8364 ai_observed_internal/2,
8365 % ai_observed/2,
8366 ai_not_observed_internal/2,
8367 ai_not_observed/2,
8368 ai_is_observed/2,
8369 depends_on_as/3,
8370 ai_observation_gather_results/0.
8372 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8373 :- chr_type program_point == any.
8375 :- chr_option(mode,initial_call_pattern(+)).
8376 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8378 :- chr_option(mode,call_pattern(+)).
8379 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8381 :- chr_option(mode,call_pattern_worker(+)).
8382 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8384 :- chr_option(mode,final_answer_pattern(+,+)).
8385 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8387 :- chr_option(mode,abstract_constraints(+)).
8388 :- chr_option(type_declaration,abstract_constraints(list)).
8390 :- chr_option(mode,depends_on(+,+)).
8391 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8393 :- chr_option(mode,depends_on_as(+,+,+)).
8394 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8395 :- chr_option(mode,depends_on_goal(+,+)).
8396 :- chr_option(mode,ai_is_observed(+,+)).
8397 :- chr_option(mode,ai_not_observed(+,+)).
8398 % :- chr_option(mode,ai_observed(+,+)).
8399 :- chr_option(mode,ai_not_observed_internal(+,+)).
8400 :- chr_option(mode,ai_observed_internal(+,+)).
8403 abstract_constraints_fd @
8404 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8406 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8407 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8408 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8410 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8411 ai_is_observed(_,_) <=> true.
8413 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8414 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8415 ai_observation_gather_results <=> true.
8417 %------------------------------------------------------------------------------%
8418 % Main Analysis Entry
8419 %------------------------------------------------------------------------------%
8420 ai_observation_analysis(ACs) :-
8421 ( chr_pp_flag(ai_observation_analysis,on),
8422 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8423 list_to_ord_set(ACs,ACSet),
8424 abstract_constraints(ACSet),
8425 ai_observation_schedule_initial_calls(ACSet,ACSet),
8426 ai_observation_gather_results
8427 ;
8428 true
8429 ).
8431 ai_observation_schedule_initial_calls([],_).
8432 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8433 ai_observation_schedule_initial_call(AC,ACs),
8434 ai_observation_schedule_initial_calls(RACs,ACs).
8436 ai_observation_schedule_initial_call(AC,ACs) :-
8437 ai_observation_top(AC,CallPattern),
8438 % ai_observation_bot(AC,ACs,CallPattern),
8439 initial_call_pattern(CallPattern).
8441 ai_observation_schedule_new_calls([],AP).
8442 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8443 AP = odom(_,Set),
8444 initial_call_pattern(odom(AC,Set)),
8445 ai_observation_schedule_new_calls(ACs,AP).
8447 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8448 <=>
8449 ai_observation_leq(AP2,AP1)
8450 |
8451 true.
8453 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
8455 initial_call_pattern(CP) ==> call_pattern(CP).
8457 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
8458 ==>
8459 ai_observation_schedule_new_calls(ACs,AP)
8460 pragma
8461 passive(ID3).
8463 call_pattern(CP) \ call_pattern(CP) <=> true.
8465 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
8466 final_answer_pattern(CP1,AP).
8468 %call_pattern(CP) ==> writeln(call_pattern(CP)).
8470 call_pattern(CP) ==> call_pattern_worker(CP).
8472 %------------------------------------------------------------------------------%
8473 % Abstract Goal
8474 %------------------------------------------------------------------------------%
8476 % AbstractGoala
8477 %call_pattern(odom([],Set)) ==>
8478 % final_answer_pattern(odom([],Set),odom([],Set)).
8480 call_pattern_worker(odom([],Set)) <=>
8481 % writeln(' - AbstractGoal'(odom([],Set))),
8482 final_answer_pattern(odom([],Set),odom([],Set)).
8484 % AbstractGoalb
8485 call_pattern_worker(odom([G|Gs],Set)) <=>
8486 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
8487 CP1 = odom(G,Set),
8488 depends_on_goal(odom([G|Gs],Set),CP1),
8489 call_pattern(CP1).
8491 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
8492 <=> true pragma passive(ID).
8493 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
8494 ==>
8495 CP1 = odom([_|Gs],_),
8496 AP2 = odom([],Set),
8497 CCP = odom(Gs,Set),
8498 call_pattern(CCP),
8499 depends_on(CP1,CCP).
8501 %------------------------------------------------------------------------------%
8502 % Abstract Disjunction
8503 %------------------------------------------------------------------------------%
8505 call_pattern_worker(odom((AG1;AG2),Set)) <=>
8506 CP = odom((AG1;AG2),Set),
8507 InitialAnswerApproximation = odom([],Set),
8508 final_answer_pattern(CP,InitialAnswerApproximation),
8509 CP1 = odom(AG1,Set),
8510 CP2 = odom(AG2,Set),
8511 call_pattern(CP1),
8512 call_pattern(CP2),
8513 depends_on_as(CP,CP1,CP2).
8515 %------------------------------------------------------------------------------%
8516 % Abstract Solve
8517 %------------------------------------------------------------------------------%
8518 call_pattern_worker(odom(builtin,Set)) <=>
8519 % writeln(' - AbstractSolve'(odom(builtin,Set))),
8520 ord_empty(EmptySet),
8521 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
8523 %------------------------------------------------------------------------------%
8524 % Abstract Drop
8525 %------------------------------------------------------------------------------%
8526 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8527 <=>
8528 O > MO
8529 |
8530 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
8531 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8532 pragma
8533 passive(ID2).
8535 %------------------------------------------------------------------------------%
8536 % Abstract Activate
8537 %------------------------------------------------------------------------------%
8538 call_pattern_worker(odom(AC,Set))
8539 <=>
8540 AC = _ / _
8541 |
8542 % writeln(' - AbstractActivate'(odom(AC,Set))),
8543 CP = odom(occ(AC,1),Set),
8544 call_pattern(CP),
8545 depends_on(odom(AC,Set),CP).
8547 %------------------------------------------------------------------------------%
8548 % Abstract Passive
8549 %------------------------------------------------------------------------------%
8550 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8551 <=>
8552 is_passive(RuleNb,ID)
8553 |
8554 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8555 % DEFAULT
8556 NO is O + 1,
8557 DCP = odom(occ(C,NO),Set),
8558 call_pattern(DCP),
8559 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
8560 depends_on(odom(occ(C,O),Set),DCP)
8561 pragma
8562 passive(ID2).
8563 %------------------------------------------------------------------------------%
8564 % Abstract Simplify
8565 %------------------------------------------------------------------------------%
8567 % AbstractSimplify
8568 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8569 <=>
8570 \+ is_passive(RuleNb,ID)
8571 |
8572 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
8573 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
8574 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
8575 ai_observation_memo_abstract_goal(RuleNb,AG),
8576 call_pattern(odom(AG,Set2)),
8577 % DEFAULT
8578 NO is O + 1,
8579 DCP = odom(occ(C,NO),Set),
8580 call_pattern(DCP),
8581 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
8582 % DEADLOCK AVOIDANCE
8583 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
8584 pragma
8585 passive(ID2).
8587 depends_on_as(CP,CPS,CPD),
8588 final_answer_pattern(CPS,APS),
8589 final_answer_pattern(CPD,APD) ==>
8590 ai_observation_lub(APS,APD,AP),
8591 final_answer_pattern(CP,AP).
8594 :- chr_constraint
8595 ai_observation_memo_simplification_rest_heads/3,
8596 ai_observation_memoed_simplification_rest_heads/3.
8598 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
8599 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
8601 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8602 <=>
8603 QRH = RH.
8604 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8605 <=>
8606 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
8607 once(select2(ID,_,IDs1,H1,_,RestH1)),
8608 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
8609 ai_observation_abstract_constraints(H2,ACs,AH2),
8610 append(ARestHeads,AH2,AbstractHeads),
8611 sort(AbstractHeads,QRH),
8612 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
8613 pragma
8614 passive(ID1),
8615 passive(ID2),
8616 passive(ID3).
8618 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
8620 %------------------------------------------------------------------------------%
8621 % Abstract Propagate
8622 %------------------------------------------------------------------------------%
8625 % AbstractPropagate
8626 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8627 <=>
8628 \+ is_passive(RuleNb,ID)
8629 |
8630 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
8631 % observe partners
8632 ai_observation_memo_propagation_rest_heads(C,O,AHs),
8633 ai_observation_observe_set(Set,AHs,Set2),
8634 ord_add_element(Set2,C,Set3),
8635 ai_observation_memo_abstract_goal(RuleNb,AG),
8636 call_pattern(odom(AG,Set3)),
8637 ( ord_memberchk(C,Set2) ->
8638 Delete = no
8639 ;
8640 Delete = yes
8641 ),
8642 % DEFAULT
8643 NO is O + 1,
8644 DCP = odom(occ(C,NO),Set),
8645 call_pattern(DCP),
8646 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
8647 pragma
8648 passive(ID2).
8650 :- chr_constraint
8651 ai_observation_memo_propagation_rest_heads/3,
8652 ai_observation_memoed_propagation_rest_heads/3.
8654 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
8655 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
8657 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8658 <=>
8659 QRH = RH.
8660 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8661 <=>
8662 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
8663 once(select2(ID,_,IDs2,H2,_,RestH2)),
8664 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
8665 ai_observation_abstract_constraints(H1,ACs,AH1),
8666 append(ARestHeads,AH1,AbstractHeads),
8667 sort(AbstractHeads,QRH),
8668 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
8669 pragma
8670 passive(ID1),
8671 passive(ID2),
8672 passive(ID3).
8674 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
8676 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
8677 final_answer_pattern(CP,APD).
8678 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
8679 final_answer_pattern(CPD,APD) ==>
8680 true |
8681 CP = odom(occ(C,O),_),
8682 ( ai_observation_is_observed(APP,C) ->
8683 ai_observed_internal(C,O)
8684 ;
8685 ai_not_observed_internal(C,O)
8686 ),
8687 ( Delete == yes ->
8688 APP = odom([],Set0),
8689 ord_del_element(Set0,C,Set),
8690 NAPP = odom([],Set)
8691 ;
8692 NAPP = APP
8693 ),
8694 ai_observation_lub(NAPP,APD,AP),
8695 final_answer_pattern(CP,AP).
8697 %------------------------------------------------------------------------------%
8698 % Catch All
8699 %------------------------------------------------------------------------------%
8701 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
8703 %------------------------------------------------------------------------------%
8704 % Auxiliary Predicates
8705 %------------------------------------------------------------------------------%
8707 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
8708 ord_intersection(S1,S2,S3).
8710 ai_observation_bot(AG,AS,odom(AG,AS)).
8712 ai_observation_top(AG,odom(AG,EmptyS)) :-
8713 ord_empty(EmptyS).
8715 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
8716 ord_subset(S2,S1).
8718 ai_observation_observe_set(S,ACSet,NS) :-
8719 ord_subtract(S,ACSet,NS).
8721 ai_observation_abstract_constraint(C,ACs,AC) :-
8722 functor(C,F,A),
8723 AC = F/A,
8724 memberchk(AC,ACs).
8726 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
8727 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
8729 %------------------------------------------------------------------------------%
8730 % Abstraction of Rule Bodies
8731 %------------------------------------------------------------------------------%
8733 :- chr_constraint
8734 ai_observation_memoed_abstract_goal/2,
8735 ai_observation_memo_abstract_goal/2.
8737 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
8738 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
8740 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
8741 <=>
8742 QAG = AG
8743 pragma
8744 passive(ID1).
8746 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
8747 <=>
8748 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
8749 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
8750 QAG = AG,
8751 ai_observation_memoed_abstract_goal(RuleNb,AG)
8752 pragma
8753 passive(ID1),
8754 passive(ID2).
8756 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
8757 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
8758 term_variables((H1,H2,Guard),HVars),
8759 append(H1,H2,Heads),
8760 % variables that are declared to be ground are safe,
8761 ground_vars(Heads,GroundVars),
8762 % so we remove them from the list of 'dangerous' head variables
8763 list_difference_eq(HVars,GroundVars,HV),
8764 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
8765 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
8766 % HV are 'dangerous' variables, all others are fresh and safe
8768 ground_vars([],[]).
8769 ground_vars([H|Hs],GroundVars) :-
8770 functor(H,F,A),
8771 get_constraint_mode(F/A,Mode),
8772 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
8773 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
8774 ground_vars(Hs,GroundVars2),
8775 append(GroundVars1,GroundVars2,GroundVars).
8777 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
8778 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
8779 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
8780 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
8781 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
8782 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
8783 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
8784 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
8785 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
8786 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
8787 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
8788 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
8789 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
8790 % non-CHR constraint is safe if it only binds fresh variables
8791 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
8792 builtin_binds_b(G,Vars),
8793 intersect_eq(Vars,HV,[]),
8794 !.
8795 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
8796 AG = builtin. % default case if goal is not recognized/safe
8798 ai_observation_is_observed(odom(_,ACSet),AC) :-
8799 \+ ord_memberchk(AC,ACSet).
8801 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8802 unconditional_occurrence(C,O) :-
8803 get_occurrence(C,O,RuleNb,ID),
8804 get_rule(RuleNb,PRule),
8805 PRule = pragma(ORule,_,_,_,_),
8806 copy_term_nat(ORule,Rule),
8807 Rule = rule(H1,H2,Guard,_),
8808 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
8809 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
8810 once((
8811 H1 = [Head], H2 == []
8812 ;
8813 H2 = [Head], H1 == [], \+ may_trigger(C)
8814 )),
8815 functor(Head,F,A),
8816 Head =.. [_|Args],
8817 unconditional_occurrence_args(Args).
8819 unconditional_occurrence_args([]).
8820 unconditional_occurrence_args([X|Xs]) :-
8821 var(X),
8822 X = x,
8823 unconditional_occurrence_args(Xs).
8825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8827 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8828 % Partial wake analysis
8829 %
8830 % In a Var = Var unification do not wake up constraints of both variables,
8831 % but rather only those of one variable.
8832 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8834 :- chr_constraint partial_wake_analysis/0.
8835 :- chr_constraint no_partial_wake/1.
8836 :- chr_option(mode,no_partial_wake(+)).
8837 :- chr_constraint wakes_partially/1.
8838 :- chr_option(mode,wakes_partially(+)).
8840 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
8841 ==>
8842 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
8843 ( is_passive(RuleNb,ID) ->
8844 true
8845 ; Type == simplification ->
8846 select(H,H1,RestH1),
8847 H =.. [_|Args],
8848 term_variables(Guard,Vars),
8849 partial_wake_args(Args,ArgModes,Vars,FA)
8850 ; % Type == propagation ->
8851 select(H,H2,RestH2),
8852 H =.. [_|Args],
8853 term_variables(Guard,Vars),
8854 partial_wake_args(Args,ArgModes,Vars,FA)
8855 ).
8857 partial_wake_args([],_,_,_).
8858 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
8859 ( Mode \== (+) ->
8860 ( nonvar(Arg) ->
8861 no_partial_wake(C)
8862 ; memberchk_eq(Arg,Vars) ->
8863 no_partial_wake(C)
8864 ;
8865 true
8866 )
8867 ;
8868 true
8869 ),
8870 partial_wake_args(Args,Modes,Vars,C).
8872 no_partial_wake(C) \ no_partial_wake(C) <=> true.
8874 no_partial_wake(C) \ wakes_partially(C) <=> fail.
8876 wakes_partially(C) <=> true.
8879 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8880 % Generate rules that implement chr_show_store/1 functionality.
8881 %
8882 % CLASSIFICATION
8883 % Experimental
8884 % Unused
8885 %
8886 % Generates additional rules:
8887 %
8888 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
8889 % ...
8890 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
8891 % $show <=> true.
8893 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
8894 ( chr_pp_flag(show,on) ->
8895 Constraints = ['$show'/0|Constraints0],
8896 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
8897 inc_rule_count(RuleNb),
8898 Rule = pragma(
8899 rule(['$show'],[],true,true),
8900 ids([0],[]),
8901 [],
8902 no,
8903 RuleNb
8904 )
8905 ;
8906 Constraints = Constraints0,
8907 Rules = Rules0
8908 ).
8910 generate_show_rules([],Rules,Rules).
8911 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
8912 functor(C,F,A),
8913 inc_rule_count(RuleNb),
8914 Rule = pragma(
8915 rule([],['$show',C],true,writeln(C)),
8916 ids([],[0,1]),
8917 [passive(1)],
8918 no,
8919 RuleNb
8920 ),
8921 generate_show_rules(Rest,Tail,Rules).
8923 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8924 % Custom supension term layout
8926 static_suspension_term(F/A,Suspension) :-
8927 suspension_term_base(F/A,Base),
8928 Arity is Base + A,
8929 functor(Suspension,suspension,Arity).
8931 has_suspension_field(FA,Field) :-
8932 suspension_term_base_fields(FA,Fields),
8933 memberchk(Field,Fields).
8935 suspension_term_base(FA,Base) :-
8936 suspension_term_base_fields(FA,Fields),
8937 length(Fields,Base).
8939 suspension_term_base_fields(FA,Fields) :-
8940 ( chr_pp_flag(debugable,on) ->
8941 % 1. ID
8942 % 2. State
8943 % 3. Propagation History
8944 % 4. Generation Number
8945 % 5. Continuation Goal
8946 % 6. Functor
8947 Fields = [id,state,history,generation,continuation,functor]
8948 ;
8949 ( uses_history(FA) ->
8950 Fields = [id,state,history|Fields2]
8951 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
8952 Fields = [state|Fields2]
8953 ;
8954 Fields = [id,state|Fields2]
8955 ),
8956 ( only_ground_indexed_arguments(FA) ->
8957 get_store_type(FA,StoreType),
8958 basic_store_types(StoreType,BasicStoreTypes),
8959 ( memberchk(global_ground,BasicStoreTypes) ->
8960 % 1. ID
8961 % 2. State
8962 % 3. Propagation History
8963 % 4. Global List Prev
8964 Fields2 = [global_list_prev|Fields3]
8965 ;
8966 % 1. ID
8967 % 2. State
8968 % 3. Propagation History
8969 Fields2 = Fields3
8970 ),
8971 ( chr_pp_flag(ht_removal,on)
8972 -> ht_prev_fields(BasicStoreTypes,Fields3)
8973 ; Fields3 = []
8974 )
8975 ; may_trigger(FA) ->
8976 % 1. ID
8977 % 2. State
8978 % 3. Propagation History
8979 ( uses_field(FA,generation) ->
8980 % 4. Generation Number
8981 % 5. Global List Prev
8982 Fields2 = [generation,global_list_prev|Fields3]
8983 ;
8984 Fields2 = [global_list_prev|Fields3]
8985 ),
8986 ( chr_pp_flag(mixed_stores,on),
8987 chr_pp_flag(ht_removal,on)
8988 -> get_store_type(FA,StoreType),
8989 basic_store_types(StoreType,BasicStoreTypes),
8990 ht_prev_fields(BasicStoreTypes,Fields3)
8991 ; Fields3 = []
8992 )
8993 ;
8994 % 1. ID
8995 % 2. State
8996 % 3. Propagation History
8997 % 4. Global List Prev
8998 Fields2 = [global_list_prev|Fields3],
8999 ( chr_pp_flag(mixed_stores,on),
9000 chr_pp_flag(ht_removal,on)
9001 -> get_store_type(FA,StoreType),
9002 basic_store_types(StoreType,BasicStoreTypes),
9003 ht_prev_fields(BasicStoreTypes,Fields3)
9004 ; Fields3 = []
9005 )
9006 )
9007 ).
9009 ht_prev_fields(Stores,Prevs) :-
9010 ht_prev_fields_int(Stores,PrevsList),
9011 append(PrevsList,Prevs).
9012 ht_prev_fields_int([],[]).
9013 ht_prev_fields_int([H|T],Fields) :-
9014 ( H = multi_hash(Indexes)
9015 -> maplist(ht_prev_field,Indexes,FH),
9016 Fields = [FH|FT]
9017 ; Fields = FT
9018 ),
9019 ht_prev_fields_int(T,FT).
9021 ht_prev_field(Index,Field) :-
9022 ( integer(Index)
9023 -> atom_concat('multi_hash_prev-',Index,Field)
9024 ; Index = [_|_]
9025 -> concat_atom(['multi_hash_prev-'|Index],Field)
9026 ).
9028 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9029 suspension_term_base_fields(FA,Fields),
9030 nth(Index,Fields,FieldName), !,
9031 arg(Index,StaticSuspension,Field).
9032 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9033 suspension_term_base(FA,Base),
9034 StaticSuspension =.. [_|Args],
9035 drop(Base,Args,Field).
9036 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9037 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9040 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9041 suspension_term_base_fields(FA,Fields),
9042 nth(Index,Fields,FieldName), !,
9043 Goal = arg(Index,DynamicSuspension,Field).
9044 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9045 static_suspension_term(FA,StaticSuspension),
9046 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9047 Goal = (DynamicSuspension = StaticSuspension).
9048 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9049 suspension_term_base(FA,Base),
9050 Index is I + Base,
9051 Goal = arg(Index,DynamicSuspension,Field).
9052 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9053 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9056 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9057 suspension_term_base_fields(FA,Fields),
9058 nth(Index,Fields,FieldName), !,
9059 Goal = setarg(Index,DynamicSuspension,Field).
9060 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9061 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9063 basic_store_types(multi_store(Types),Types) :- !.
9064 basic_store_types(Type,[Type]).
9066 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9067 %
9069 :- chr_constraint
9070 phase_end/1,
9071 delay_phase_end/2.
9073 :- chr_option(mode,phase_end(+)).
9074 :- chr_option(mode,delay_phase_end(+,?)).
9076 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9077 % phase_end(Phase) <=> true.
9080 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9081 :- chr_constraint
9082 does_use_history/2,
9083 uses_history/1,
9084 novel_production_call/4.
9086 :- chr_option(mode,uses_history(+)).
9087 :- chr_option(mode,does_use_history(+,+)).
9088 :- chr_option(mode,novel_production_call(+,+,?,?)).
9090 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9091 does_use_history(FA,_) \ uses_history(FA) <=> true.
9092 uses_history(_FA) <=> fail.
9094 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9095 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9097 :- chr_constraint
9098 does_use_field/2,
9099 uses_field/2.
9101 :- chr_option(mode,uses_field(+,+)).
9102 :- chr_option(mode,does_use_field(+,+)).
9104 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9105 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9106 uses_field(_FA,_Field) <=> fail.
9108 :- chr_constraint
9109 uses_state/2,
9110 if_used_state/5,
9111 used_states_known/0.
9113 :- chr_option(mode,uses_state(+,+)).
9114 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9117 % states ::= not_stored_yet | passive | active | triggered | removed
9118 %
9119 % allocate CREATES not_stored_yet
9120 % remove CHECKS not_stored_yet
9121 % activate CHECKS not_stored_yet
9122 %
9123 % ==> no allocate THEN no not_stored_yet
9125 % recurs CREATES inactive
9126 % lookup CHECKS inactive
9128 % insert CREATES active
9129 % activate CREATES active
9130 % lookup CHECKS active
9131 % recurs CHECKS active
9133 % runsusp CREATES triggered
9134 % lookup CHECKS triggered
9135 %
9136 % ==> no runsusp THEN no triggered
9138 % remove CREATES removed
9139 % runsusp CHECKS removed
9140 % lookup CHECKS removed
9141 % recurs CHECKS removed
9142 %
9143 % ==> no remove THEN no removed
9145 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9147 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9149 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9150 <=> ResultGoal = Used.
9151 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9152 <=> ResultGoal = NotUsed.
9154 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9155 % Check storedness annotations.
9156 %
9157 % Feature for SSS.
9159 :- chr_constraint stored_assertion/1.
9160 :- chr_option(mode,stored_assertion(+)).
9161 :- chr_option(type_declaration,stored_assertion(constraint)).
9163 :- chr_constraint never_stored_default/2.
9164 :- chr_option(mode,never_stored_default(+,?)).
9165 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9167 generate_never_stored_rules(Constraints,Rules) :-
9168 ( chr_pp_flag(declare_stored_constraints,on) ->
9169 never_stored_rules(Constraints,Rules)
9170 ;
9171 Rules = []
9172 ).
9174 :- chr_constraint never_stored_rules/2.
9175 :- chr_option(mode,never_stored_rules(+,?)).
9176 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9178 never_stored_rules([],Rules) <=> Rules = [].
9179 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9180 Constraint = F/A,
9181 functor(Head,F,A),
9182 inc_rule_count(RuleNb),
9183 Rule = pragma(
9184 rule([Head],[],true,Goal),
9185 ids([0],[]),
9186 [],
9187 no,
9188 RuleNb
9189 ),
9190 Rules = [Rule|Tail],
9191 never_stored_rules(Constraints,Tail).
9192 never_stored_rules([_|Constraints],Rules) <=>
9193 never_stored_rules(Constraints,Rules).
9195 check_storedness_assertions(Constraints) :-
9196 ( chr_pp_flag(declare_stored_constraints,on) ->
9197 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9198 ;
9199 true
9200 ).
9203 :- chr_constraint check_storedness_assertion/1.
9204 :- chr_option(mode,check_storedness_assertion(+)).
9205 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9207 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9208 <=> ( is_stored(Constraint) ->
9209 true
9210 ;
9211 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9212 ).
9213 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9214 <=> ( is_stored(Constraint) ->
9215 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9216 ;
9217 true
9218 ).
9219 % never-stored, no default goal
9220 check_storedness_assertion(Constraint)
9221 <=> ( is_stored(Constraint) ->
9222 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9223 ;
9224 true
9225 ).