| blob | 87327bbea3624ba0eceb856120fd6855140c7d64 |
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 %% * analyze history usage to determine whether/when
64 %% cheaper suspension is possible:
65 %% don't use history when all partners are passive and self never triggers
66 %% * store constraint unconditionally for unconditional propagation rule,
67 %% if first, i.e. without checking history and set trigger cont to next occ
68 %% * get rid of suspension passing for never triggered constraints,
69 %% up to allocation occurrence
70 %% * get rid of call indirection for never triggered constraints
71 %% up to first allocation occurrence.
72 %% * get rid of unnecessary indirection if last active occurrence
73 %% before unconditional removal is head2, e.g.
74 %% a \ b <=> true.
75 %% a <=> true.
76 %% * Eliminate last clause of never stored constraint, if its body
77 %% is fail, e.g.
78 %% a ...
79 %% a <=> fail.
80 %% * Specialize lookup operations and indexes for functional dependencies.
81 %%
82 %% MORE TODO
83 %%
84 %% * map A \ B <=> true | true rules
85 %% onto efficient code that empties the constraint stores of B
86 %% in O(1) time for ground constraints where A and B do not share
87 %% any variables
88 %% * ground matching seems to be not optimized for compound terms
89 %% in case of simpagation_head2 and propagation occurrences
90 %% * analysis for storage delaying (see primes for case)
91 %% * internal constraints declaration + analyses?
92 %% * Do not store in global variable store if not necessary
93 %% NOTE: affects show_store/1
94 %% * var_assoc multi-level store: variable - ground
95 %% * Do not maintain/check unnecessary propagation history
96 %% for reasons of anti-monotony
97 %% * Strengthen storage analysis for propagation rules
98 %% reason about bodies of rules only containing constraints
99 %% -> fixpoint with observation analysis
100 %% * instantiation declarations
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
103 %%
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * fd -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
112 %% ...
113 %% if( (
114 %% generator_n(Y),
115 %% test(X,Y)
116 %% ),
117 %% true,
118 %% ('_$cutto'(CP_1), fail)
119 %% ),
120 %% ...
121 %%
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
129 %%
130 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :- module(chr_translate,
132 [ chr_translate/2 % +Decls, -TranslatedDecls
133 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
134 ]).
135 %% SWI begin
136 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
137 :- use_module(library(ordsets)).
138 :- use_module(library(aggregate)).
139 :- use_module(library(apply_macros)).
140 :- use_module(library(occurs)).
141 %% SWI end
143 :- use_module(hprolog).
144 :- use_module(pairlist).
145 :- use_module(a_star).
146 :- use_module(listmap).
147 :- use_module(clean_code).
148 :- use_module(builtins).
149 :- use_module(find).
150 :- use_module(binomialheap).
151 :- use_module(guard_entailment).
152 :- use_module(chr_compiler_options).
153 :- use_module(chr_compiler_utility).
154 :- use_module(chr_compiler_errors).
155 :- include(chr_op).
156 :- op(1150, fx, chr_type).
157 :- op(1130, xfx, --->).
158 :- op(980, fx, (+)).
159 :- op(980, fx, (-)).
160 :- op(980, fx, (?)).
161 :- op(1150, fx, constraints).
162 :- op(1150, fx, chr_constraint).
164 :- chr_option(debug,off).
165 :- chr_option(optimize,full).
166 :- chr_option(check_guard_bindings,off).
168 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
170 :- chr_type list(T) ---> [] ; [T|list(T)].
172 :- chr_type list == list(any).
174 :- chr_type mode ---> (+) ; (-) ; (?).
176 :- chr_type maybe(T) ---> yes(T) ; no.
178 :- chr_type constraint ---> any / any.
180 :- chr_type module_name == any.
182 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
183 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
184 :- chr_type idspair ---> ids(list(id),list(id)).
186 :- chr_type pragma_type ---> passive(id)
187 ; mpassive(list(id))
188 ; already_in_heads
189 ; already_in_heads(id)
190 ; no_history
191 ; history(history_name,list(id)).
192 :- chr_type history_name== any.
194 :- chr_type rule_name == any.
195 :- chr_type rule_nb == natural.
196 :- chr_type id == natural.
197 :- chr_type occurrence == int.
199 :- chr_type goal == any.
201 :- chr_type store_type ---> default
202 ; multi_store(list(store_type))
203 ; multi_hash(list(list(int)))
204 ; multi_inthash(list(list(int)))
205 ; global_singleton
206 ; global_ground
207 % EXPERIMENTAL STORES
208 ; atomic_constants(list(int),list(any),coverage)
209 ; ground_constants(list(int),list(any),coverage)
210 ; var_assoc_store(int,list(int))
211 ; identifier_store(int)
212 ; type_indexed_identifier_store(int,any).
213 :- chr_type coverage ---> complete ; incomplete.
215 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
217 %------------------------------------------------------------------------------%
218 :- chr_constraint chr_source_file/1.
219 :- chr_option(mode,chr_source_file(+)).
220 :- chr_option(type_declaration,chr_source_file(module_name)).
221 %------------------------------------------------------------------------------%
222 chr_source_file(_) \ chr_source_file(_) <=> true.
224 %------------------------------------------------------------------------------%
225 :- chr_constraint get_chr_source_file/1.
226 :- chr_option(mode,get_chr_source_file(-)).
227 :- chr_option(type_declaration,get_chr_source_file(module_name)).
228 %------------------------------------------------------------------------------%
229 chr_source_file(Mod) \ get_chr_source_file(Query)
230 <=> Query = Mod .
231 get_chr_source_file(Query)
232 <=> Query = user.
235 %------------------------------------------------------------------------------%
236 :- chr_constraint target_module/1.
237 :- chr_option(mode,target_module(+)).
238 :- chr_option(type_declaration,target_module(module_name)).
239 %------------------------------------------------------------------------------%
240 target_module(_) \ target_module(_) <=> true.
242 %------------------------------------------------------------------------------%
243 :- chr_constraint get_target_module/1.
244 :- chr_option(mode,get_target_module(-)).
245 :- chr_option(type_declaration,get_target_module(module_name)).
246 %------------------------------------------------------------------------------%
247 target_module(Mod) \ get_target_module(Query)
248 <=> Query = Mod .
249 get_target_module(Query)
250 <=> Query = user.
252 %------------------------------------------------------------------------------%
253 :- chr_constraint line_number/2.
254 :- chr_option(mode,line_number(+,+)).
255 :- chr_option(type_declaration,line_number(rule_nb,int)).
256 %------------------------------------------------------------------------------%
257 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
259 %------------------------------------------------------------------------------%
260 :- chr_constraint get_line_number/2.
261 :- chr_option(mode,get_line_number(+,-)).
262 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
263 %------------------------------------------------------------------------------%
264 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
265 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
267 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
268 :- chr_option(mode,indexed_argument(+,+)).
269 :- chr_option(type_declaration,indexed_argument(constraint,int)).
271 :- chr_constraint is_indexed_argument/2.
272 :- chr_option(mode,is_indexed_argument(+,+)).
273 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
275 :- chr_constraint constraint_mode/2.
276 :- chr_option(mode,constraint_mode(+,+)).
277 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
279 :- chr_constraint get_constraint_mode/2.
280 :- chr_option(mode,get_constraint_mode(+,-)).
281 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
283 :- chr_constraint may_trigger/1.
284 :- chr_option(mode,may_trigger(+)).
285 :- chr_option(type_declaration,may_trigger(constraint)).
287 :- chr_constraint only_ground_indexed_arguments/1.
288 :- chr_option(mode,only_ground_indexed_arguments(+)).
289 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
291 :- chr_constraint none_suspended_on_variables/0.
293 :- chr_constraint are_none_suspended_on_variables/0.
295 :- chr_constraint store_type/2.
296 :- chr_option(mode,store_type(+,+)).
297 :- chr_option(type_declaration,store_type(constraint,store_type)).
299 :- chr_constraint get_store_type/2.
300 :- chr_option(mode,get_store_type(+,?)).
301 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
303 :- chr_constraint update_store_type/2.
304 :- chr_option(mode,update_store_type(+,+)).
305 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
307 :- chr_constraint actual_store_types/2.
308 :- chr_option(mode,actual_store_types(+,+)).
309 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
311 :- chr_constraint assumed_store_type/2.
312 :- chr_option(mode,assumed_store_type(+,+)).
313 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
315 :- chr_constraint validate_store_type_assumption/1.
316 :- chr_option(mode,validate_store_type_assumption(+)).
317 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
319 :- chr_constraint rule_count/1.
320 :- chr_option(mode,rule_count(+)).
321 :- chr_option(type_declaration,rule_count(natural)).
323 :- chr_constraint inc_rule_count/1.
324 :- chr_option(mode,inc_rule_count(-)).
325 :- chr_option(type_declaration,inc_rule_count(natural)).
327 rule_count(_) \ rule_count(_)
328 <=> true.
329 rule_count(C), inc_rule_count(NC)
330 <=> NC is C + 1, rule_count(NC).
331 inc_rule_count(NC)
332 <=> NC = 1, rule_count(NC).
334 :- chr_constraint passive/2.
335 :- chr_option(mode,passive(+,+)).
337 :- chr_constraint is_passive/2.
338 :- chr_option(mode,is_passive(+,+)).
340 :- chr_constraint any_passive_head/1.
341 :- chr_option(mode,any_passive_head(+)).
343 :- chr_constraint new_occurrence/4.
344 :- chr_option(mode,new_occurrence(+,+,+,+)).
346 :- chr_constraint occurrence/5.
347 :- chr_option(mode,occurrence(+,+,+,+,+)).
348 :- chr_type occurrence_type ---> simplification ; propagation.
349 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
351 :- chr_constraint get_occurrence/4.
352 :- chr_option(mode,get_occurrence(+,+,-,-)).
354 :- chr_constraint get_occurrence_from_id/4.
355 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
357 :- chr_constraint max_occurrence/2.
358 :- chr_option(mode,max_occurrence(+,+)).
360 :- chr_constraint get_max_occurrence/2.
361 :- chr_option(mode,get_max_occurrence(+,-)).
363 :- chr_constraint allocation_occurrence/2.
364 :- chr_option(mode,allocation_occurrence(+,+)).
366 :- chr_constraint get_allocation_occurrence/2.
367 :- chr_option(mode,get_allocation_occurrence(+,-)).
369 :- chr_constraint rule/2.
370 :- chr_option(mode,rule(+,+)).
371 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
373 :- chr_constraint get_rule/2.
374 :- chr_option(mode,get_rule(+,-)).
375 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
377 :- chr_constraint least_occurrence/2.
378 :- chr_option(mode,least_occurrence(+,+)).
379 :- chr_option(type_declaration,least_occurrence(any,list)).
381 :- chr_constraint is_least_occurrence/1.
382 :- chr_option(mode,is_least_occurrence(+)).
385 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
386 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
387 is_indexed_argument(_,_) <=> fail.
389 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
391 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
392 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
393 Q = Mode.
394 get_constraint_mode(FA,Q) <=>
395 FA = _ / N,
396 replicate(N,(?),Q).
398 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
400 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
401 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
402 nth1(I,Mode,M),
403 M \== (+) |
404 is_stored(FA).
405 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
407 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
408 <=>
409 nth1(I,Mode,M),
410 M \== (+)
411 |
412 fail.
413 only_ground_indexed_arguments(_) <=>
414 true.
416 none_suspended_on_variables \ none_suspended_on_variables <=> true.
417 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
418 are_none_suspended_on_variables <=> fail.
419 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
420 % STORE TYPES
421 %
422 % The functionality for inspecting and deciding on the different types of constraint
423 % store / indexes for constraints.
425 store_type(FA,StoreType)
426 ==> chr_pp_flag(verbose,on)
427 |
428 format('The indexes for ~w are:\n',[FA]),
429 format_storetype(StoreType).
430 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
432 format_storetype(multi_store(StoreTypes)) :- !,
433 forall(member(StoreType,StoreTypes), format_storetype(StoreType)).
434 format_storetype(atomic_constants(Index,Constants,_)) :-
435 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
436 format_storetype(ground_constants(Index,Constants,_)) :-
437 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
438 format_storetype(StoreType) :-
439 format('\t* ~w\n',[StoreType]).
442 % 1. Inspection
443 % ~~~~~~~~~~~~~
444 %
445 %
447 get_store_type_normal @
448 store_type(FA,Store) \ get_store_type(FA,Query)
449 <=> Query = Store.
451 get_store_type_assumed @
452 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
453 <=> Query = Store.
455 get_store_type_default @
456 get_store_type(_,Query)
457 <=> Query = default.
459 % 2. Store type registration
460 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
462 actual_store_types(C,STs) \ update_store_type(C,ST)
463 <=> member(ST,STs) | true.
464 update_store_type(C,ST), actual_store_types(C,STs)
465 <=>
466 actual_store_types(C,[ST|STs]).
467 update_store_type(C,ST)
468 <=>
469 actual_store_types(C,[ST]).
471 % 3. Final decision on store types
472 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
475 <=>
476 true % chr_pp_flag(experiment,on)
477 |
478 delete(STs,multi_hash([Index]),STs0),
479 Index = [IndexPos],
480 ( get_constraint_type(C,Types),
481 nth1(IndexPos,Types,Type),
482 enumerated_atomic_type(Type,Atoms),
483 sort(Atoms,Keys) ->
484 Completeness = complete
485 ;
486 Completeness = incomplete
487 ),
488 actual_store_types(C,[atomic_constants(Index,Keys,Completeness)|STs0]).
489 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Keys)
490 <=>
491 true % chr_pp_flag(experiment,on)
492 |
493 ( Index = [IndexPos],
494 get_constraint_arg_type(C,IndexPos,chr_constants)
495 ->
496 Completeness = complete
497 ;
498 Completeness = incomplete
499 ),
500 delete(STs,multi_hash([Index]),STs0),
501 actual_store_types(C,[ground_constants(Index,Keys,Completeness)|STs0]).
503 get_constraint_arg_type(C,Pos,Type) :-
504 get_constraint_type(C,Types),
505 nth1(IndexPos,Types,Type0),
506 unalias_type(Type0,Type).
508 validate_store_type_assumption(C) \ actual_store_types(C,STs)
509 <=>
510 % chr_pp_flag(experiment,on),
511 memberchk(multi_hash([[Index]]),STs),
512 get_constraint_type(C,Types),
513 nth1(Index,Types,Type),
514 enumerated_atomic_type(Type,Atoms)
515 |
516 delete(STs,multi_hash([[Index]]),STs0),
517 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
518 validate_store_type_assumption(C) \ actual_store_types(C,STs)
519 <=>
520 memberchk(multi_hash([[Index]]),STs),
521 get_constraint_arg_type(C,Index,chr_constants(Constants))
522 |
523 delete(STs,multi_hash([[Index]]),STs0),
524 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
525 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
526 <=>
527 ( /* chr_pp_flag(experiment,on), */ forall(member(ST,STs), partial_store(ST)) ->
528 Stores = [global_ground|STs]
529 ;
530 Stores = STs
531 ),
532 store_type(C,multi_store(Stores)).
533 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
534 <=>
535 store_type(C,multi_store(STs)).
536 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
537 <=>
538 chr_pp_flag(debugable,on)
539 |
540 store_type(C,default).
541 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
542 <=> store_type(C,global_ground).
543 validate_store_type_assumption(C)
544 <=> true.
546 partial_store(ground_constants(_,_,incomplete)).
547 partial_store(atomic_constants(_,_,incomplete)).
549 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
550 passive(R,ID) \ passive(R,ID) <=> true.
552 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
553 is_passive(_,_) <=> fail.
555 passive(RuleNb,_) \ any_passive_head(RuleNb)
556 <=> true.
557 any_passive_head(_)
558 <=> fail.
559 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
561 max_occurrence(C,N) \ max_occurrence(C,M)
562 <=> N >= M | true.
564 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
565 NO is MO + 1,
566 occurrence(C,NO,RuleNb,ID,Type),
567 max_occurrence(C,NO).
568 new_occurrence(C,RuleNb,ID,_) <=>
569 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
571 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
572 <=> Q = MON.
573 get_max_occurrence(C,Q)
574 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
576 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
577 <=> Rule = QRule, ID = QID.
578 get_occurrence(C,O,_,_)
579 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
581 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
582 <=> QC = C, QON = ON.
583 get_occurrence_from_id(C,O,_,_)
584 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
586 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
587 % Late allocation
589 late_allocation_analysis(Cs) :-
590 ( chr_pp_flag(late_allocation,on) ->
591 maplist(late_allocation, Cs)
592 ;
593 true
594 ).
596 late_allocation(C) :- late_allocation(C,0).
597 late_allocation(C,O) :- allocation_occurrence(C,O), !.
598 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
600 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
602 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
604 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
605 \+ is_passive(RuleNb,Id),
606 Type == propagation,
607 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
608 true
609 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
610 is_observed(C,O)
611 ; is_least_occurrence(RuleNb) -> % propagation rule
612 is_observed(C,O)
613 ;
614 true
615 ).
617 stored_in_guard_before_next_kept_occurrence(C,O) :-
618 chr_pp_flag(store_in_guards, on),
619 NO is O + 1,
620 stored_in_guard_lookahead(C,NO).
622 :- chr_constraint stored_in_guard_lookahead/2.
623 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
625 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
626 NO is O + 1, stored_in_guard_lookahead(C,NO).
627 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
628 Type == simplification,
629 ( is_stored_in_guard(C,RuleNb) ->
630 true
631 ;
632 NO is O + 1, stored_in_guard_lookahead(C,NO)
633 ).
634 stored_in_guard_lookahead(_,_) <=> fail.
637 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
638 \ least_occurrence(RuleNb,[ID|IDs])
639 <=> AO >= O, \+ may_trigger(C) |
640 least_occurrence(RuleNb,IDs).
641 rule(RuleNb,Rule), passive(RuleNb,ID)
642 \ least_occurrence(RuleNb,[ID|IDs])
643 <=> least_occurrence(RuleNb,IDs).
645 rule(RuleNb,Rule)
646 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
647 least_occurrence(RuleNb,IDs).
649 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
650 <=> true.
651 is_least_occurrence(_)
652 <=> fail.
654 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
655 <=> Q = O.
656 get_allocation_occurrence(_,Q)
657 <=> chr_pp_flag(late_allocation,off), Q=0.
658 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
660 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
661 <=> Q = Rule.
662 get_rule(_,_)
663 <=> fail.
665 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
667 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
668 %
669 % Default store constraint index assignment.
671 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
672 :- chr_option(mode,constraint_index(+,+)).
673 :- chr_option(type_declaration,constraint_index(constraint,int)).
675 :- chr_constraint get_constraint_index/2.
676 :- chr_option(mode,get_constraint_index(+,-)).
677 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
679 :- chr_constraint get_indexed_constraint/2.
680 :- chr_option(mode,get_indexed_constraint(+,-)).
681 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
683 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
684 :- chr_option(mode,max_constraint_index(+)).
685 :- chr_option(type_declaration,max_constraint_index(int)).
687 :- chr_constraint get_max_constraint_index/1.
688 :- chr_option(mode,get_max_constraint_index(-)).
689 :- chr_option(type_declaration,get_max_constraint_index(int)).
691 constraint_index(C,Index) \ get_constraint_index(C,Query)
692 <=> Query = Index.
693 get_constraint_index(C,Query)
694 <=> fail.
696 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
697 <=> Q = C.
698 get_indexed_constraint(Index,Q)
699 <=> fail.
701 max_constraint_index(Index) \ get_max_constraint_index(Query)
702 <=> Query = Index.
703 get_max_constraint_index(Query)
704 <=> Query = 0.
706 set_constraint_indices(Constraints) :-
707 set_constraint_indices(Constraints,1).
708 set_constraint_indices([],M) :-
709 N is M - 1,
710 max_constraint_index(N).
711 set_constraint_indices([C|Cs],N) :-
712 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
713 ; get_store_type(C,var_assoc_store(_,_))) ->
714 constraint_index(C,N),
715 M is N + 1,
716 set_constraint_indices(Cs,M)
717 ;
718 set_constraint_indices(Cs,N)
719 ).
721 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
722 % Identifier Indexes
724 :- chr_constraint identifier_size/1.
725 :- chr_option(mode,identifier_size(+)).
726 :- chr_option(type_declaration,identifier_size(natural)).
728 identifier_size(_) \ identifier_size(_)
729 <=>
730 true.
732 :- chr_constraint get_identifier_size/1.
733 :- chr_option(mode,get_identifier_size(-)).
734 :- chr_option(type_declaration,get_identifier_size(natural)).
736 identifier_size(Size) \ get_identifier_size(Q)
737 <=>
738 Q = Size.
740 get_identifier_size(Q)
741 <=>
742 Q = 1.
744 :- chr_constraint identifier_index/3.
745 :- chr_option(mode,identifier_index(+,+,+)).
746 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
748 identifier_index(C,I,_) \ identifier_index(C,I,_)
749 <=>
750 true.
752 :- chr_constraint get_identifier_index/3.
753 :- chr_option(mode,get_identifier_index(+,+,-)).
754 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
756 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
757 <=>
758 Q = II.
759 identifier_size(Size), get_identifier_index(C,I,Q)
760 <=>
761 NSize is Size + 1,
762 identifier_index(C,I,NSize),
763 identifier_size(NSize),
764 Q = NSize.
765 get_identifier_index(C,I,Q)
766 <=>
767 identifier_index(C,I,2),
768 identifier_size(2),
769 Q = 2.
771 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
772 % Type Indexed Identifier Indexes
774 :- chr_constraint type_indexed_identifier_size/2.
775 :- chr_option(mode,type_indexed_identifier_size(+,+)).
776 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
778 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
779 <=>
780 true.
782 :- chr_constraint get_type_indexed_identifier_size/2.
783 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
784 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
786 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
787 <=>
788 Q = Size.
790 get_type_indexed_identifier_size(IndexType,Q)
791 <=>
792 Q = 1.
794 :- chr_constraint type_indexed_identifier_index/4.
795 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
796 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
798 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
799 <=>
800 true.
802 :- chr_constraint get_type_indexed_identifier_index/4.
803 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
804 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
806 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
807 <=>
808 Q = II.
809 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
810 <=>
811 NSize is Size + 1,
812 type_indexed_identifier_index(IndexType,C,I,NSize),
813 type_indexed_identifier_size(IndexType,NSize),
814 Q = NSize.
815 get_type_indexed_identifier_index(IndexType,C,I,Q)
816 <=>
817 type_indexed_identifier_index(IndexType,C,I,2),
818 type_indexed_identifier_size(IndexType,2),
819 Q = 2.
821 type_indexed_identifier_structure(IndexType,Structure) :-
822 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
823 get_type_indexed_identifier_size(IndexType,Arity),
824 functor(Structure,Functor,Arity).
825 type_indexed_identifier_name(IndexType,Prefix,Name) :-
826 ( atom(IndexType) ->
827 IndexTypeName = IndexType
828 ;
829 term_to_atom(IndexType,IndexTypeName)
830 ),
831 atom_concat_list([Prefix,'_',IndexTypeName],Name).
833 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
838 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
839 %%
840 %% Translation
842 chr_translate(Declarations,NewDeclarations) :-
843 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
845 chr_translate_line_info(Declarations,File,NewDeclarations) :-
846 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',[]),
847 init_chr_pp_flags,
848 chr_source_file(File),
849 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
850 chr_compiler_options:sanity_check,
852 dump_code(Declarations),
854 check_declared_constraints(Constraints0),
855 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
856 add_constraints(Constraints),
857 add_rules(Rules1),
858 generate_never_stored_rules(Constraints,NewRules),
859 add_rules(NewRules),
860 append(Rules1,NewRules,Rules),
861 % start analysis
862 check_rules(Rules,Constraints),
863 time('type checking',chr_translate:static_type_check),
864 add_occurrences(Rules),
865 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
866 time('set semantics',chr_translate:set_semantics_rules(Rules)),
867 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
868 time('guard simplification',chr_translate:guard_simplification),
869 time('late storage',chr_translate:storage_analysis(Constraints)),
870 time('observation',chr_translate:observation_analysis(Constraints)),
871 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
872 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
873 partial_wake_analysis,
874 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
875 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
876 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
877 time('continuation analysis',chr_translate:continuation_analysis(Constraints)),
878 % end analysis
879 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
880 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
881 phase_end(validate_store_type_assumptions),
882 used_states_known,
883 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
884 insert_declarations(OtherClauses, Clauses0),
885 chr_module_declaration(CHRModuleDeclaration),
886 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
887 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
888 append([Clauses0,GeneratedClauses], NewDeclarations),
889 dump_code(NewDeclarations).
891 store_management_preds(Constraints,Clauses) :-
892 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
893 generate_attr_unify_hook(AttrUnifyHookClauses),
894 generate_attach_increment(AttachIncrementClauses),
895 generate_extra_clauses(Constraints,ExtraClauses),
896 generate_insert_delete_constraints(Constraints,DeleteClauses),
897 generate_attach_code(Constraints,StoreClauses),
898 generate_counter_code(CounterClauses),
899 generate_dynamic_type_check_clauses(TypeCheckClauses),
900 append([AttachAConstraintClauses
901 ,AttachIncrementClauses
902 ,AttrUnifyHookClauses
903 ,ExtraClauses
904 ,DeleteClauses
905 ,StoreClauses
906 ,CounterClauses
907 ,TypeCheckClauses
908 ]
909 ,Clauses).
912 insert_declarations(Clauses0, Clauses) :-
913 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
914 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
916 auxiliary_module(chr_hashtable_store).
917 auxiliary_module(chr_integertable_store).
918 auxiliary_module(chr_assoc_store).
920 generate_counter_code(Clauses) :-
921 ( chr_pp_flag(store_counter,on) ->
922 Clauses = [
923 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
924 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
925 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
926 (:- '$counter_init'('$insert_counter')),
927 (:- '$counter_init'('$delete_counter')),
928 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
929 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
930 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
931 ]
932 ;
933 Clauses = []
934 ).
936 % for systems with multifile declaration
937 chr_module_declaration(CHRModuleDeclaration) :-
938 get_target_module(Mod),
939 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
940 CHRModuleDeclaration = [
941 (:- multifile chr:'$chr_module'/1),
942 chr:'$chr_module'(Mod)
943 ]
944 ;
945 CHRModuleDeclaration = []
946 ).
949 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
950 %%
951 %% Partitioning of clauses into constraint declarations, chr rules and other
952 %% clauses
954 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
955 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
956 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
957 partition_clauses([],[],[],[]).
958 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
959 ( parse_rule(Clause,Rule) ->
960 ConstraintDeclarations = RestConstraintDeclarations,
961 Rules = [Rule|RestRules],
962 OtherClauses = RestOtherClauses
963 ; is_declaration(Clause,ConstraintDeclaration) ->
964 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
965 Rules = RestRules,
966 OtherClauses = RestOtherClauses
967 ; is_module_declaration(Clause,Mod) ->
968 target_module(Mod),
969 ConstraintDeclarations = RestConstraintDeclarations,
970 Rules = RestRules,
971 OtherClauses = [Clause|RestOtherClauses]
972 ; is_type_definition(Clause) ->
973 ConstraintDeclarations = RestConstraintDeclarations,
974 Rules = RestRules,
975 OtherClauses = RestOtherClauses
976 ; Clause = (handler _) ->
977 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
978 ConstraintDeclarations = RestConstraintDeclarations,
979 Rules = RestRules,
980 OtherClauses = RestOtherClauses
981 ; Clause = (rules _) ->
982 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
983 ConstraintDeclarations = RestConstraintDeclarations,
984 Rules = RestRules,
985 OtherClauses = RestOtherClauses
986 ; Clause = option(OptionName,OptionValue) ->
987 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
988 handle_option(OptionName,OptionValue),
989 ConstraintDeclarations = RestConstraintDeclarations,
990 Rules = RestRules,
991 OtherClauses = RestOtherClauses
992 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
993 handle_option(OptionName,OptionValue),
994 ConstraintDeclarations = RestConstraintDeclarations,
995 Rules = RestRules,
996 OtherClauses = RestOtherClauses
997 ; Clause = ('$chr_compiled_with_version'(_)) ->
998 ConstraintDeclarations = RestConstraintDeclarations,
999 Rules = RestRules,
1000 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1001 ; ConstraintDeclarations = RestConstraintDeclarations,
1002 Rules = RestRules,
1003 OtherClauses = [Clause|RestOtherClauses]
1004 ),
1005 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1007 '$chr_compiled_with_version'(2).
1009 is_declaration(D, Constraints) :- %% constraint declaration
1010 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1011 conj2list(Cs,Constraints0)
1012 ;
1013 ( D = (:- Decl) ->
1014 Decl =.. [constraints,Cs]
1015 ;
1016 D =.. [constraints,Cs]
1017 ),
1018 conj2list(Cs,Constraints0),
1019 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1020 ),
1021 extract_type_mode(Constraints0,Constraints).
1023 extract_type_mode([],[]).
1024 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1025 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1026 ( C0 = C # Annotation ->
1027 functor(C,F,A),
1028 extract_annotation(Annotation,F/A)
1029 ;
1030 C0 = C,
1031 functor(C,F,A)
1032 ),
1033 ConstraintSymbol = F/A,
1034 C =.. [_|Args],
1035 extract_types_and_modes(Args,ArgTypes,ArgModes),
1036 assert_constraint_type(ConstraintSymbol,ArgTypes),
1037 constraint_mode(ConstraintSymbol,ArgModes),
1038 extract_type_mode(R,R2).
1040 extract_annotation(stored,Symbol) :-
1041 stored_assertion(Symbol).
1042 extract_annotation(default(Goal),Symbol) :-
1043 never_stored_default(Symbol,Goal).
1045 extract_types_and_modes([],[],[]).
1046 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1047 extract_type_and_mode(X,T,M),
1048 extract_types_and_modes(R,R2,R3).
1050 extract_type_and_mode(+(T),T,(+)) :- !.
1051 extract_type_and_mode(?(T),T,(?)) :- !.
1052 extract_type_and_mode(-(T),T,(-)) :- !.
1053 extract_type_and_mode((+),any,(+)) :- !.
1054 extract_type_and_mode((?),any,(?)) :- !.
1055 extract_type_and_mode((-),any,(-)) :- !.
1056 extract_type_and_mode(Illegal,_,_) :-
1057 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1059 is_type_definition(Declaration) :-
1060 ( Declaration = (:- TDef) ->
1061 true
1062 ;
1063 Declaration = TDef
1064 ),
1065 TDef =.. [chr_type,TypeDef],
1066 ( TypeDef = (Name ---> Def) ->
1067 tdisj2list(Def,DefList),
1068 type_definition(Name,DefList)
1069 ; TypeDef = (Alias == Name) ->
1070 type_alias(Alias,Name)
1071 ;
1072 type_definition(TypeDef,[]),
1073 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1074 ).
1076 %% tdisj2list(+Goal,-ListOfGoals) is det.
1077 %
1078 % no removal of fails, e.g. :- type bool ---> true ; fail.
1079 tdisj2list(Conj,L) :-
1080 tdisj2list(Conj,L,[]).
1082 tdisj2list(Conj,L,T) :-
1083 Conj = (G1;G2), !,
1084 tdisj2list(G1,L,T1),
1085 tdisj2list(G2,T1,T).
1086 tdisj2list(G,[G | T],T).
1089 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1090 %% parse_rule(+term,-pragma_rule) is semidet.
1091 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1092 parse_rule(RI,R) :- %% name @ rule
1093 RI = (Name @ RI2), !,
1094 rule(RI2,yes(Name),R).
1095 parse_rule(RI,R) :-
1096 rule(RI,no,R).
1098 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1099 %% parse_rule(+term,-pragma_rule) is semidet.
1100 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1101 rule(RI,Name,R) :-
1102 RI = (RI2 pragma P), !, %% pragmas
1103 ( var(P) ->
1104 Ps = [_] % intercept variable
1105 ;
1106 conj2list(P,Ps)
1107 ),
1108 inc_rule_count(RuleCount),
1109 R = pragma(R1,IDs,Ps,Name,RuleCount),
1110 is_rule(RI2,R1,IDs,R).
1111 rule(RI,Name,R) :-
1112 inc_rule_count(RuleCount),
1113 R = pragma(R1,IDs,[],Name,RuleCount),
1114 is_rule(RI,R1,IDs,R).
1116 is_rule(RI,R,IDs,RC) :- %% propagation rule
1117 RI = (H ==> B), !,
1118 conj2list(H,Head2i),
1119 get_ids(Head2i,IDs2,Head2,RC),
1120 IDs = ids([],IDs2),
1121 ( B = (G | RB) ->
1122 R = rule([],Head2,G,RB)
1123 ;
1124 R = rule([],Head2,true,B)
1125 ).
1126 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1127 RI = (H <=> B), !,
1128 ( B = (G | RB) ->
1129 Guard = G,
1130 Body = RB
1131 ; Guard = true,
1132 Body = B
1133 ),
1134 ( H = (H1 \ H2) ->
1135 conj2list(H1,Head2i),
1136 conj2list(H2,Head1i),
1137 get_ids(Head2i,IDs2,Head2,0,N,RC),
1138 get_ids(Head1i,IDs1,Head1,N,_,RC),
1139 IDs = ids(IDs1,IDs2)
1140 ; conj2list(H,Head1i),
1141 Head2 = [],
1142 get_ids(Head1i,IDs1,Head1,RC),
1143 IDs = ids(IDs1,[])
1144 ),
1145 R = rule(Head1,Head2,Guard,Body).
1147 get_ids(Cs,IDs,NCs,RC) :-
1148 get_ids(Cs,IDs,NCs,0,_,RC).
1150 get_ids([],[],[],N,N,_).
1151 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1152 ( C = (NC # N1) ->
1153 ( var(N1) ->
1154 N1 = N
1155 ;
1156 check_direct_pragma(N1,N,RC)
1157 )
1158 ;
1159 NC = C
1160 ),
1161 M is N + 1,
1162 get_ids(Cs,IDs,NCs, M,NN,RC).
1164 check_direct_pragma(passive,Id,PragmaRule) :- !,
1165 PragmaRule = pragma(_,_,_,_,RuleNb),
1166 passive(RuleNb,Id).
1167 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1168 ( direct_pragma(FullPragma),
1169 atom_concat(Abbrev,Remainder,FullPragma) ->
1170 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1171 ;
1172 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1173 ).
1175 direct_pragma(passive).
1177 is_module_declaration((:- module(Mod)),Mod).
1178 is_module_declaration((:- module(Mod,_)),Mod).
1180 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1182 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1183 % Add constraints
1184 add_constraints([]).
1185 add_constraints([C|Cs]) :-
1186 max_occurrence(C,0),
1187 C = _/A,
1188 length(Mode,A),
1189 set_elems(Mode,?),
1190 constraint_mode(C,Mode),
1191 add_constraints(Cs).
1193 % Add rules
1194 add_rules([]).
1195 add_rules([Rule|Rules]) :-
1196 Rule = pragma(_,_,_,_,RuleNb),
1197 rule(RuleNb,Rule),
1198 add_rules(Rules).
1200 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1202 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1203 %% Some input verification:
1205 check_declared_constraints(Constraints) :-
1206 check_declared_constraints(Constraints,[]).
1208 check_declared_constraints([],_).
1209 check_declared_constraints([C|Cs],Acc) :-
1210 ( memberchk_eq(C,Acc) ->
1211 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1212 ;
1213 true
1214 ),
1215 check_declared_constraints(Cs,[C|Acc]).
1217 %% - all constraints in heads are declared constraints
1218 %% - all passive pragmas refer to actual head constraints
1220 check_rules([],_).
1221 check_rules([PragmaRule|Rest],Decls) :-
1222 check_rule(PragmaRule,Decls),
1223 check_rules(Rest,Decls).
1225 check_rule(PragmaRule,Decls) :-
1226 check_rule_indexing(PragmaRule),
1227 check_trivial_propagation_rule(PragmaRule),
1228 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1229 Rule = rule(H1,H2,_,_),
1230 append(H1,H2,HeadConstraints),
1231 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1232 check_pragmas(Pragmas,PragmaRule).
1234 % Make all heads passive in trivial propagation rule
1235 % ... ==> ... | true.
1236 check_trivial_propagation_rule(PragmaRule) :-
1237 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1238 ( Rule = rule([],_,_,true) ->
1239 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1240 set_all_passive(RuleNb)
1241 ;
1242 true
1243 ).
1245 check_head_constraints([],_,_).
1246 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1247 functor(Constr,F,A),
1248 ( member(F/A,Decls) ->
1249 check_head_constraints(Rest,Decls,PragmaRule)
1250 ;
1251 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1252 ).
1254 check_pragmas([],_).
1255 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1256 check_pragma(Pragma,PragmaRule),
1257 check_pragmas(Pragmas,PragmaRule).
1259 check_pragma(Pragma,PragmaRule) :-
1260 var(Pragma), !,
1261 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1262 check_pragma(passive(ID), PragmaRule) :-
1263 !,
1264 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1265 ( memberchk_eq(ID,IDs1) ->
1266 true
1267 ; memberchk_eq(ID,IDs2) ->
1268 true
1269 ;
1270 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1271 ),
1272 passive(RuleNb,ID).
1274 check_pragma(mpassive(IDs), PragmaRule) :-
1275 !,
1276 PragmaRule = pragma(_,_,_,_,RuleNb),
1277 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1278 maplist(passive(RuleNb),IDs).
1280 check_pragma(Pragma, PragmaRule) :-
1281 Pragma = already_in_heads,
1282 !,
1283 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1285 check_pragma(Pragma, PragmaRule) :-
1286 Pragma = already_in_head(_),
1287 !,
1288 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1290 check_pragma(Pragma, PragmaRule) :-
1291 Pragma = no_history,
1292 !,
1293 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1294 PragmaRule = pragma(_,_,_,_,N),
1295 no_history(N).
1297 check_pragma(Pragma, PragmaRule) :-
1298 Pragma = history(HistoryName,IDs),
1299 !,
1300 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1301 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1302 ( IDs1 \== [] ->
1303 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1304 ; \+ atom(HistoryName) ->
1305 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1306 ; \+ is_set(IDs) ->
1307 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1308 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1309 history(RuleNb,HistoryName,IDs)
1310 ;
1311 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1312 ).
1313 check_pragma(Pragma,PragmaRule) :-
1314 Pragma = line_number(LineNumber),
1315 !,
1316 PragmaRule = pragma(_,_,_,_,RuleNb),
1317 line_number(RuleNb,LineNumber).
1319 check_history_pragma_ids([], _, _).
1320 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1321 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1322 check_history_pragma_ids(IDs,IDs1,IDs2).
1324 check_pragma(Pragma,PragmaRule) :-
1325 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1327 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1328 %% no_history(+RuleNb) is det.
1329 :- chr_constraint no_history/1.
1330 :- chr_option(mode,no_history(+)).
1331 :- chr_option(type_declaration,no_history(int)).
1333 %% has_no_history(+RuleNb) is semidet.
1334 :- chr_constraint has_no_history/1.
1335 :- chr_option(mode,has_no_history(+)).
1336 :- chr_option(type_declaration,has_no_history(int)).
1338 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1339 has_no_history(_) <=> fail.
1341 :- chr_constraint history/3.
1342 :- chr_option(mode,history(+,+,+)).
1343 :- chr_option(type_declaration,history(any,any,list)).
1345 :- chr_constraint named_history/3.
1347 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1348 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1350 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1351 length(IDs1,L1), length(IDs2,L2),
1352 ( L1 \== L2 ->
1353 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1354 ;
1355 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1356 ).
1358 test_named_history_id_pairs(_, [], _, []).
1359 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1360 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1361 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1363 :- chr_constraint test_named_history_id_pair/4.
1364 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1366 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1367 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1368 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1369 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1371 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1372 named_history(_,_,_) <=> fail.
1374 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1377 format_rule(PragmaRule) :-
1378 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1379 ( MaybeName = yes(Name) ->
1380 write('rule '), write(Name)
1381 ;
1382 write('rule number '), write(RuleNumber)
1383 ),
1384 get_line_number(RuleNumber,LineNumber),
1385 write(' (line '),
1386 write(LineNumber),
1387 write(')').
1389 check_rule_indexing(PragmaRule) :-
1390 PragmaRule = pragma(Rule,_,_,_,_),
1391 Rule = rule(H1,H2,G,_),
1392 term_variables(H1-H2,HeadVars),
1393 remove_anti_monotonic_guards(G,HeadVars,NG),
1394 check_indexing(H1,NG-H2),
1395 check_indexing(H2,NG-H1),
1396 % EXPERIMENT
1397 ( chr_pp_flag(term_indexing,on) ->
1398 term_variables(NG,GuardVariables),
1399 append(H1,H2,Heads),
1400 check_specs_indexing(Heads,GuardVariables,Specs)
1401 ;
1402 true
1403 ).
1405 :- chr_constraint indexing_spec/2.
1406 :- chr_option(mode,indexing_spec(+,+)).
1408 :- chr_constraint get_indexing_spec/2.
1409 :- chr_option(mode,get_indexing_spec(+,-)).
1412 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1413 get_indexing_spec(_,Spec) <=> Spec = [].
1415 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1416 <=>
1417 append(Specs1,Specs2,Specs),
1418 indexing_spec(FA,Specs).
1420 remove_anti_monotonic_guards(G,Vars,NG) :-
1421 conj2list(G,GL),
1422 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1423 list2conj(NGL,NG).
1425 remove_anti_monotonic_guard_list([],_,[]).
1426 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1427 ( G = var(X), memberchk_eq(X,Vars) ->
1428 NGs = RGs
1429 % TODO: this is not correct
1430 % ; G = functor(Term,Functor,Arity), % isotonic
1431 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1432 % NGs = RGs
1433 ;
1434 NGs = [G|RGs]
1435 ),
1436 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1438 check_indexing([],_).
1439 check_indexing([Head|Heads],Other) :-
1440 functor(Head,F,A),
1441 Head =.. [_|Args],
1442 term_variables(Heads-Other,OtherVars),
1443 check_indexing(Args,1,F/A,OtherVars),
1444 check_indexing(Heads,[Head|Other]).
1446 check_indexing([],_,_,_).
1447 check_indexing([Arg|Args],I,FA,OtherVars) :-
1448 ( is_indexed_argument(FA,I) ->
1449 true
1450 ; nonvar(Arg) ->
1451 indexed_argument(FA,I)
1452 ; % var(Arg) ->
1453 term_variables(Args,ArgsVars),
1454 append(ArgsVars,OtherVars,RestVars),
1455 ( memberchk_eq(Arg,RestVars) ->
1456 indexed_argument(FA,I)
1457 ;
1458 true
1459 )
1460 ),
1461 J is I + 1,
1462 term_variables(Arg,NVars),
1463 append(NVars,OtherVars,NOtherVars),
1464 check_indexing(Args,J,FA,NOtherVars).
1466 check_specs_indexing([],_,[]).
1467 check_specs_indexing([Head|Heads],Variables,Specs) :-
1468 Specs = [Spec|RSpecs],
1469 term_variables(Heads,OtherVariables,Variables),
1470 check_spec_indexing(Head,OtherVariables,Spec),
1471 term_variables(Head,NVariables,Variables),
1472 check_specs_indexing(Heads,NVariables,RSpecs).
1474 check_spec_indexing(Head,OtherVariables,Spec) :-
1475 functor(Head,F,A),
1476 Spec = spec(F,A,ArgSpecs),
1477 Head =.. [_|Args],
1478 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1479 indexing_spec(F/A,[ArgSpecs]).
1481 check_args_spec_indexing([],_,_,[]).
1482 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1483 term_variables(Args,Variables,OtherVariables),
1484 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1485 ArgSpecs = [ArgSpec|RArgSpecs]
1486 ;
1487 ArgSpecs = RArgSpecs
1488 ),
1489 J is I + 1,
1490 term_variables(Arg,NOtherVariables,OtherVariables),
1491 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1493 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1494 ( var(Arg) ->
1495 memberchk_eq(Arg,Variables),
1496 ArgSpec = specinfo(I,any,[])
1497 ;
1498 functor(Arg,F,A),
1499 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1500 Arg =.. [_|Args],
1501 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1502 ).
1504 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1506 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1507 % Occurrences
1509 add_occurrences([]).
1510 add_occurrences([Rule|Rules]) :-
1511 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1512 add_occurrences(H1,IDs1,simplification,Nb),
1513 add_occurrences(H2,IDs2,propagation,Nb),
1514 add_occurrences(Rules).
1516 add_occurrences([],[],_,_).
1517 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1518 functor(H,F,A),
1519 FA = F/A,
1520 new_occurrence(FA,RuleNb,ID,Type),
1521 add_occurrences(Hs,IDs,Type,RuleNb).
1523 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1525 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1526 % Observation Analysis
1527 %
1528 % CLASSIFICATION
1529 %
1530 %
1531 %
1532 %
1533 %
1534 %
1536 :- chr_constraint observation_analysis/1.
1537 :- chr_option(mode, observation_analysis(+)).
1539 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1540 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1541 ( chr_pp_flag(store_in_guards, on) ->
1542 observation_analysis(RuleNb, Guard, guard, Cs)
1543 ;
1544 true
1545 ),
1546 observation_analysis(RuleNb, Body, body, Cs)
1548 pragma passive(Id).
1549 observation_analysis(_) <=> true.
1551 observation_analysis(RuleNb, Term, GB, Cs) :-
1552 ( all_spawned(RuleNb,GB) ->
1553 true
1554 ; var(Term) ->
1555 spawns_all(RuleNb,GB)
1556 ; Term = true ->
1557 true
1558 ; Term = fail ->
1559 true
1560 ; Term = '!' ->
1561 true
1562 ; Term = (T1,T2) ->
1563 observation_analysis(RuleNb,T1,GB,Cs),
1564 observation_analysis(RuleNb,T2,GB,Cs)
1565 ; Term = (T1;T2) ->
1566 observation_analysis(RuleNb,T1,GB,Cs),
1567 observation_analysis(RuleNb,T2,GB,Cs)
1568 ; Term = (T1->T2) ->
1569 observation_analysis(RuleNb,T1,GB,Cs),
1570 observation_analysis(RuleNb,T2,GB,Cs)
1571 ; Term = (\+ T) ->
1572 observation_analysis(RuleNb,T,GB,Cs)
1573 ; functor(Term,F,A), member(F/A,Cs) ->
1574 spawns(RuleNb,GB,F/A)
1575 ; Term = (_ = _) ->
1576 spawns_all_triggers(RuleNb,GB)
1577 ; Term = (_ is _) ->
1578 spawns_all_triggers(RuleNb,GB)
1579 ; builtin_binds_b(Term,Vars) ->
1580 ( Vars == [] ->
1581 true
1582 ;
1583 spawns_all_triggers(RuleNb,GB)
1584 )
1585 ;
1586 spawns_all(RuleNb,GB)
1587 ).
1589 :- chr_constraint spawns/3.
1590 :- chr_option(mode, spawns(+,+,+)).
1591 :- chr_type spawns_type ---> guard ; body.
1592 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1594 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1595 :- chr_option(mode, spawns_all(+,+)).
1596 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1597 :- chr_option(mode, spawns_all_triggers(+,+)).
1598 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1600 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1601 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1602 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1603 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1604 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1605 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1607 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1608 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1609 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1610 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1612 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1613 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1615 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1616 \
1617 spawns(RuleNb1,GB,C1)
1618 <=>
1619 \+ is_passive(RuleNb2,O)
1620 |
1621 spawns_all(RuleNb1,GB)
1622 pragma
1623 passive(Id).
1625 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1626 ==>
1627 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1628 \+ is_passive(RuleNb2,O), may_trigger(C1)
1629 |
1630 spawns_all_triggers_implies_spawns_all
1631 pragma
1632 passive(Id).
1634 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1635 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1636 spawns_all_triggers_implies_spawns_all \
1637 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1639 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1640 \
1641 spawns(RuleNb1,GB,C1)
1642 <=>
1643 may_trigger(C1),
1644 \+ is_passive(RuleNb2,O)
1645 |
1646 spawns_all_triggers(RuleNb1,GB)
1647 pragma
1648 passive(Id).
1650 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1651 spawns(RuleNb1,GB,C1)
1652 ==>
1653 \+ may_trigger(C1),
1654 \+ is_passive(RuleNb2,O)
1655 |
1656 spawns_all_triggers(RuleNb1,GB)
1657 pragma
1658 passive(Id).
1660 % a bit dangerous this rule: could start propagating too much too soon?
1661 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1662 spawns(RuleNb1,GB,C1)
1663 ==>
1664 RuleNb1 \== RuleNb2, C1 \== C2,
1665 \+ is_passive(RuleNb2,O)
1666 |
1667 spawns(RuleNb1,GB,C2)
1668 pragma
1669 passive(Id).
1671 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1672 spawns_all_triggers(RuleNb1,GB)
1673 ==>
1674 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1675 |
1676 spawns(RuleNb1,GB,C2)
1677 pragma
1678 passive(Id).
1681 :- chr_constraint all_spawned/2.
1682 :- chr_option(mode, all_spawned(+,+)).
1683 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1684 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1685 all_spawned(RuleNb,GB) <=> fail.
1688 % Overview of the supported queries:
1689 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1690 % only succeeds if the occurrence is observed by the
1691 % guard resp. body (depending on the last argument) of its rule
1692 % is_observed(+functor/artiy, +occurrence_number, -)
1693 % succeeds if the occurrence is observed by either the guard or
1694 % the body of its rule
1695 % NOTE: the last argument is NOT bound by this query
1696 %
1697 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1698 % succeeds if the given constraint is observed by the given
1699 % guard resp. body
1700 % do_is_observed(+functor/artiy,+rule_number)
1701 % succeeds if the given constraint is observed by the given
1702 % rule (either its guard or its body)
1705 is_observed(C,O) :-
1706 is_observed(C,O,_),
1707 ai_is_observed(C,O).
1709 is_stored_in_guard(C,RuleNb) :-
1710 chr_pp_flag(store_in_guards, on),
1711 do_is_observed(C,RuleNb,guard).
1713 :- chr_constraint is_observed/3.
1714 :- chr_option(mode, is_observed(+,+,+)).
1715 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1716 is_observed(_,_,_) <=> fail. % this will not happen in practice
1719 :- chr_constraint do_is_observed/3.
1720 :- chr_option(mode, do_is_observed(+,+,+)).
1721 :- chr_constraint do_is_observed/2.
1722 :- chr_option(mode, do_is_observed(+,+)).
1724 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1726 % (1) spawns_all
1727 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1728 % and some non-passive occurrence of some (possibly other) constraint
1729 % exists in a rule (could be same rule) with at least one occurrence of C
1731 spawns_all(RuleNb,GB),
1732 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1733 \
1734 do_is_observed(C,RuleNb,GB)
1735 <=>
1736 \+ is_passive(RuleNb2,O)
1737 |
1738 true.
1740 spawns_all(RuleNb,_),
1741 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1742 \
1743 do_is_observed(C,RuleNb)
1744 <=>
1745 \+ is_passive(RuleNb2,O)
1746 |
1747 true.
1749 % (2) spawns
1750 % a constraint C is observed if the GB of the rule it occurs in spawns a
1751 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1752 % as an occurrence of C
1754 spawns(RuleNb,GB,C2),
1755 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1756 \
1757 do_is_observed(C,RuleNb,GB)
1758 <=>
1759 \+ is_passive(RuleNb2,O)
1760 |
1761 true.
1763 spawns(RuleNb,_,C2),
1764 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1765 \
1766 do_is_observed(C,RuleNb)
1767 <=>
1768 \+ is_passive(RuleNb2,O)
1769 |
1770 true.
1772 % (3) spawns_all_triggers
1773 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1774 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1775 % exists in a rule (could be same rule) with at least one occurrence of C
1777 spawns_all_triggers(RuleNb,GB),
1778 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1779 \
1780 do_is_observed(C,RuleNb,GB)
1781 <=>
1782 \+ is_passive(RuleNb2,O), may_trigger(C2)
1783 |
1784 true.
1786 spawns_all_triggers(RuleNb,_),
1787 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1788 \
1789 do_is_observed(C,RuleNb)
1790 <=>
1791 \+ is_passive(RuleNb2,O), may_trigger(C2)
1792 |
1793 true.
1795 % (4) conservativeness
1796 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1797 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1802 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1804 %%
1805 %% Generated predicates
1806 %% attach_$CONSTRAINT
1807 %% attach_increment
1808 %% detach_$CONSTRAINT
1809 %% attr_unify_hook
1811 %% attach_$CONSTRAINT
1812 generate_attach_detach_a_constraint_all([],[]).
1813 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1814 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1815 generate_attach_a_constraint(Constraint,Clauses1),
1816 generate_detach_a_constraint(Constraint,Clauses2)
1817 ;
1818 Clauses1 = [],
1819 Clauses2 = []
1820 ),
1821 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1822 append([Clauses1,Clauses2,Clauses3],Clauses).
1824 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1825 generate_attach_a_constraint_nil(Constraint,Clause1),
1826 generate_attach_a_constraint_cons(Constraint,Clause2).
1828 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1829 make_name('attach_',FA,Name),
1830 Atom =.. [Name,Vars,Susp].
1832 generate_attach_a_constraint_nil(FA,Clause) :-
1833 Clause = (Head :- true),
1834 attach_constraint_atom(FA,[],_,Head).
1836 generate_attach_a_constraint_cons(FA,Clause) :-
1837 Clause = (Head :- Body),
1838 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1839 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1840 Body = ( AttachBody, Subscribe, RecursiveCall ),
1841 get_max_constraint_index(N),
1842 ( N == 1 ->
1843 generate_attach_body_1(FA,Var,Susp,AttachBody)
1844 ;
1845 generate_attach_body_n(FA,Var,Susp,AttachBody)
1846 ),
1847 % SWI-Prolog specific code
1848 chr_pp_flag(solver_events,NMod),
1849 ( NMod \== none ->
1850 Args = [[Var|_],Susp],
1851 get_target_module(Mod),
1852 use_auxiliary_predicate(run_suspensions),
1853 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1854 ;
1855 Subscribe = true
1856 ).
1858 generate_attach_body_1(FA,Var,Susp,Body) :-
1859 get_target_module(Mod),
1860 Body =
1861 ( get_attr(Var, Mod, Susps) ->
1862 put_attr(Var, Mod, [Susp|Susps])
1863 ;
1864 put_attr(Var, Mod, [Susp])
1865 ).
1867 generate_attach_body_n(F/A,Var,Susp,Body) :-
1868 get_constraint_index(F/A,Position),
1869 get_max_constraint_index(Total),
1870 get_target_module(Mod),
1871 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1872 singleton_attr(Total,Susp,Position,NewAttr3),
1873 Body =
1874 ( get_attr(Var,Mod,TAttr) ->
1875 AddGoal,
1876 put_attr(Var,Mod,NTAttr)
1877 ;
1878 put_attr(Var,Mod,NewAttr3)
1879 ), !.
1881 %% detach_$CONSTRAINT
1882 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1883 generate_detach_a_constraint_nil(Constraint,Clause1),
1884 generate_detach_a_constraint_cons(Constraint,Clause2).
1886 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1887 make_name('detach_',FA,Name),
1888 Atom =.. [Name,Vars,Susp].
1890 generate_detach_a_constraint_nil(FA,Clause) :-
1891 Clause = ( Head :- true),
1892 detach_constraint_atom(FA,[],_,Head).
1894 generate_detach_a_constraint_cons(FA,Clause) :-
1895 Clause = (Head :- Body),
1896 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1897 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1898 Body = ( DetachBody, RecursiveCall ),
1899 get_max_constraint_index(N),
1900 ( N == 1 ->
1901 generate_detach_body_1(FA,Var,Susp,DetachBody)
1902 ;
1903 generate_detach_body_n(FA,Var,Susp,DetachBody)
1904 ).
1906 generate_detach_body_1(FA,Var,Susp,Body) :-
1907 get_target_module(Mod),
1908 Body =
1909 ( get_attr(Var,Mod,Susps) ->
1910 'chr sbag_del_element'(Susps,Susp,NewSusps),
1911 ( NewSusps == [] ->
1912 del_attr(Var,Mod)
1913 ;
1914 put_attr(Var,Mod,NewSusps)
1915 )
1916 ;
1917 true
1918 ).
1920 generate_detach_body_n(F/A,Var,Susp,Body) :-
1921 get_constraint_index(F/A,Position),
1922 get_max_constraint_index(Total),
1923 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1924 get_target_module(Mod),
1925 Body =
1926 ( get_attr(Var,Mod,TAttr) ->
1927 RemGoal
1928 ;
1929 true
1930 ), !.
1932 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1933 %-------------------------------------------------------------------------------
1934 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1935 :- chr_constraint generate_indexed_variables_body/4.
1936 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1937 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1938 %-------------------------------------------------------------------------------
1939 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1940 get_indexing_spec(F/A,Specs),
1941 ( chr_pp_flag(term_indexing,on) ->
1942 spectermvars(Specs,Args,F,A,Body,Vars)
1943 ;
1944 get_constraint_type_det(F/A,ArgTypes),
1945 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1946 ( MaybeBody == empty ->
1947 Body = true,
1948 Vars = []
1949 ; N == 0 ->
1950 ( Args = [Term] ->
1951 true
1952 ;
1953 Term =.. [term|Args]
1954 ),
1955 Body = term_variables(Term,Vars)
1956 ;
1957 MaybeBody = Body
1958 )
1959 ).
1960 generate_indexed_variables_body(FA,_,_,_) <=>
1961 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1962 %===============================================================================
1964 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1965 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1966 J is I + 1,
1967 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1968 ( Mode == (?),
1969 is_indexed_argument(FA,I) ->
1970 ( atomic_type(Type) ->
1971 Body =
1972 (
1973 ( var(V) ->
1974 Vars = [V|Tail]
1975 ;
1976 Vars = Tail
1977 ),
1978 Continuation
1979 ),
1980 ( RBody == empty ->
1981 Continuation = true, Tail = []
1982 ;
1983 Continuation = RBody
1984 )
1985 ;
1986 ( RBody == empty ->
1987 Body = term_variables(V,Vars)
1988 ;
1989 Body = (term_variables(V,Vars,Tail),RBody)
1990 )
1991 ),
1992 N = M
1993 ; Mode == (-), is_indexed_argument(FA,I) ->
1994 ( RBody == empty ->
1995 Body = (Vars = [V])
1996 ;
1997 Body = (Vars = [V|Tail],RBody)
1998 ),
1999 N is M + 1
2000 ;
2001 Vars = Tail,
2002 Body = RBody,
2003 N is M + 1
2004 ).
2005 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2006 % EXPERIMENTAL
2007 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2008 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2010 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2011 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2012 Goal = (ArgGoal,RGoal),
2013 argspecs(Specs,I,TempArgSpecs,RSpecs),
2014 merge_argspecs(TempArgSpecs,ArgSpecs),
2015 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2016 J is I + 1,
2017 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2019 argspecs([],_,[],[]).
2020 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2021 argspecs(Rest,I,ArgSpecs,RestSpecs).
2022 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2023 ( I == J ->
2024 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2025 ( Specs = [] ->
2026 RRestSpecs = RestSpecs
2027 ;
2028 RestSpecs = [Specs|RRestSpecs]
2029 )
2030 ;
2031 ArgSpecs = RArgSpecs,
2032 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2033 ),
2034 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2036 merge_argspecs(In,Out) :-
2037 sort(In,Sorted),
2038 merge_argspecs_(Sorted,Out).
2040 merge_argspecs_([],[]).
2041 merge_argspecs_([X],R) :- !, R = [X].
2042 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2043 ( (F1 == any ; F2 == any) ->
2044 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2045 ; F1 == F2 ->
2046 append(A1,A2,A),
2047 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2048 ;
2049 R = [specinfo(I,F1,A1)|RR],
2050 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2051 ).
2053 arggoal(List,Arg,Goal,L,T) :-
2054 ( List == [] ->
2055 L = T,
2056 Goal = true
2057 ; List = [specinfo(_,any,_)] ->
2058 Goal = term_variables(Arg,L,T)
2059 ;
2060 Goal =
2061 ( var(Arg) ->
2062 L = [Arg|T]
2063 ;
2064 Cases
2065 ),
2066 arggoal_cases(List,Arg,L,T,Cases)
2067 ).
2069 arggoal_cases([],_,L,T,L=T).
2070 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2071 ( ArgSpecs == [] ->
2072 Cases = RCases
2073 ; ArgSpecs == [[]] ->
2074 Cases = RCases
2075 ; FA = F/A ->
2076 Cases = (Case ; RCases),
2077 functor(Term,F,A),
2078 Term =.. [_|Args],
2079 Case = (Arg = Term -> ArgsGoal),
2080 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2081 ),
2082 arggoal_cases(Rest,Arg,L,T,RCases).
2083 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2085 generate_extra_clauses(Constraints,List) :-
2086 generate_activate_clauses(Constraints,List,Tail0),
2087 generate_remove_clauses(Constraints,Tail0,Tail1),
2088 generate_allocate_clauses(Constraints,Tail1,Tail2),
2089 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2090 generate_novel_production(Tail3,Tail4),
2091 generate_extend_history(Tail4,Tail5),
2092 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2093 generate_empty_named_history_initialisations(Tail6,Tail7),
2094 Tail7 = [].
2096 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2097 % remove_constraint_internal/[1/3]
2099 generate_remove_clauses([],List,List).
2100 generate_remove_clauses([C|Cs],List,Tail) :-
2101 generate_remove_clause(C,List,List1),
2102 generate_remove_clauses(Cs,List1,Tail).
2104 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2105 uses_state(Constraint,removed),
2106 ( chr_pp_flag(inline_insertremove,off) ->
2107 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2108 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2109 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2110 ;
2111 delay_phase_end(validate_store_type_assumptions,
2112 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2113 )
2114 ).
2116 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2117 make_name('$remove_constraint_internal_',Constraint,Name),
2118 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2119 Goal =.. [Name, Susp,Delete]
2120 ;
2121 Goal =.. [Name,Susp,Agenda,Delete]
2122 ).
2124 generate_remove_clause(Constraint,List,Tail) :-
2125 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2126 List = [RemoveClause|Tail],
2127 RemoveClause = (Head :- RemoveBody),
2128 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2129 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2130 ;
2131 List = Tail
2132 ).
2134 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2135 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2136 ( Role == active ->
2137 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2138 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2139 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2140 ; Role == partner ->
2141 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2142 GetStateValue = true,
2143 MaybeDelete = DeleteYes
2144 ),
2145 RemoveBody =
2146 (
2147 GetState,
2148 GetStateValue,
2149 UpdateState,
2150 MaybeDelete
2151 )
2152 ;
2153 static_suspension_term(Constraint,Susp2),
2154 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2155 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2156 ( chr_pp_flag(debugable,on) ->
2157 Constraint = Functor / _,
2158 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2159 ;
2160 true
2161 ),
2162 ( Role == active ->
2163 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2164 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2165 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2166 ; Role == partner ->
2167 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2168 GetStateValue = true,
2169 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2170 ),
2171 RemoveBody =
2172 (
2173 Susp = Susp2,
2174 GetStateValue,
2175 UpdateState,
2176 MaybeDelete
2177 )
2178 ).
2180 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2181 % activate_constraint/4
2183 generate_activate_clauses([],List,List).
2184 generate_activate_clauses([C|Cs],List,Tail) :-
2185 generate_activate_clause(C,List,List1),
2186 generate_activate_clauses(Cs,List1,Tail).
2188 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2189 ( chr_pp_flag(inline_insertremove,off) ->
2190 use_auxiliary_predicate(activate_constraint,Constraint),
2191 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2192 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2193 ;
2194 delay_phase_end(validate_store_type_assumptions,
2195 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2196 )
2197 ).
2199 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2200 make_name('$activate_constraint_',Constraint,Name),
2201 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2202 Goal =.. [Name,Store, Susp]
2203 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2204 Goal =.. [Name,Store, Susp, Generation]
2205 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2206 Goal =.. [Name,Store, Vars, Susp, Generation]
2207 ;
2208 Goal =.. [Name,Store, Vars, Susp]
2209 ).
2211 generate_activate_clause(Constraint,List,Tail) :-
2212 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2213 List = [Clause|Tail],
2214 Clause = (Head :- Body),
2215 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2216 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2217 ;
2218 List = Tail
2219 ).
2221 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2222 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2223 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2224 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2225 ;
2226 GenerationHandling = true
2227 ),
2228 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2229 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2230 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2231 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2232 ;
2233 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2234 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2235 ( chr_pp_flag(guard_locks,off) ->
2236 NoneLocked = true
2237 ;
2238 NoneLocked = 'chr none_locked'( Vars)
2239 ),
2240 if_used_state(Constraint,not_stored_yet,
2241 ( State == not_stored_yet ->
2242 ArgumentsGoal,
2243 IndexedVariablesBody,
2244 NoneLocked,
2245 StoreYes
2246 ;
2247 % Vars = [],
2248 StoreNo
2249 ),
2250 % (Vars = [],StoreNo),StoreVarsGoal)
2251 StoreNo,StoreVarsGoal)
2252 ),
2253 Body =
2254 (
2255 GetState,
2256 GetStateValue,
2257 UpdateState,
2258 GenerationHandling,
2259 StoreVarsGoal
2260 ).
2261 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2262 % allocate_constraint/4
2264 generate_allocate_clauses([],List,List).
2265 generate_allocate_clauses([C|Cs],List,Tail) :-
2266 generate_allocate_clause(C,List,List1),
2267 generate_allocate_clauses(Cs,List1,Tail).
2269 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2270 uses_state(Constraint,not_stored_yet),
2271 ( chr_pp_flag(inline_insertremove,off) ->
2272 use_auxiliary_predicate(allocate_constraint,Constraint),
2273 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2274 ;
2275 Goal = (Susp = Suspension, Goal0),
2276 delay_phase_end(validate_store_type_assumptions,
2277 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2278 )
2279 ).
2281 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2282 make_name('$allocate_constraint_',Constraint,Name),
2283 Goal =.. [Name,Susp|Args].
2285 generate_allocate_clause(Constraint,List,Tail) :-
2286 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2287 List = [Clause|Tail],
2288 Clause = (Head :- Body),
2289 Constraint = _/A,
2290 length(Args,A),
2291 allocate_constraint_atom(Constraint,Susp,Args,Head),
2292 allocate_constraint_body(Constraint,Susp,Args,Body)
2293 ;
2294 List = Tail
2295 ).
2297 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2298 static_suspension_term(Constraint,Suspension),
2299 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2300 ( chr_pp_flag(debugable,on) ->
2301 Constraint = Functor / _,
2302 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2303 ;
2304 true
2305 ),
2306 ( chr_pp_flag(debugable,on) ->
2307 ( may_trigger(Constraint) ->
2308 append(Args,[Susp],VarsSusp),
2309 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2310 get_target_module(Mod),
2311 Continuation = Mod : ContinuationGoal
2312 ;
2313 Continuation = true
2314 ),
2315 Init = (Susp = Suspension),
2316 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2317 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2318 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2319 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2320 Susp = Suspension, Init = true, CreateContinuation = true
2321 ;
2322 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2323 ),
2324 ( uses_history(Constraint) ->
2325 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2326 ;
2327 CreateHistory = true
2328 ),
2329 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2330 ( has_suspension_field(Constraint,id) ->
2331 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2332 gen_id(Id,GenID)
2333 ;
2334 GenID = true
2335 ),
2336 Body =
2337 (
2338 Init,
2339 CreateContinuation,
2340 CreateGeneration,
2341 CreateHistory,
2342 CreateState,
2343 GenID
2344 ).
2346 gen_id(Id,'chr gen_id'(Id)).
2347 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2348 % insert_constraint_internal
2350 generate_insert_constraint_internal_clauses([],List,List).
2351 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2352 generate_insert_constraint_internal_clause(C,List,List1),
2353 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2355 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2356 ( chr_pp_flag(inline_insertremove,off) ->
2357 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2358 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2359 ;
2360 delay_phase_end(validate_store_type_assumptions,
2361 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2362 )
2363 ).
2366 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2367 insert_constraint_internal_constraint_name(Constraint,Name),
2368 ( chr_pp_flag(debugable,on) ->
2369 Goal =.. [Name, Vars, Self, Closure | Args]
2370 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2371 Goal =.. [Name,Self | Args]
2372 ;
2373 Goal =.. [Name,Vars, Self | Args]
2374 ).
2376 insert_constraint_internal_constraint_name(Constraint,Name) :-
2377 make_name('$insert_constraint_internal_',Constraint,Name).
2379 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2380 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2381 List = [Clause|Tail],
2382 Clause = (Head :- Body),
2383 Constraint = _/A,
2384 length(Args,A),
2385 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2386 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2387 ;
2388 List = Tail
2389 ).
2392 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2393 static_suspension_term(Constraint,Suspension),
2394 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2395 ( chr_pp_flag(debugable,on) ->
2396 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2397 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2398 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2399 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2400 ;
2401 CreateGeneration = true
2402 ),
2403 ( chr_pp_flag(debugable,on) ->
2404 Constraint = Functor / _,
2405 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2406 ;
2407 true
2408 ),
2409 ( uses_history(Constraint) ->
2410 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2411 ;
2412 CreateHistory = true
2413 ),
2414 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2415 List = [Clause|Tail],
2416 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2417 suspension_term_base_fields(Constraint,BaseFields),
2418 ( has_suspension_field(Constraint,id) ->
2419 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2420 gen_id(Id,GenID)
2421 ;
2422 GenID = true
2423 ),
2424 Body =
2425 (
2426 Susp = Suspension,
2427 CreateState,
2428 CreateGeneration,
2429 CreateHistory,
2430 GenID
2431 )
2432 ;
2433 ( has_suspension_field(Constraint,id) ->
2434 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2435 gen_id(Id,GenID)
2436 ;
2437 GenID = true
2438 ),
2439 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2440 ( chr_pp_flag(guard_locks,off) ->
2441 NoneLocked = true
2442 ;
2443 NoneLocked = 'chr none_locked'( Vars)
2444 ),
2445 Body =
2446 (
2447 Susp = Suspension,
2448 IndexedVariablesBody,
2449 NoneLocked,
2450 CreateState,
2451 CreateGeneration,
2452 CreateHistory,
2453 GenID
2454 )
2455 ).
2457 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2458 % novel_production/2
2460 generate_novel_production(List,Tail) :-
2461 ( is_used_auxiliary_predicate(novel_production) ->
2462 List = [Clause|Tail],
2463 Clause =
2464 (
2465 '$novel_production'( Self, Tuple) :-
2466 % arg( 3, Self, Ref), % ARGXXX
2467 % 'chr get_mutable'( History, Ref),
2468 arg( 3, Self, History), % ARGXXX
2469 ( hprolog:get_ds( Tuple, History, _) ->
2470 fail
2471 ;
2472 true
2473 )
2474 )
2475 ;
2476 List = Tail
2477 ).
2479 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2480 % extend_history/2
2482 generate_extend_history(List,Tail) :-
2483 ( is_used_auxiliary_predicate(extend_history) ->
2484 List = [Clause|Tail],
2485 Clause =
2486 (
2487 '$extend_history'( Self, Tuple) :-
2488 % arg( 3, Self, Ref), % ARGXXX
2489 % 'chr get_mutable'( History, Ref),
2490 arg( 3, Self, History), % ARGXXX
2491 hprolog:put_ds( Tuple, History, x, NewHistory),
2492 setarg( 3, Self, NewHistory) % ARGXXX
2493 )
2494 ;
2495 List = Tail
2496 ).
2498 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2499 %
2500 :- chr_constraint
2501 empty_named_history_initialisations/2,
2502 generate_empty_named_history_initialisation/1,
2503 find_empty_named_histories/0.
2505 generate_empty_named_history_initialisations(List, Tail) :-
2506 empty_named_history_initialisations(List, Tail),
2507 find_empty_named_histories.
2509 find_empty_named_histories, history(_, Name, []) ==>
2510 generate_empty_named_history_initialisation(Name).
2512 generate_empty_named_history_initialisation(Name) \
2513 generate_empty_named_history_initialisation(Name) <=> true.
2514 generate_empty_named_history_initialisation(Name) \
2515 empty_named_history_initialisations(List, Tail) # Passive
2516 <=>
2517 empty_named_history_global_variable(Name, GlobalVariable),
2518 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2519 empty_named_history_initialisations(Rest, Tail)
2520 pragma passive(Passive).
2522 find_empty_named_histories \
2523 generate_empty_named_history_initialisation(_) # Passive <=> true
2524 pragma passive(Passive).
2526 find_empty_named_histories,
2527 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2528 pragma passive(Passive).
2530 find_empty_named_histories <=>
2531 chr_error(internal, 'find_empty_named_histories was not removed', []).
2534 empty_named_history_global_variable(Name, GlobalVariable) :-
2535 atom_concat('chr empty named history ', Name, GlobalVariable).
2537 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2538 empty_named_history_global_variable(Name, GlobalVariable).
2540 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2541 empty_named_history_global_variable(Name, GlobalVariable).
2544 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2545 % run_suspensions/2
2547 generate_run_suspensions_clauses([],List,List).
2548 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2549 generate_run_suspensions_clause(C,List,List1),
2550 generate_run_suspensions_clauses(Cs,List1,Tail).
2552 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2553 make_name('$run_suspensions_',Constraint,Name),
2554 Goal =.. [Name,Suspensions].
2556 generate_run_suspensions_clause(Constraint,List,Tail) :-
2557 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2558 List = [Clause1,Clause2|Tail],
2559 run_suspensions_goal(Constraint,[],Clause1),
2560 ( chr_pp_flag(debugable,on) ->
2561 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2562 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2563 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2564 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2565 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2566 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2567 Clause2 =
2568 (
2569 Clause2Head :-
2570 GetState,
2571 GetStateValue,
2572 ( State==active ->
2573 UpdateState,
2574 GetGeneration,
2575 GetGenerationValue,
2576 Generation is Gen+1,
2577 UpdateGeneration,
2578 GetContinuation,
2579 (
2580 'chr debug_event'(wake(Suspension)),
2581 call(Continuation)
2582 ;
2583 'chr debug_event'(fail(Suspension)), !,
2584 fail
2585 ),
2586 (
2587 'chr debug_event'(exit(Suspension))
2588 ;
2589 'chr debug_event'(redo(Suspension)),
2590 fail
2591 ),
2592 GetPost,
2593 GetPostValue,
2594 ( Post==triggered ->
2595 UpdatePost % catching constraints that did not do anything
2596 ;
2597 true
2598 )
2599 ;
2600 true
2601 ),
2602 Clause2Recursion
2603 )
2604 ;
2605 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2606 static_suspension_term(Constraint,SuspensionTerm),
2607 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2608 append(Arguments,[Suspension],VarsSusp),
2609 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2610 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2611 ( uses_field(Constraint,generation) ->
2612 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2613 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2614 ;
2615 GenerationHandling = true
2616 ),
2617 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2618 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2619 if_used_state(Constraint,removed,
2620 ( GetState,
2621 ( State==active
2622 -> ReactivateConstraint
2623 ; true)
2624 ),ReactivateConstraint,CondReactivate),
2625 ReactivateConstraint =
2626 (
2627 UpdateState,
2628 GenerationHandling,
2629 Continuation,
2630 GetPostState,
2631 ( Post==triggered ->
2632 UpdatePostState % catching constraints that did not do anything
2633 ;
2634 true
2635 )
2636 ),
2637 Clause2 =
2638 (
2639 Clause2Head :-
2640 Suspension = SuspensionTerm,
2641 CondReactivate,
2642 Clause2Recursion
2643 )
2644 )
2645 ;
2646 List = Tail
2647 ).
2649 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2651 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2652 generate_attach_increment(Clauses) :-
2653 get_max_constraint_index(N),
2654 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2655 Clauses = [Clause1,Clause2],
2656 generate_attach_increment_empty(Clause1),
2657 ( N == 1 ->
2658 generate_attach_increment_one(Clause2)
2659 ;
2660 generate_attach_increment_many(N,Clause2)
2661 )
2662 ;
2663 Clauses = []
2664 ).
2666 generate_attach_increment_empty((attach_increment([],_) :- true)).
2668 generate_attach_increment_one(Clause) :-
2669 Head = attach_increment([Var|Vars],Susps),
2670 get_target_module(Mod),
2671 ( chr_pp_flag(guard_locks,off) ->
2672 NotLocked = true
2673 ;
2674 NotLocked = 'chr not_locked'( Var)
2675 ),
2676 Body =
2677 (
2678 NotLocked,
2679 ( get_attr(Var,Mod,VarSusps) ->
2680 sort(VarSusps,SortedVarSusps),
2681 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2682 put_attr(Var,Mod,MergedSusps)
2683 ;
2684 put_attr(Var,Mod,Susps)
2685 ),
2686 attach_increment(Vars,Susps)
2687 ),
2688 Clause = (Head :- Body).
2690 generate_attach_increment_many(N,Clause) :-
2691 Head = attach_increment([Var|Vars],TAttr1),
2692 % writeln(merge_attributes_1_before),
2693 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2694 % writeln(merge_attributes_1_after),
2695 get_target_module(Mod),
2696 ( chr_pp_flag(guard_locks,off) ->
2697 NotLocked = true
2698 ;
2699 NotLocked = 'chr not_locked'( Var)
2700 ),
2701 Body =
2702 (
2703 NotLocked,
2704 ( get_attr(Var,Mod,TAttr2) ->
2705 MergeGoal,
2706 put_attr(Var,Mod,Attr)
2707 ;
2708 put_attr(Var,Mod,TAttr1)
2709 ),
2710 attach_increment(Vars,TAttr1)
2711 ),
2712 Clause = (Head :- Body).
2714 %% attr_unify_hook
2715 generate_attr_unify_hook(Clauses) :-
2716 get_max_constraint_index(N),
2717 ( N == 0 ->
2718 Clauses = []
2719 ;
2720 ( N == 1 ->
2721 generate_attr_unify_hook_one(Clauses)
2722 ;
2723 generate_attr_unify_hook_many(N,Clauses)
2724 )
2725 ).
2727 generate_attr_unify_hook_one([Clause]) :-
2728 Head = attr_unify_hook(Susps,Other),
2729 get_target_module(Mod),
2730 get_indexed_constraint(1,C),
2731 ( get_store_type(C,ST),
2732 ( ST = default ; ST = multi_store(STs), member(default,STs) ) ->
2733 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2734 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2735 ( atomic_types_suspended_constraint(C) ->
2736 SortGoal1 = true,
2737 SortedSusps = Susps,
2738 SortGoal2 = true,
2739 SortedOtherSusps = OtherSusps,
2740 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2741 NonvarBody = true
2742 ;
2743 SortGoal1 = sort(Susps, SortedSusps),
2744 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2745 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2746 use_auxiliary_predicate(attach_increment),
2747 NonvarBody =
2748 ( compound(Other) ->
2749 term_variables(Other,OtherVars),
2750 attach_increment(OtherVars, SortedSusps)
2751 ;
2752 true
2753 )
2754 ),
2755 Body =
2756 (
2757 SortGoal1,
2758 ( var(Other) ->
2759 ( get_attr(Other,Mod,OtherSusps) ->
2760 SortGoal2,
2761 MergeGoal,
2762 put_attr(Other,Mod,NewSusps),
2763 WakeNewSusps
2764 ;
2765 put_attr(Other,Mod,SortedSusps),
2766 WakeSusps
2767 )
2768 ;
2769 NonvarBody,
2770 WakeSusps
2771 )
2772 ),
2773 Clause = (Head :- Body)
2774 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2775 make_run_suspensions(List,List,WakeNewSusps),
2776 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2777 Body =
2778 ( get_attr(Other,Mod,OtherSusps) ->
2779 MergeGoal,
2780 WakeNewSusps
2781 ;
2782 put_attr(Other,Mod,Susps)
2783 ),
2784 Clause = (Head :- Body)
2785 ).
2788 generate_attr_unify_hook_many(N,[Clause]) :-
2789 chr_pp_flag(dynattr,off), !,
2790 Head = attr_unify_hook(Attr,Other),
2791 get_target_module(Mod),
2792 make_attr(N,Mask,SuspsList,Attr),
2793 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2794 list2conj(SortGoalList,SortGoals),
2795 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2796 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2797 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2798 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2799 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2800 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2801 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2802 NonvarBody = true
2803 ;
2804 use_auxiliary_predicate(attach_increment),
2805 NonvarBody =
2806 ( compound(Other) ->
2807 term_variables(Other,OtherVars),
2808 attach_increment(OtherVars,SortedAttr)
2809 ;
2810 true
2811 )
2812 ),
2813 Body =
2814 (
2815 SortGoals,
2816 ( var(Other) ->
2817 ( get_attr(Other,Mod,TOtherAttr) ->
2818 MergeGoal,
2819 put_attr(Other,Mod,MergedAttr),
2820 WakeMergedSusps
2821 ;
2822 put_attr(Other,Mod,SortedAttr),
2823 WakeSortedSusps
2824 )
2825 ;
2826 NonvarBody,
2827 WakeSortedSusps
2828 )
2829 ),
2830 Clause = (Head :- Body).
2832 % NEW
2833 generate_attr_unify_hook_many(N,Clauses) :-
2834 Head = attr_unify_hook(Attr,Other),
2835 get_target_module(Mod),
2836 normalize_attr(Attr,NormalGoal,NormalAttr),
2837 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2838 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2839 make_run_suspensions(N),
2840 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2841 NonvarBody = true
2842 ;
2843 use_auxiliary_predicate(attach_increment),
2844 NonvarBody =
2845 ( compound(Other) ->
2846 term_variables(Other,OtherVars),
2847 attach_increment(OtherVars,NormalAttr)
2848 ;
2849 true
2850 )
2851 ),
2852 Body =
2853 (
2854 NormalGoal,
2855 ( var(Other) ->
2856 ( get_attr(Other,Mod,OtherAttr) ->
2857 NormalOtherGoal,
2858 MergeGoal,
2859 put_attr(Other,Mod,MergedAttr),
2860 '$dispatch_run_suspensions'(MergedAttr)
2861 ;
2862 put_attr(Other,Mod,NormalAttr),
2863 '$dispatch_run_suspensions'(NormalAttr)
2864 )
2865 ;
2866 NonvarBody,
2867 '$dispatch_run_suspensions'(NormalAttr)
2868 )
2869 ),
2870 Clause = (Head :- Body),
2871 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2872 DispatchList1 = ('$dispatch_run_suspensions'([])),
2873 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2874 run_suspensions_dispatchers(N,[],Dispatchers).
2876 % NEW
2877 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2878 ( N > 0 ->
2879 get_indexed_constraint(N,C),
2880 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2881 ( may_trigger(C) ->
2882 run_suspensions_goal(C,List,Body)
2883 ;
2884 Body = true
2885 ),
2886 M is N - 1,
2887 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2888 ;
2889 Dispatchers = Acc
2890 ).
2892 % NEW
2893 make_run_suspensions(N) :-
2894 ( N > 0 ->
2895 ( get_indexed_constraint(N,C),
2896 may_trigger(C) ->
2897 use_auxiliary_predicate(run_suspensions,C)
2898 ;
2899 true
2900 ),
2901 M is N - 1,
2902 make_run_suspensions(M)
2903 ;
2904 true
2905 ).
2907 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2908 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2910 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2911 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2912 use_auxiliary_predicate(run_suspensions,C),
2913 ( wakes_partially(C) ->
2914 run_suspensions_goal(C,OneSusps,Goal)
2915 ;
2916 run_suspensions_goal(C,AllSusps,Goal)
2917 )
2918 ;
2919 Goal = true
2920 ).
2922 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2923 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2925 make_run_suspensions_loop([],[],_,true).
2926 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2927 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2928 J is I + 1,
2929 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2931 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2932 % $insert_in_store_F/A
2933 % $delete_from_store_F/A
2935 generate_insert_delete_constraints([],[]).
2936 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2937 ( is_stored(FA) ->
2938 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2939 ;
2940 Clauses = RestClauses
2941 ),
2942 generate_insert_delete_constraints(Rest,RestClauses).
2944 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2945 insert_constraint_clause(FA,Clauses,RestClauses1),
2946 delete_constraint_clause(FA,RestClauses1,RestClauses).
2948 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2949 % insert_in_store
2951 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2952 ( chr_pp_flag(inline_insertremove,off) ->
2953 use_auxiliary_predicate(insert_in_store,FA),
2954 insert_constraint_atom(FA,Susp,Goal)
2955 ;
2956 delay_phase_end(validate_store_type_assumptions,
2957 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2958 insert_constraint_direct_used_vars(UsedVars,Vars)
2959 )
2960 )
2961 ).
2963 insert_constraint_direct_used_vars([],_).
2964 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2965 nth1(Index,Vars,Var),
2966 insert_constraint_direct_used_vars(Rest,Vars).
2968 insert_constraint_atom(FA,Susp,Call) :-
2969 make_name('$insert_in_store_',FA,Functor),
2970 Call =.. [Functor,Susp].
2972 insert_constraint_clause(C,Clauses,RestClauses) :-
2973 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2974 Clauses = [Clause|RestClauses],
2975 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2976 insert_constraint_atom(C,Susp,Head),
2977 insert_constraint_body(C,Susp,UsedVars,Body),
2978 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2979 ( chr_pp_flag(store_counter,on) ->
2980 InsertCounterInc = '$insert_counter_inc'
2981 ;
2982 InsertCounterInc = true
2983 )
2984 ;
2985 Clauses = RestClauses
2986 ).
2988 insert_constraint_used_vars([],_,_,true).
2989 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2990 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2991 insert_constraint_used_vars(Rest,C,Susp,Goals).
2993 insert_constraint_body(C,Susp,UsedVars,Body) :-
2994 get_store_type(C,StoreType),
2995 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2997 insert_constraint_body(default,C,Susp,[],Body) :-
2998 global_list_store_name(C,StoreName),
2999 make_get_store_goal(StoreName,Store,GetStoreGoal),
3000 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3001 ( chr_pp_flag(debugable,on) ->
3002 Cell = [Susp|Store],
3003 Body =
3004 (
3005 GetStoreGoal,
3006 UpdateStoreGoal
3007 )
3008 ;
3009 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3010 Body =
3011 (
3012 GetStoreGoal,
3013 Cell = [Susp|Store],
3014 UpdateStoreGoal,
3015 ( Store = [NextSusp|_] ->
3016 SetGoal
3017 ;
3018 true
3019 )
3020 )
3021 ).
3022 % get_target_module(Mod),
3023 % get_max_constraint_index(Total),
3024 % ( Total == 1 ->
3025 % generate_attach_body_1(C,Store,Susp,AttachBody)
3026 % ;
3027 % generate_attach_body_n(C,Store,Susp,AttachBody)
3028 % ),
3029 % Body =
3030 % (
3031 % 'chr default_store'(Store),
3032 % AttachBody
3033 % ).
3034 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3035 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3036 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3037 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3038 sort_out_used_vars(MixedUsedVars,UsedVars).
3039 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3040 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3041 constants_store_index_name(C,Index,IndexName),
3042 IndexLookup =.. [IndexName,Key,StoreName],
3043 Body =
3044 ( IndexLookup ->
3045 nb_getval(StoreName,Store),
3046 b_setval(StoreName,[Susp|Store])
3047 ;
3048 true
3049 ).
3050 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3051 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3052 constants_store_index_name(C,Index,IndexName),
3053 IndexLookup =.. [IndexName,Key,StoreName],
3054 Body =
3055 ( IndexLookup ->
3056 nb_getval(StoreName,Store),
3057 b_setval(StoreName,[Susp|Store])
3058 ;
3059 true
3060 ).
3061 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3062 global_ground_store_name(C,StoreName),
3063 make_get_store_goal(StoreName,Store,GetStoreGoal),
3064 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3065 ( chr_pp_flag(debugable,on) ->
3066 Cell = [Susp|Store],
3067 Body =
3068 (
3069 GetStoreGoal,
3070 UpdateStoreGoal
3071 )
3072 ;
3073 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3074 Body =
3075 (
3076 GetStoreGoal,
3077 Cell = [Susp|Store],
3078 UpdateStoreGoal,
3079 ( Store = [NextSusp|_] ->
3080 SetGoal
3081 ;
3082 true
3083 )
3084 )
3085 ).
3086 % global_ground_store_name(C,StoreName),
3087 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3088 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3089 % Body =
3090 % (
3091 % GetStoreGoal, % nb_getval(StoreName,Store),
3092 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3093 % ).
3094 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3095 % TODO: generalize to more than one !!!
3096 get_target_module(Module),
3097 Body = ( get_attr(Variable,Module,AssocStore) ->
3098 insert_assoc_store(AssocStore,Key,Susp)
3099 ;
3100 new_assoc_store(AssocStore),
3101 put_attr(Variable,Module,AssocStore),
3102 insert_assoc_store(AssocStore,Key,Susp)
3103 ).
3105 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3106 global_singleton_store_name(C,StoreName),
3107 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3108 Body =
3109 (
3110 UpdateStoreGoal
3111 ).
3112 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3113 find_with_var_identity(
3114 B-UV,
3115 [Susp],
3116 (
3117 member(ST,StoreTypes),
3118 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
3119 ),
3120 BodiesUsedVars
3121 ),
3122 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
3123 list2conj(Bodies,Body),
3124 sort_out_used_vars(NestedUsedVars,UsedVars).
3125 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3126 UsedVars = [Index-Var],
3127 get_identifier_size(ISize),
3128 functor(Struct,struct,ISize),
3129 get_identifier_index(C,Index,IIndex),
3130 arg(IIndex,Struct,Susps),
3131 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3132 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3133 UsedVars = [Index-Var],
3134 type_indexed_identifier_structure(IndexType,Struct),
3135 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3136 arg(IIndex,Struct,Susps),
3137 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3139 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3140 flatten(NestedUsedVars,FlatUsedVars),
3141 sort(FlatUsedVars,SortedFlatUsedVars),
3142 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3144 sort_out_used_vars1([],[]).
3145 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3146 sort_out_used_vars1([I-X,J-Y|R],L) :-
3147 ( I == J ->
3148 X = Y,
3149 sort_out_used_vars1([I-X|R],L)
3150 ;
3151 L = [I-X|T],
3152 sort_out_used_vars1([J-Y|R],T)
3153 ).
3155 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3156 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3157 multi_hash_store_name(FA,Index,StoreName),
3158 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3159 Body =
3160 (
3161 KeyBody,
3162 nb_getval(StoreName,Store),
3163 insert_iht(Store,Key,Susp)
3164 ),
3165 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3167 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3168 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3169 multi_hash_store_name(FA,Index,StoreName),
3170 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3171 make_get_store_goal(StoreName,Store,GetStoreGoal),
3172 ( chr_pp_flag(ht_removal,on)
3173 -> ht_prev_field(Index,PrevField),
3174 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3175 SetGoal),
3176 Body =
3177 (
3178 GetStoreGoal,
3179 insert_ht(Store,Key,Susp,Result),
3180 ( Result = [_,NextSusp|_]
3181 -> SetGoal
3182 ; true
3183 )
3184 )
3185 ; Body =
3186 (
3187 GetStoreGoal,
3188 insert_ht(Store,Key,Susp)
3189 )
3190 ),
3191 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3193 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3194 % Delete
3196 delete_constraint_clause(C,Clauses,RestClauses) :-
3197 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3198 Clauses = [Clause|RestClauses],
3199 Clause = (Head :- Body),
3200 delete_constraint_atom(C,Susp,Head),
3201 C = F/A,
3202 functor(Head,F,A),
3203 delete_constraint_body(C,Head,Susp,[],Body)
3204 ;
3205 Clauses = RestClauses
3206 ).
3208 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3209 functor(Head,F,A),
3210 C = F/A,
3211 ( chr_pp_flag(inline_insertremove,off) ->
3212 use_auxiliary_predicate(delete_from_store,C),
3213 delete_constraint_atom(C,Susp,Goal)
3214 ;
3215 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3216 ).
3218 delete_constraint_atom(C,Susp,Atom) :-
3219 make_name('$delete_from_store_',C,Functor),
3220 Atom =.. [Functor,Susp].
3223 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3224 Body = (CounterBody,DeleteBody),
3225 ( chr_pp_flag(store_counter,on) ->
3226 CounterBody = '$delete_counter_inc'
3227 ;
3228 CounterBody = true
3229 ),
3230 get_store_type(C,StoreType),
3231 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3233 delete_constraint_body(default,C,_,Susp,_,Body) :-
3234 ( chr_pp_flag(debugable,on) ->
3235 global_list_store_name(C,StoreName),
3236 make_get_store_goal(StoreName,Store,GetStoreGoal),
3237 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3238 Body =
3239 (
3240 GetStoreGoal, % nb_getval(StoreName,Store),
3241 'chr sbag_del_element'(Store,Susp,NStore),
3242 UpdateStoreGoal % b_setval(StoreName,NStore)
3243 )
3244 ;
3245 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3246 global_list_store_name(C,StoreName),
3247 make_get_store_goal(StoreName,Store,GetStoreGoal),
3248 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3249 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3250 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3251 Body =
3252 (
3253 GetGoal,
3254 ( var(PredCell) ->
3255 GetStoreGoal, % nb_getval(StoreName,Store),
3256 Store = [_|Tail],
3257 UpdateStoreGoal,
3258 ( Tail = [NextSusp|_] ->
3259 SetGoal1
3260 ;
3261 true
3262 )
3263 ;
3264 PredCell = [_,_|Tail],
3265 setarg(2,PredCell,Tail),
3266 ( Tail = [NextSusp|_] ->
3267 SetGoal2
3268 ;
3269 true
3270 )
3271 )
3272 )
3273 ).
3274 % get_target_module(Mod),
3275 % get_max_constraint_index(Total),
3276 % ( Total == 1 ->
3277 % generate_detach_body_1(C,Store,Susp,DetachBody),
3278 % Body =
3279 % (
3280 % 'chr default_store'(Store),
3281 % DetachBody
3282 % )
3283 % ;
3284 % generate_detach_body_n(C,Store,Susp,DetachBody),
3285 % Body =
3286 % (
3287 % 'chr default_store'(Store),
3288 % DetachBody
3289 % )
3290 % ).
3291 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3292 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3293 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3294 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3295 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3296 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3297 constants_store_index_name(C,Index,IndexName),
3298 IndexLookup =.. [IndexName,Key,StoreName],
3299 Body =
3300 ( KeyBody,
3301 ( IndexLookup ->
3302 nb_getval(StoreName,Store),
3303 'chr sbag_del_element'(Store,Susp,NStore),
3304 b_setval(StoreName,NStore)
3305 ;
3306 true
3307 )).
3308 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3309 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3310 constants_store_index_name(C,Index,IndexName),
3311 IndexLookup =.. [IndexName,Key,StoreName],
3312 Body =
3313 ( KeyBody,
3314 ( IndexLookup ->
3315 nb_getval(StoreName,Store),
3316 'chr sbag_del_element'(Store,Susp,NStore),
3317 b_setval(StoreName,NStore)
3318 ;
3319 true
3320 )).
3321 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3322 ( chr_pp_flag(debugable,on) ->
3323 global_ground_store_name(C,StoreName),
3324 make_get_store_goal(StoreName,Store,GetStoreGoal),
3325 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3326 Body =
3327 (
3328 GetStoreGoal, % nb_getval(StoreName,Store),
3329 'chr sbag_del_element'(Store,Susp,NStore),
3330 UpdateStoreGoal % b_setval(StoreName,NStore)
3331 )
3332 ;
3333 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3334 global_ground_store_name(C,StoreName),
3335 make_get_store_goal(StoreName,Store,GetStoreGoal),
3336 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3337 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3338 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3339 Body =
3340 (
3341 GetGoal,
3342 ( var(PredCell) ->
3343 GetStoreGoal, % nb_getval(StoreName,Store),
3344 Store = [_|Tail],
3345 UpdateStoreGoal,
3346 ( Tail = [NextSusp|_] ->
3347 SetGoal1
3348 ;
3349 true
3350 )
3351 ;
3352 PredCell = [_,_|Tail],
3353 setarg(2,PredCell,Tail),
3354 ( Tail = [NextSusp|_] ->
3355 SetGoal2
3356 ;
3357 true
3358 )
3359 )
3360 )
3361 ).
3362 % global_ground_store_name(C,StoreName),
3363 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3364 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3365 % Body =
3366 % (
3367 % GetStoreGoal, % nb_getval(StoreName,Store),
3368 % 'chr sbag_del_element'(Store,Susp,NStore),
3369 % UpdateStoreGoal % b_setval(StoreName,NStore)
3370 % ).
3371 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3372 get_target_module(Module),
3373 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3374 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3375 Body = (
3376 VariableGoal,
3377 get_attr(Variable,Module,AssocStore),
3378 KeyGoal,
3379 delete_assoc_store(AssocStore,Key,Susp)
3380 ).
3381 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3382 global_singleton_store_name(C,StoreName),
3383 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3384 Body =
3385 (
3386 UpdateStoreGoal % b_setval(StoreName,[])
3387 ).
3388 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3389 find_with_var_identity(
3390 B,
3391 [Susp/VarDict/Head],
3392 (
3393 member(ST,StoreTypes),
3394 chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
3395 ),
3396 Bodies
3397 ),
3398 list2conj(Bodies,Body).
3399 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3400 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3401 get_identifier_size(ISize),
3402 functor(Struct,struct,ISize),
3403 get_identifier_index(C,Index,IIndex),
3404 arg(IIndex,Struct,Susps),
3405 Body = (
3406 VariableGoal,
3407 Variable = Struct,
3408 'chr sbag_del_element'(Susps,Susp,NSusps),
3409 setarg(IIndex,Variable,NSusps)
3410 ).
3411 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3412 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
3413 type_indexed_identifier_structure(IndexType,Struct),
3414 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3415 arg(IIndex,Struct,Susps),
3416 Body = (
3417 VariableGoal,
3418 Variable = Struct,
3419 'chr sbag_del_element'(Susps,Susp,NSusps),
3420 setarg(IIndex,Variable,NSusps)
3421 ).
3423 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3424 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3425 multi_hash_store_name(FA,Index,StoreName),
3426 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3427 Body =
3428 (
3429 KeyBody,
3430 nb_getval(StoreName,Store),
3431 delete_iht(Store,Key,Susp)
3432 ),
3433 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3434 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3435 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3436 multi_hash_store_name(C,Index,StoreName),
3437 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3438 make_get_store_goal(StoreName,Store,GetStoreGoal),
3439 ( chr_pp_flag(ht_removal,on)
3440 -> ht_prev_field(Index,PrevField),
3441 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3442 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3443 SetGoal1),
3444 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3445 SetGoal2),
3446 Body =
3447 (
3448 GetGoal,
3449 ( var(Prev)
3450 -> GetStoreGoal,
3451 KeyBody,
3452 delete_first_ht(Store,Key,Values),
3453 ( Values = [NextSusp|_]
3454 -> SetGoal1
3455 ; true
3456 )
3457 ; Prev = [_,_|Values],
3458 setarg(2,Prev,Values),
3459 ( Values = [NextSusp|_]
3460 -> SetGoal2
3461 ; true
3462 )
3463 )
3464 )
3465 ; Body =
3466 (
3467 KeyBody,
3468 GetStoreGoal, % nb_getval(StoreName,Store),
3469 delete_ht(Store,Key,Susp)
3470 )
3471 ),
3472 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3474 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3476 :- chr_constraint
3477 module_initializer/1,
3478 module_initializers/1.
3480 module_initializers(G), module_initializer(Initializer) <=>
3481 G = (Initializer,Initializers),
3482 module_initializers(Initializers).
3484 module_initializers(G) <=>
3485 G = true.
3487 generate_attach_code(Constraints,[Enumerate|L]) :-
3488 enumerate_stores_code(Constraints,Enumerate),
3489 generate_attach_code(Constraints,L,T),
3490 module_initializers(Initializers),
3491 prolog_global_variables_code(PrologGlobalVariables),
3492 % Do not rename or the 'chr_initialization' predicate
3493 % without warning SSS
3494 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3496 generate_attach_code([],L,L).
3497 generate_attach_code([C|Cs],L,T) :-
3498 get_store_type(C,StoreType),
3499 generate_attach_code(StoreType,C,L,L1),
3500 generate_attach_code(Cs,L1,T).
3502 generate_attach_code(default,C,L,T) :-
3503 global_list_store_initialisation(C,L,T).
3504 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3505 multi_inthash_store_initialisations(Indexes,C,L,L1),
3506 multi_inthash_via_lookups(Indexes,C,L1,T).
3507 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3508 multi_hash_store_initialisations(Indexes,C,L,L1),
3509 multi_hash_lookups(Indexes,C,L1,T).
3510 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3511 constants_initializers(C,Index,Constants),
3512 atomic_constants_code(C,Index,Constants,L,T).
3513 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3514 constants_initializers(C,Index,Constants),
3515 ground_constants_code(C,Index,Constants,L,T).
3516 generate_attach_code(global_ground,C,L,T) :-
3517 global_ground_store_initialisation(C,L,T).
3518 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3519 use_auxiliary_module(chr_assoc_store).
3520 generate_attach_code(global_singleton,C,L,T) :-
3521 global_singleton_store_initialisation(C,L,T).
3522 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3523 multi_store_generate_attach_code(StoreTypes,C,L,T).
3524 generate_attach_code(identifier_store(Index),C,L,T) :-
3525 get_identifier_index(C,Index,IIndex),
3526 ( IIndex == 2 ->
3527 get_identifier_size(ISize),
3528 functor(Struct,struct,ISize),
3529 Struct =.. [_,Label|Stores],
3530 set_elems(Stores,[]),
3531 Clause1 = new_identifier(Label,Struct),
3532 functor(Struct2,struct,ISize),
3533 arg(1,Struct2,Label2),
3534 Clause2 =
3535 ( user:portray(Struct2) :-
3536 write('<id:'),
3537 print(Label2),
3538 write('>')
3539 ),
3540 functor(Struct3,struct,ISize),
3541 arg(1,Struct3,Label3),
3542 Clause3 = identifier_label(Struct3,Label3),
3543 L = [Clause1,Clause2,Clause3|T]
3544 ;
3545 L = T
3546 ).
3547 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3548 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3549 ( IIndex == 2 ->
3550 identifier_store_initialization(IndexType,L,L1),
3551 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3552 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3553 get_type_indexed_identifier_size(IndexType,ISize),
3554 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3555 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3556 type_indexed_identifier_structure(IndexType,Struct),
3557 Struct =.. [_,Label|Stores],
3558 set_elems(Stores,[]),
3559 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3560 Clause1 =.. [Name1,Label,Struct],
3561 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3562 Goal1 =.. [Name1,Label1b,S1b],
3563 type_indexed_identifier_structure(IndexType,Struct1b),
3564 Struct1b =.. [_,Label1b|Stores1b],
3565 set_elems(Stores1b,[]),
3566 Expansion1 = (S1b = Struct1b),
3567 Clause1b = user:goal_expansion(Goal1,Expansion1),
3568 % writeln(Clause1-Clause1b),
3569 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3570 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3571 type_indexed_identifier_structure(IndexType,Struct2),
3572 arg(1,Struct2,Label2),
3573 Clause2 =
3574 ( user:portray(Struct2) :-
3575 write('<id:'),
3576 print(Label2),
3577 write('>')
3578 ),
3579 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3581 type_indexed_identifier_structure(IndexType,Struct3),
3582 arg(1,Struct3,Label3),
3583 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3584 Clause3 =.. [Name3,Struct3,Label3],
3585 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3586 Goal3b =.. [Name3,S3b,L3b],
3587 type_indexed_identifier_structure(IndexType,Struct3b),
3588 arg(1,Struct3b,L3b),
3589 Expansion3b = (S3 = Struct3b),
3590 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3591 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3592 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3593 identifier_store_name(IndexType,GlobalVariable),
3594 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3595 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3596 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3597 Clause4 =
3598 ( LookupAtom :-
3599 nb_getval(GlobalVariable,HT),
3600 ( lookup_ht(HT,X,[IX]) ->
3601 true
3602 ;
3603 NewIdentifierGoal,
3604 insert_ht(HT,X,IX)
3605 )
3606 ),
3607 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3608 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3609 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3610 ;
3611 L = T
3612 ).
3614 constants_initializers(C,Index,Constants) :-
3615 maplist(constants_store_name(C,Index),Constants,StoreNames),
3616 findall(Initializer,
3617 ( member(StoreName,StoreNames),
3618 Initializer = nb_setval(StoreName,[])
3619 ),
3620 Initializers),
3621 maplist(module_initializer,Initializers).
3623 lookup_identifier_atom(Key,X,IX,Atom) :-
3624 atom_concat('lookup_identifier_',Key,LookupFunctor),
3625 Atom =.. [LookupFunctor,X,IX].
3627 identifier_label_atom(IndexType,IX,X,Atom) :-
3628 type_indexed_identifier_name(IndexType,identifier_label,Name),
3629 Atom =.. [Name,IX,X].
3631 multi_store_generate_attach_code([],_,L,L).
3632 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3633 generate_attach_code(ST,C,L,L1),
3634 multi_store_generate_attach_code(STs,C,L1,T).
3636 multi_inthash_store_initialisations([],_,L,L).
3637 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3638 use_auxiliary_module(chr_integertable_store),
3639 multi_hash_store_name(FA,Index,StoreName),
3640 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3641 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3642 L1 = L,
3643 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3644 multi_hash_store_initialisations([],_,L,L).
3645 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3646 use_auxiliary_module(chr_hashtable_store),
3647 multi_hash_store_name(FA,Index,StoreName),
3648 prolog_global_variable(StoreName),
3649 make_init_store_goal(StoreName,HT,InitStoreGoal),
3650 module_initializer((new_ht(HT),InitStoreGoal)),
3651 L1 = L,
3652 multi_hash_store_initialisations(Indexes,FA,L1,T).
3654 global_list_store_initialisation(C,L,T) :-
3655 ( is_stored(C) ->
3656 global_list_store_name(C,StoreName),
3657 prolog_global_variable(StoreName),
3658 make_init_store_goal(StoreName,[],InitStoreGoal),
3659 module_initializer(InitStoreGoal)
3660 ;
3661 true
3662 ),
3663 L = T.
3664 global_ground_store_initialisation(C,L,T) :-
3665 global_ground_store_name(C,StoreName),
3666 prolog_global_variable(StoreName),
3667 make_init_store_goal(StoreName,[],InitStoreGoal),
3668 module_initializer(InitStoreGoal),
3669 L = T.
3670 global_singleton_store_initialisation(C,L,T) :-
3671 global_singleton_store_name(C,StoreName),
3672 prolog_global_variable(StoreName),
3673 make_init_store_goal(StoreName,[],InitStoreGoal),
3674 module_initializer(InitStoreGoal),
3675 L = T.
3676 identifier_store_initialization(IndexType,L,T) :-
3677 use_auxiliary_module(chr_hashtable_store),
3678 identifier_store_name(IndexType,StoreName),
3679 prolog_global_variable(StoreName),
3680 make_init_store_goal(StoreName,HT,InitStoreGoal),
3681 module_initializer((new_ht(HT),InitStoreGoal)),
3682 L = T.
3685 multi_inthash_via_lookups([],_,L,L).
3686 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3687 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3688 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3689 L = [(Head :- Body)|L1],
3690 multi_inthash_via_lookups(Indexes,C,L1,T).
3691 multi_hash_lookups([],_,L,L).
3692 multi_hash_lookups([Index|Indexes],C,L,T) :-
3693 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3694 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3695 L = [(Head :- Body)|L1],
3696 multi_hash_lookups(Indexes,C,L1,T).
3698 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3699 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3700 Head =.. [Name,Key,SuspsList].
3702 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3703 %
3704 % Returns goal that performs hash table lookup.
3705 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3706 % INLINED:
3707 get_store_type(ConstraintSymbol,multi_store(Stores)),
3708 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3709 ( ground(Key) ->
3710 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3711 Goal = nb_getval(StoreName,SuspsList)
3712 ;
3713 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3714 Lookup =.. [IndexName,Key,StoreName],
3715 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3716 )
3717 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3718 ( ground(Key) ->
3719 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3720 Goal = nb_getval(StoreName,SuspsList)
3721 ;
3722 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3723 Lookup =.. [IndexName,Key,StoreName],
3724 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3725 )
3726 ; memberchk(multi_hash([Index]),Stores) ->
3727 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3728 make_get_store_goal(StoreName,HT,GetStoreGoal),
3729 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3730 Goal =
3731 (
3732 GetStoreGoal, % nb_getval(StoreName,HT),
3733 HashCall, % hash_term(Key,Hash),
3734 lookup_ht1(HT,Hash,Key,SuspsList)
3735 )
3736 ;
3737 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3738 Goal =
3739 (
3740 GetStoreGoal, % nb_getval(StoreName,HT),
3741 Lookup
3742 )
3743 )
3744 ; HashType == inthash ->
3745 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3746 make_get_store_goal(StoreName,HT,GetStoreGoal),
3747 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3748 Goal =
3749 (
3750 GetStoreGoal, % nb_getval(StoreName,HT),
3751 Lookup
3752 )
3753 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3754 % find alternative index
3755 % -> SubIndex + RestIndex
3756 % -> SubKey + RestKeys
3757 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3758 % instantiate rest goal?
3759 % Goal = (SubGoal,RestGoal)
3760 ).
3763 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3764 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3766 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3767 ( ground(Key) ->
3768 % This is based on a property of SWI-Prolog's
3769 % hash_term/2 predicate:
3770 % the hash value is stable over repeated invocations
3771 % of SWI-Prolog
3772 hash_term(Key,Hash),
3773 Call = true
3774 ; Index = [IndexPos],
3775 get_constraint_type(Constraint,ArgTypes),
3776 nth1(IndexPos,ArgTypes,Type),
3777 unalias_type(Type,NormalType),
3778 memberchk_eq(NormalType,[int,natural]) ->
3779 ( NormalType == int ->
3780 Hash = abs(Key),
3781 Call = true
3782 ;
3783 Hash = Key,
3784 Call = true
3785 )
3786 ;
3787 nonvar(Key),
3788 specialize_hash_term(Key,NewKey),
3789 NewKey \== Key,
3790 Call = hash_term(NewKey,Hash)
3791 ).
3793 specialize_hash_term(Term,NewTerm) :-
3794 ( ground(Term) ->
3795 hash_term(Term,NewTerm)
3796 ; var(Term) ->
3797 NewTerm = Term
3798 ;
3799 Term =.. [F|Args],
3800 maplist(specialize_hash_term,Args,NewArgs),
3801 NewTerm =.. [F|NewArgs]
3802 ).
3804 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3805 ( /* chr_pp_flag(experiment,off) ->
3806 true
3807 ; */ atomic(Key) ->
3808 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3809 ; ground(Key) ->
3810 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3811 ;
3812 ( Index = [Pos],
3813 get_constraint_arg_type(ConstraintSymbol,Pos,chr_constants)
3814 ->
3815 true
3816 ;
3817 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3818 )
3819 ),
3820 delay_phase_end(validate_store_type_assumptions,
3821 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3823 :- chr_constraint actual_atomic_multi_hash_keys/3.
3824 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3826 :- chr_constraint actual_ground_multi_hash_keys/3.
3827 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3829 :- chr_constraint actual_non_ground_multi_hash_key/2.
3830 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3832 /*
3833 actual_atomic_multi_hash_keys(C,Index,Keys)
3834 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3836 actual_ground_multi_hash_keys(C,Index,Keys)
3837 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3839 actual_non_ground_multi_hash_key(C,Index)
3840 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3841 */
3842 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3843 <=> append(Keys1,Keys2,Keys0),
3844 sort(Keys0,Keys),
3845 actual_atomic_multi_hash_keys(C,Index,Keys).
3847 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3848 <=> append(Keys1,Keys2,Keys0),
3849 sort(Keys0,Keys),
3850 actual_ground_multi_hash_keys(C,Index,Keys).
3852 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3853 <=> append(Keys1,Keys2,Keys0),
3854 sort(Keys0,Keys),
3855 actual_ground_multi_hash_keys(C,Index,Keys).
3857 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3858 <=> true.
3860 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3861 <=> true.
3863 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3864 <=> true.
3866 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3867 %
3868 % Returns predicate name of hash table lookup predicate.
3869 multi_hash_lookup_name(F/A,Index,Name) :-
3870 ( integer(Index) ->
3871 IndexName = Index
3872 ; is_list(Index) ->
3873 atom_concat_list(Index,IndexName)
3874 ),
3875 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3877 multi_hash_store_name(F/A,Index,Name) :-
3878 get_target_module(Mod),
3879 ( integer(Index) ->
3880 IndexName = Index
3881 ; is_list(Index) ->
3882 atom_concat_list(Index,IndexName)
3883 ),
3884 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3886 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3887 ( ( integer(Index) ->
3888 I = Index
3889 ;
3890 Index = [I]
3891 ) ->
3892 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3893 ; is_list(Index) ->
3894 sort(Index,Indexes),
3895 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3896 once(pairup(Bodies,Keys,ArgKeyPairs)),
3897 Key =.. [k|Keys],
3898 list2conj(Bodies,KeyBody)
3899 ).
3901 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3902 ( ( integer(Index) ->
3903 I = Index
3904 ;
3905 Index = [I]
3906 ) ->
3907 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3908 ; is_list(Index) ->
3909 sort(Index,Indexes),
3910 find_with_var_identity(
3911 Goal-KeyI,
3912 [Susp/Head/VarDict],
3913 (
3914 member(I,Indexes),
3915 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3916 ),
3917 ArgKeyPairs
3918 ),
3919 once(pairup(Bodies,Keys,ArgKeyPairs)),
3920 Key =.. [k|Keys],
3921 list2conj(Bodies,KeyBody)
3922 ).
3924 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3925 arg(Index,Head,OriginalArg),
3926 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3927 Goal = true
3928 ;
3929 functor(Head,F,A),
3930 C = F/A,
3931 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3932 ).
3934 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3935 ( ( integer(Index) ->
3936 I = Index
3937 ;
3938 Index = [I]
3939 ) ->
3940 UsedVars = [I-Key]
3941 ; is_list(Index) ->
3942 sort(Index,Indexes),
3943 pairup(Indexes,Keys,UsedVars),
3944 Key =.. [k|Keys]
3945 ).
3947 multi_hash_key_args(Index,Head,KeyArgs) :-
3948 ( integer(Index) ->
3949 arg(Index,Head,Arg),
3950 KeyArgs = [Arg]
3951 ; is_list(Index) ->
3952 sort(Index,Indexes),
3953 term_variables(Head,Vars),
3954 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3955 ).
3958 %-------------------------------------------------------------------------------
3959 atomic_constants_code(C,Index,Constants,L,T) :-
3960 constants_store_index_name(C,Index,IndexName),
3961 findall(Clause,
3962 ( member(Constant,Constants),
3963 constants_store_name(C,Index,Constant,StoreName),
3964 Clause =.. [IndexName,Constant,StoreName]
3965 ),
3966 Clauses),
3967 append(Clauses,T,L).
3969 %-------------------------------------------------------------------------------
3970 ground_constants_code(C,Index,Terms,L,T) :-
3971 constants_store_index_name(C,Index,IndexName),
3972 findall(StoreName,
3973 ( member(Constant,Terms),
3974 constants_store_name(C,Index,Constant,StoreName)
3975 ),
3976 StoreNames),
3977 length(Terms,N),
3978 replicate(N,[],More),
3979 trie_index([Terms|More],StoreNames,IndexName,L,T).
3981 constants_store_name(F/A,Index,Term,Name) :-
3982 get_target_module(Mod),
3983 term_to_atom(Term,Constant),
3984 term_to_atom(Index,IndexAtom),
3985 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3987 constants_store_index_name(F/A,Index,Name) :-
3988 get_target_module(Mod),
3989 term_to_atom(Index,IndexAtom),
3990 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3992 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3993 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3995 trie_step([],_,_,[],[],L,L) :- !.
3996 % length MorePatterns == length Patterns == length Results
3997 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3998 MorePatterns = [List|_],
3999 length(List,N),
4000 aggregate_all(set(F/A),
4001 ( member(Pattern,Patterns),
4002 functor(Pattern,F,A)
4003 ),
4004 FAs),
4005 N1 is N + 1,
4006 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4008 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4009 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4010 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4011 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4013 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4014 Clause = (Head :- Body),
4015 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4016 N1 is N + 1,
4017 functor(Head,Symbol,N1),
4018 arg(1,Head,IndexPattern),
4019 Head =.. [_,_|RestArgs],
4020 once(append(Vs,[Result],RestArgs)),
4021 /* IndexPattern = F() */
4022 functor(IndexPattern,F,A),
4023 IndexPattern =.. [_|Args],
4024 append(Args,RestArgs,RecArgs),
4025 ( RecArgs == [Result] ->
4026 /* nothing more to match on */
4027 List = Tail,
4028 Body = true,
4029 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4030 MoreResults = [Result]
4031 ; /* more things to match on */
4032 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4033 ( MoreCases = [OneMoreCase] ->
4034 /* only one more thing to match on */
4035 List = Tail,
4036 Body = true,
4037 append([Cases,OneMoreCase,MoreResults],RecArgs)
4038 ;
4039 /* more than one thing to match on */
4040 /* [ x1,..., xn]
4041 [xs1,...,xsn]
4042 */
4043 pairup(Cases,MoreCases,CasePairs),
4044 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4045 append(Args,Vs,[First|Rest]),
4046 First-Rest = CommonPatternPair,
4047 % Body = RSymbol(DiffVars,Result)
4048 gensym(Prefix,RSymbol),
4049 append(DiffVars,[Result],RecCallVars),
4050 Body =.. [RSymbol|RecCallVars],
4051 findall(CH-CT,member([CH|CT],Differences),CPairs),
4052 once(pairup(CHs,CTs,CPairs)),
4053 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4054 )
4055 ).
4057 rec_cases([],[],[],_,[],[],[]).
4058 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4059 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4060 Cases = [Case|NCases],
4061 MoreCases = [MoreCase|NMoreCases],
4062 MoreResults = [Result|NMoreResults],
4063 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4064 ;
4065 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4066 ).
4068 %% common_pattern(+terms,-term,-vars,-differences) is det.
4069 common_pattern(Ts,T,Vars,Differences) :-
4070 fold1(gct,Ts,T),
4071 term_variables(T,Vars),
4072 findall(Vars,member(T,Ts),Differences).
4074 gct(T1,T2,T) :-
4075 gct_(T1,T2,T,[],_).
4077 gct_(T1,T2,T,Dict0,Dict) :-
4078 ( nonvar(T1),
4079 nonvar(T2),
4080 functor(T1,F1,A1),
4081 functor(T2,F2,A2),
4082 F1 == F2,
4083 A1 == A2 ->
4084 functor(T,F1,A1),
4085 T1 =.. [_|Args1],
4086 T2 =.. [_|Args2],
4087 T =.. [_|Args],
4088 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4089 ;
4090 /* T is a variable */
4091 ( lookup_eq(Dict0,T1+T2,T) ->
4092 /* we already have a variable for this difference */
4093 Dict = Dict0
4094 ;
4095 /* T is a fresh variable */
4096 Dict = [(T1+T2)-T|Dict0]
4097 )
4098 ).
4101 fold1(P,[Head|Tail],Result) :-
4102 fold(Tail,P,Head,Result).
4104 fold([],_,Acc,Acc).
4105 fold([X|Xs],P,Acc,Res) :-
4106 call(P,X,Acc,NAcc),
4107 fold(Xs,P,NAcc,Res).
4109 maplist_dcg(P,L1,L2,L) -->
4110 maplist_dcg_(L1,L2,L,P).
4112 maplist_dcg_([],[],[],_) --> [].
4113 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4114 call(P,X,Y,Z),
4115 maplist_dcg_(Xs,Ys,Zs,P).
4116 %-------------------------------------------------------------------------------
4117 global_list_store_name(F/A,Name) :-
4118 get_target_module(Mod),
4119 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4120 global_ground_store_name(F/A,Name) :-
4121 get_target_module(Mod),
4122 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4123 global_singleton_store_name(F/A,Name) :-
4124 get_target_module(Mod),
4125 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4127 identifier_store_name(TypeName,Name) :-
4128 get_target_module(Mod),
4129 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4131 :- chr_constraint prolog_global_variable/1.
4132 :- chr_option(mode,prolog_global_variable(+)).
4134 :- chr_constraint prolog_global_variables/1.
4135 :- chr_option(mode,prolog_global_variables(-)).
4137 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4139 prolog_global_variables(List), prolog_global_variable(Name) <=>
4140 List = [Name|Tail],
4141 prolog_global_variables(Tail).
4142 prolog_global_variables(List) <=> List = [].
4144 %% SWI begin
4145 prolog_global_variables_code(Code) :-
4146 prolog_global_variables(Names),
4147 ( Names == [] ->
4148 Code = []
4149 ;
4150 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
4151 Code = [(:- dynamic user:exception/3),
4152 (:- multifile user:exception/3),
4153 (user:exception(undefined_global_variable,Name,retry) :-
4154 (
4155 '$chr_prolog_global_variable'(Name),
4156 '$chr_initialization'
4157 )
4158 )
4159 |
4160 NameDeclarations
4161 ]
4162 ).
4163 %% SWI end
4164 %% SICStus begin
4165 % prolog_global_variables_code([]).
4166 %% SICStus end
4167 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4168 %sbag_member_call(S,L,sysh:mem(S,L)).
4169 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4170 %sbag_member_call(S,L,member(S,L)).
4171 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4172 %update_mutable_call(A,B,setarg(1, B, A)).
4173 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4174 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4176 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4177 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4178 % create_get_mutable(Value,Field,Get1).
4179 %
4180 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4181 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4182 % update_mutable_call(NewValue,Field,Set).
4183 %
4184 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4185 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4186 % create_get_mutable_ref(Value,Field,Get1),
4187 % update_mutable_call(NewValue,Field,Set).
4188 %
4189 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4190 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4191 % create_mutable_call(Value,Field,Create).
4192 %
4193 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4194 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4195 % create_get_mutable(Value,Field,Get).
4196 %
4197 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4198 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4199 % create_get_mutable_ref(Value,Field,Get),
4200 % update_mutable_call(NewValue,Field,Set).
4202 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4203 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4205 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4206 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4208 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4209 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4210 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4212 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4213 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4215 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4216 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4218 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4219 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4220 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4222 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4224 enumerate_stores_code(Constraints,Clause) :-
4225 Head = '$enumerate_constraints'(Constraint),
4226 enumerate_store_bodies(Constraints,Constraint,Bodies),
4227 list2disj(Bodies,Body),
4228 Clause = (Head :- Body).
4230 enumerate_store_bodies([],_,[]).
4231 enumerate_store_bodies([C|Cs],Constraint,L) :-
4232 ( is_stored(C) ->
4233 get_store_type(C,StoreType),
4234 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4235 true
4236 ;
4237 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4238 ),
4239 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4240 C = F/_,
4241 Constraint0 =.. [F|Arguments],
4242 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4243 L = [Body|T]
4244 ;
4245 L = T
4246 ),
4247 enumerate_store_bodies(Cs,Constraint,T).
4249 enumerate_store_body(default,C,Susp,Body) :-
4250 global_list_store_name(C,StoreName),
4251 sbag_member_call(Susp,List,Sbag),
4252 make_get_store_goal(StoreName,List,GetStoreGoal),
4253 Body =
4254 (
4255 GetStoreGoal, % nb_getval(StoreName,List),
4256 Sbag
4257 ).
4258 % get_constraint_index(C,Index),
4259 % get_target_module(Mod),
4260 % get_max_constraint_index(MaxIndex),
4261 % Body1 =
4262 % (
4263 % 'chr default_store'(GlobalStore),
4264 % get_attr(GlobalStore,Mod,Attr)
4265 % ),
4266 % ( MaxIndex > 1 ->
4267 % NIndex is Index + 1,
4268 % sbag_member_call(Susp,List,Sbag),
4269 % Body2 =
4270 % (
4271 % arg(NIndex,Attr,List),
4272 % Sbag
4273 % )
4274 % ;
4275 % sbag_member_call(Susp,Attr,Sbag),
4276 % Body2 = Sbag
4277 % ),
4278 % Body = (Body1,Body2).
4279 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4280 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4281 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4282 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4283 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4284 Completeness == complete, % fail if incomplete
4285 find_with_var_identity(nb_getval(StoreName,Susps),[Susps],
4286 ( member(Constant,Constants),
4287 constants_store_name(C,Index,Constant,StoreName) )
4288 , Disjuncts),
4289 list2disj(Disjuncts, Disjunction),
4290 Body = ( Disjunction, member(Susp,Susps) ).
4291 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4292 Completeness == complete, % fail if incomplete
4293 find_with_var_identity(nb_getval(StoreName,Susps),[Susps],
4294 ( member(Constant,Constants),
4295 constants_store_name(C,Index,Constant,StoreName) )
4296 , Disjuncts),
4297 list2disj(Disjuncts, Disjunction),
4298 Body = ( Disjunction, member(Susp,Susps) ).
4299 enumerate_store_body(global_ground,C,Susp,Body) :-
4300 global_ground_store_name(C,StoreName),
4301 sbag_member_call(Susp,List,Sbag),
4302 make_get_store_goal(StoreName,List,GetStoreGoal),
4303 Body =
4304 (
4305 GetStoreGoal, % nb_getval(StoreName,List),
4306 Sbag
4307 ).
4308 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4309 Body = fail.
4310 enumerate_store_body(global_singleton,C,Susp,Body) :-
4311 global_singleton_store_name(C,StoreName),
4312 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4313 Body =
4314 (
4315 GetStoreGoal, % nb_getval(StoreName,Susp),
4316 Susp \== []
4317 ).
4318 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4319 once((
4320 member(ST,STs),
4321 enumerate_store_body(ST,C,Susp,Body)
4322 )).
4323 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4324 Body = fail.
4325 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4326 Body = fail.
4328 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4329 multi_hash_store_name(C,I,StoreName),
4330 B =
4331 (
4332 nb_getval(StoreName,HT),
4333 value_iht(HT,Susp)
4334 ).
4335 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4336 multi_hash_store_name(C,I,StoreName),
4337 make_get_store_goal(StoreName,HT,GetStoreGoal),
4338 B =
4339 (
4340 GetStoreGoal, % nb_getval(StoreName,HT),
4341 value_ht(HT,Susp)
4342 ).
4344 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4347 :- chr_constraint
4348 prev_guard_list/8,
4349 prev_guard_list/6,
4350 simplify_guards/1,
4351 set_all_passive/1.
4353 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4354 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4355 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4356 :- chr_option(mode,simplify_guards(+)).
4357 :- chr_option(mode,set_all_passive(+)).
4359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4360 % GUARD SIMPLIFICATION
4361 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4362 % If the negation of the guards of earlier rules entails (part of)
4363 % the current guard, the current guard can be simplified. We can only
4364 % use earlier rules with a head that matches if the head of the current
4365 % rule does, and which make it impossible for the current rule to match
4366 % if they fire (i.e. they shouldn't be propagation rules and their
4367 % head constraints must be subsets of those of the current rule).
4368 % At this point, we know for sure that the negation of the guard
4369 % of such a rule has to be true (otherwise the earlier rule would have
4370 % fired, because of the refined operational semantics), so we can use
4371 % that information to simplify the guard by replacing all entailed
4372 % conditions by true/0. As a consequence, the never-stored analysis
4373 % (in a further phase) will detect more cases of never-stored constraints.
4374 %
4375 % e.g. c(X),d(Y) <=> X > 0 | ...
4376 % e(X) <=> X < 0 | ...
4377 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4378 % \____________/
4379 % true
4381 guard_simplification :-
4382 ( chr_pp_flag(guard_simplification,on) ->
4383 precompute_head_matchings,
4384 simplify_guards(1)
4385 ;
4386 true
4387 ).
4389 % for every rule, we create a prev_guard_list where the last argument
4390 % eventually is a list of the negations of earlier guards
4391 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4392 <=>
4393 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4394 append(Head1,Head2,Heads),
4395 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4396 multiple_occ_constraints_checked([]),
4397 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4399 append(IDs1,IDs2,IDs),
4400 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4401 empty_q(EmptyHeap),
4402 insert_list_q(HeapData,EmptyHeap,Heap),
4403 next_prev_rule(Heap,_,Heap1),
4404 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4405 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4406 NextRule is RuleNb+1,
4407 simplify_guards(NextRule).
4409 next_prev_rule(Heap,RuleNb,NHeap) :-
4410 ( find_min_q(Heap,_-Priority) ->
4411 Priority = (-RuleNb),
4412 normalize_heap(Heap,Priority,NHeap)
4413 ;
4414 RuleNb = 0,
4415 NHeap = Heap
4416 ).
4418 normalize_heap(Heap,Priority,NHeap) :-
4419 ( find_min_q(Heap,_-Priority) ->
4420 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4421 ( O > 1 ->
4422 NO is O -1,
4423 get_occurrence(C,NO,RuleNb,_),
4424 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4425 ;
4426 Heap2 = Heap1
4427 ),
4428 normalize_heap(Heap2,Priority,NHeap)
4429 ;
4430 NHeap = Heap
4431 ).
4433 % no more rule
4434 simplify_guards(_)
4435 <=>
4436 true.
4438 % The negation of the guard of a non-propagation rule is added
4439 % if its kept head constraints are a subset of the kept constraints of
4440 % the rule we're working on, and its removed head constraints (at least one)
4441 % are a subset of the removed constraints.
4443 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4444 <=>
4445 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4446 H1 \== [],
4447 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4448 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4449 |
4450 append(H1,H2,Heads),
4451 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4452 append(GuardList,DerivedInfo,GL1),
4453 normalize_conj_list(GL1,GL),
4454 append(GH_New1,GH,GH1),
4455 normalize_conj_list(GH1,GH_New),
4456 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4457 % PrevPrevRuleNb is PrevRuleNb-1,
4458 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4460 % if this isn't the case, we skip this one and try the next rule
4461 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4462 <=>
4463 ( N > 0 ->
4464 next_prev_rule(Heap,N1,NHeap),
4465 % N1 is N-1,
4466 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4467 ;
4468 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4469 ).
4471 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4472 <=>
4473 GH \== []
4474 |
4475 head_types_modes_condition(GH,H,TypeInfo),
4476 conj2list(TypeInfo,TI),
4477 term_variables(H,HeadVars),
4478 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4479 normalize_conj_list(Info,InfoL),
4480 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4482 head_types_modes_condition([],H,true).
4483 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4484 types_modes_condition(H,GH,TI1),
4485 head_types_modes_condition(GHs,H,TI2).
4487 %%
4488 %
4489 % when all earlier guards are added or skipped, we simplify the guard.
4490 % if it's different from the original one, we change the rule
4492 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4493 <=>
4494 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4495 G \== true, % let's not try to simplify this ;)
4496 append(M,GuardList,Info),
4497 simplify_guard(G,B,Info,SimpleGuard,NB),
4498 G \== SimpleGuard
4499 |
4500 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4501 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4503 %% normalize_conj_list(+List,-NormalList) is det.
4504 %
4505 % Removes =true= elements and flattens out conjunctions.
4507 normalize_conj_list(List,NormalList) :-
4508 list2conj(List,Conj),
4509 conj2list(Conj,NormalList).
4511 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4512 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4513 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4515 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4516 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4517 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4518 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4519 append(Renaming1,ExtraRenaming,Renaming2),
4520 list2conj(PrevMatchings,Match),
4521 negate_b(Match,HeadsDontMatch),
4522 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4523 list2conj(HeadsMatch,HeadsMatchBut),
4524 term_variables(Renaming2,RenVars),
4525 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4526 new_vars(MGVars,RenVars,ExtraRenaming2),
4527 append(Renaming2,ExtraRenaming2,Renaming),
4528 ( PrevGuard == true -> % true can't fail
4529 Info_ = HeadsDontMatch
4530 ;
4531 negate_b(PrevGuard,TheGuardFailed),
4532 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4533 ),
4534 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4535 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4536 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4537 list2conj(RenamedMatchings_,RenamedMatchings),
4538 apply_guard_wrt_term(H,RenamedG2,GH2),
4539 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4540 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4542 simplify_guard(G,B,Info,SG,NB) :-
4543 conj2list(G,LG),
4544 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4545 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4546 list2conj(SGL,SG).
4549 new_vars([],_,[]).
4550 new_vars([A|As],RV,ER) :-
4551 ( memberchk_eq(A,RV) ->
4552 new_vars(As,RV,ER)
4553 ;
4554 ER = [A-NewA,NewA-A|ER2],
4555 new_vars(As,RV,ER2)
4556 ).
4558 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4559 %
4560 % check if a list of constraints is a subset of another list of constraints
4561 % (multiset-subset), meanwhile computing a variable renaming to convert
4562 % one into the other.
4563 head_subset(H,Head,Renaming) :-
4564 head_subset(H,Head,Renaming,[],_).
4566 head_subset([],Remainder,Renaming,Renaming,Remainder).
4567 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4568 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4569 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4571 % check if A is in the list, remove it from Headleft
4572 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4573 ( variable_replacement(A,X,Acc,Renaming),
4574 Remainder = Xs
4575 ;
4576 Remainder = [X|RRemainder],
4577 head_member(Xs,A,Renaming,Acc,RRemainder)
4578 ).
4579 %-------------------------------------------------------------------------------%
4580 % memoing code to speed up repeated computation
4582 :- chr_constraint precompute_head_matchings/0.
4584 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4585 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4586 append(H1,H2,Heads),
4587 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4588 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4589 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4591 precompute_head_matchings <=> true.
4593 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4594 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4596 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4597 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4599 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4600 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4601 <=>
4602 Q1 = NHeads,
4603 Q2 = Matchings.
4604 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4606 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4607 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4608 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4609 %-------------------------------------------------------------------------------%
4611 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4612 extract_arguments(Heads,Arguments),
4613 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4614 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4616 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4617 extract_arguments(Heads,Arguments),
4618 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4619 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4621 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4622 extract_arguments(Heads,Arguments1),
4623 extract_arguments(MatchingFreeHeads,Arguments2),
4624 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4626 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4627 %
4628 % Returns list of arguments of given list of constraints.
4629 extract_arguments([],[]).
4630 extract_arguments([Constraint|Constraints],AllArguments) :-
4631 Constraint =.. [_|Arguments],
4632 append(Arguments,RestArguments,AllArguments),
4633 extract_arguments(Constraints,RestArguments).
4635 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4636 %
4637 % Substitutes arguments of constraints with those in the given list.
4639 substitute_arguments([],[],[]).
4640 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4641 functor(Constraint,F,N),
4642 split_at(N,Variables,Arguments,RestVariables),
4643 NConstraint =.. [F|Arguments],
4644 substitute_arguments(Constraints,RestVariables,NConstraints).
4646 make_matchings_explicit([],[],_,MC,MC,[]).
4647 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4648 ( var(Arg) ->
4649 ( memberchk_eq(Arg,VarAcc) ->
4650 list2disj(MatchingCondition,MatchingCondition_disj),
4651 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4652 NVarAcc = VarAcc
4653 ;
4654 Matchings = RestMatchings,
4655 NewVar = Arg,
4656 NVarAcc = [Arg|VarAcc]
4657 ),
4658 MatchingCondition2 = MatchingCondition
4659 ;
4660 functor(Arg,F,A),
4661 Arg =.. [F|RecArgs],
4662 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4663 FlatArg =.. [F|RecVars],
4664 ( RecMatchings == [] ->
4665 Matchings = [functor(NewVar,F,A)|RestMatchings]
4666 ;
4667 list2conj(RecMatchings,ArgM_conj),
4668 list2disj(MatchingCondition,MatchingCondition_disj),
4669 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4670 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4671 ),
4672 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4673 term_variables(Args,ArgVars),
4674 append(ArgVars,VarAcc,NVarAcc)
4675 ),
4676 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4679 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4680 %
4681 % Returns list of new variables and list of pairwise unifications between given list and variables.
4683 make_matchings_explicit_not_negated([],[],[]).
4684 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4685 Matchings = [Var = X|RMatchings],
4686 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4688 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4689 %
4690 % (Partially) applies substitutions of =Goal= to given list.
4692 apply_guard_wrt_term([],_Guard,[]).
4693 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4694 ( var(Term) ->
4695 apply_guard_wrt_variable(Guard,Term,NTerm)
4696 ;
4697 Term =.. [F|HArgs],
4698 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4699 NTerm =.. [F|NewHArgs]
4700 ),
4701 apply_guard_wrt_term(RH,Guard,RGH).
4703 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4704 %
4705 % (Partially) applies goal =Guard= wrt variable.
4707 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4708 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4709 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4710 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4711 ( Guard = (X = Y), Variable == X ->
4712 NVariable = Y
4713 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4714 functor(NVariable,Functor,Arity)
4715 ;
4716 NVariable = Variable
4717 ).
4719 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4720 % ALWAYS FAILING HEADS
4721 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4723 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4724 <=>
4725 chr_pp_flag(check_impossible_rules,on),
4726 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4727 append(M,GuardList,Info),
4728 guard_entailment:entails_guard(Info,fail)
4729 |
4730 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4731 set_all_passive(RuleNb).
4733 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4734 % HEAD SIMPLIFICATION
4735 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4737 % now we check the head matchings (guard may have been simplified meanwhile)
4738 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4739 <=>
4740 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4741 simplify_heads(M,GuardList,G,B,NewM,NewB),
4742 NewM \== [],
4743 extract_arguments(Head1,VH1),
4744 extract_arguments(Head2,VH2),
4745 extract_arguments(H,VH),
4746 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4747 substitute_arguments(Head1,H1,NewH1),
4748 substitute_arguments(Head2,H2,NewH2),
4749 append(NewB,NewB_,NewBody),
4750 list2conj(NewBody,BodyMatchings),
4751 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4752 (Head1 \== NewH1 ; Head2 \== NewH2 )
4753 |
4754 rule(RuleNb,NewRule).
4756 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4757 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4760 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4761 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4762 ( NH == M ->
4763 H2_ = M,
4764 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4765 ;
4766 (M = functor(X,F,A), NH == X ->
4767 length(A_args,A),
4768 (var(H2) ->
4769 NewB1 = [],
4770 H2_ =.. [F|A_args]
4771 ;
4772 H2 =.. [F|OrigArgs],
4773 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4774 H2_ =.. [F|A_args_]
4775 ),
4776 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4777 append(NewB1,NewB2,NewB)
4778 ;
4779 H2_ = H2,
4780 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4781 )
4782 ).
4784 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4785 ( NH == M ->
4786 H1_ = M,
4787 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4788 ;
4789 (M = functor(X,F,A), NH == X ->
4790 length(A_args,A),
4791 (var(H1) ->
4792 NewB1 = [],
4793 H1_ =.. [F|A_args]
4794 ;
4795 H1 =.. [F|OrigArgs],
4796 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4797 H1_ =.. [F|A_args_]
4798 ),
4799 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4800 append(NewB1,NewB2,NewB)
4801 ;
4802 H1_ = H1,
4803 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4804 )
4805 ).
4807 use_same_args([],[],[],_,_,[]).
4808 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4809 var(OA),!,
4810 Out = OA,
4811 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4812 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4813 nonvar(OA),!,
4814 ( common_variables(OA,Body) ->
4815 NewB = [NA = OA|NextB]
4816 ;
4817 NewB = NextB
4818 ),
4819 Out = NA,
4820 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4823 simplify_heads([],_GuardList,_G,_Body,[],[]).
4824 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4825 M = (A = B),
4826 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4827 guard_entailment:entails_guard(GuardList,(A=B)) ->
4828 ( common_variables(B,G-RM-GuardList) ->
4829 NewB = NextB,
4830 NewM = NextM
4831 ;
4832 ( common_variables(B,Body) ->
4833 NewB = [A = B|NextB]
4834 ;
4835 NewB = NextB
4836 ),
4837 NewM = [A|NextM]
4838 )
4839 ;
4840 ( nonvar(B), functor(B,BFu,BAr),
4841 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4842 NewB = NextB,
4843 ( common_variables(B,G-RM-GuardList) ->
4844 NewM = NextM
4845 ;
4846 NewM = [functor(A,BFu,BAr)|NextM]
4847 )
4848 ;
4849 NewM = NextM,
4850 NewB = NextB
4851 )
4852 ),
4853 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4855 common_variables(B,G) :-
4856 term_variables(B,BVars),
4857 term_variables(G,GVars),
4858 intersect_eq(BVars,GVars,L),
4859 L \== [].
4862 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4863 % ALWAYS FAILING GUARDS
4864 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4866 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4867 set_all_passive(_) <=> true.
4869 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4870 ==>
4871 chr_pp_flag(check_impossible_rules,on),
4872 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4873 conj2list(G,GL),
4874 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4875 guard_entailment:entails_guard(GL,fail)
4876 |
4877 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4878 set_all_passive(RuleNb).
4882 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4883 % OCCURRENCE SUBSUMPTION
4884 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4886 :- chr_constraint
4887 first_occ_in_rule/4,
4888 next_occ_in_rule/6.
4890 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4891 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4893 :- chr_constraint multiple_occ_constraints_checked/1.
4894 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4896 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4897 occurrence(C,O,RuleNb,ID,_),
4898 occurrence(C,O2,RuleNb,ID2,_),
4899 rule(RuleNb,Rule)
4900 \
4901 multiple_occ_constraints_checked(Done)
4902 <=>
4903 O < O2,
4904 chr_pp_flag(occurrence_subsumption,on),
4905 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4906 H1 \== [],
4907 \+ memberchk_eq(C,Done)
4908 |
4909 first_occ_in_rule(RuleNb,C,O,ID),
4910 multiple_occ_constraints_checked([C|Done]).
4912 % Find first occurrence of constraint =C= in rule =RuleNb=
4913 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4914 <=>
4915 O < O2
4916 |
4917 first_occ_in_rule(RuleNb,C,O,ID).
4919 first_occ_in_rule(RuleNb,C,O,ID_o1)
4920 <=>
4921 C = F/A,
4922 functor(FreshHead,F,A),
4923 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4925 % Skip passive occurrences.
4926 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4927 <=>
4928 O2 is O+1
4929 |
4930 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4932 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)
4933 <=>
4934 O2 is O+1,
4935 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4936 |
4937 append(H1,H2,Heads),
4938 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4939 ( ExtraCond == [chr_pp_void_info] ->
4940 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4941 ;
4942 append(ExtraCond,Cond,NewCond),
4943 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4944 copy_term(GuardList,FGuardList),
4945 variable_replacement(GuardList,FGuardList,GLRepl),
4946 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4947 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4948 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4949 append(NewCond,GuardList2,BigCond),
4950 append(BigCond,GuardList3,BigCond2),
4951 copy_with_variable_replacement(M,M2,Repl),
4952 copy_with_variable_replacement(M,M3,Repl2),
4953 append(M3,BigCond2,BigCond3),
4954 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4955 list2conj(CheckCond,OccSubsum),
4956 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4957 ( OccSubsum \= chr_pp_void_info ->
4958 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4959 passive(RuleNb,ID_o2)
4960 ;
4961 true
4962 )
4963 ;
4964 true
4965 ),!,
4966 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4967 ).
4970 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4971 <=>
4972 true.
4974 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4975 <=>
4976 true.
4978 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4979 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4980 append(ID2,ID1,IDs),
4981 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4982 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4983 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4984 copy_with_variable_replacement(G,FG,Repl),
4985 extract_explicit_matchings(FG,FG2),
4986 negate_b(FG2,NotFG),
4987 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4988 ( subsumes(FH,FH2) ->
4989 FailCond = [(NotFG;FMPCond)]
4990 ;
4991 % in this case, not much can be done
4992 % e.g. c(f(...)), c(g(...)) <=> ...
4993 FailCond = [chr_pp_void_info]
4994 ).
4996 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4997 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4998 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4999 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5000 Cond = (chr_pp_not_in_store(H);Cond1),
5001 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5003 extract_explicit_matchings((A,B),D) :- !,
5004 ( extract_explicit_matchings(A) ->
5005 extract_explicit_matchings(B,D)
5006 ;
5007 D = (A,E),
5008 extract_explicit_matchings(B,E)
5009 ).
5010 extract_explicit_matchings(A,D) :- !,
5011 ( extract_explicit_matchings(A) ->
5012 D = true
5013 ;
5014 D = A
5015 ).
5017 extract_explicit_matchings(A=B) :-
5018 var(A), var(B), !, A=B.
5019 extract_explicit_matchings(A==B) :-
5020 var(A), var(B), !, A=B.
5022 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5023 % TYPE INFORMATION
5024 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5026 :- chr_constraint
5027 type_definition/2,
5028 type_alias/2,
5029 constraint_type/2,
5030 get_type_definition/2,
5031 get_constraint_type/2.
5034 :- chr_option(mode,type_definition(?,?)).
5035 :- chr_option(mode,get_type_definition(?,?)).
5036 :- chr_option(mode,type_alias(?,?)).
5037 :- chr_option(mode,constraint_type(+,+)).
5038 :- chr_option(mode,get_constraint_type(+,-)).
5040 assert_constraint_type(Constraint,ArgTypes) :-
5041 ( ground(ArgTypes) ->
5042 constraint_type(Constraint,ArgTypes)
5043 ;
5044 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5045 ).
5047 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5048 % Consistency checks of type aliases
5050 type_alias(T,T2) <=>
5051 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5052 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
5053 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5055 type_alias(T1,A1), type_alias(T2,A2) <=>
5056 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
5057 \+ (T1\=T2) |
5058 copy_term_nat(T1,T1_),
5059 copy_term_nat(T2,T2_),
5060 T1_ = T2_,
5061 chr_error(type_error,
5062 '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_]).
5064 type_alias(T,B) \ type_alias(X,T2) <=>
5065 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5066 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
5067 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5068 type_alias(X2,D1).
5070 oneway_unification(X,Y) :-
5071 term_variables(X,XVars),
5072 chr_runtime:lockv(XVars),
5073 X=Y,
5074 chr_runtime:unlockv(XVars).
5076 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5077 % Consistency checks of type definitions
5079 type_definition(T1,_), type_definition(T2,_)
5080 <=>
5081 functor(T1,F,A), functor(T2,F,A)
5082 |
5083 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5085 type_definition(T1,_), type_alias(T2,_)
5086 <=>
5087 functor(T1,F,A), functor(T2,F,A)
5088 |
5089 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5091 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5092 %% get_type_definition(+Type,-Definition) is semidet.
5093 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5095 get_type_definition(T,Def)
5096 <=>
5097 \+ ground(T)
5098 |
5099 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5101 type_alias(T,D) \ get_type_definition(T2,Def)
5102 <=>
5103 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5104 copy_term_nat((T,D),(T1,D1)),T1=T2
5105 |
5106 ( get_type_definition(D1,Def) ->
5107 true
5108 ;
5109 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5110 ).
5112 type_definition(T,D) \ get_type_definition(T2,Def)
5113 <=>
5114 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5115 copy_term_nat((T,D),(T1,D1)),T1=T2
5116 |
5117 Def = D1.
5119 get_type_definition(Type,Def)
5120 <=>
5121 atomic_builtin_type(Type,_,_)
5122 |
5123 Def = [Type].
5125 get_type_definition(Type,Def)
5126 <=>
5127 compound_builtin_type(Type,_,_,_)
5128 |
5129 Def = [Type].
5131 get_type_definition(X,Y) <=> fail.
5133 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5134 %% get_type_definition_det(+Type,-Definition) is det.
5135 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5136 get_type_definition_det(Type,Definition) :-
5137 ( get_type_definition(Type,Definition) ->
5138 true
5139 ;
5140 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5141 ).
5143 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5144 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5145 %
5146 % Return argument types of =ConstraintSymbol=, but fails if none where
5147 % declared.
5148 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5149 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5150 get_constraint_type(_,_) <=> fail.
5152 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5153 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5154 %
5155 % Like =get_constraint_type/2=, but returns list of =any= types when
5156 % no types are declared.
5157 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5158 get_constraint_type_det(ConstraintSymbol,Types) :-
5159 ( get_constraint_type(ConstraintSymbol,Types) ->
5160 true
5161 ;
5162 ConstraintSymbol = _ / N,
5163 replicate(N,any,Types)
5164 ).
5165 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5166 %% unalias_type(+Alias,-Type) is det.
5167 %
5168 % Follows alias chain until base type is reached.
5169 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5170 :- chr_constraint unalias_type/2.
5172 unalias_var @
5173 unalias_type(Alias,BaseType)
5174 <=>
5175 var(Alias)
5176 |
5177 BaseType = Alias.
5179 unalias_alias @
5180 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5181 <=>
5182 nonvar(AliasProtoType),
5183 nonvar(Alias),
5184 functor(AliasProtoType,F,A),
5185 functor(Alias,F,A),
5186 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5187 Alias = AliasInstance
5188 |
5189 unalias_type(Type,BaseType).
5191 unalias_type_definition @
5192 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5193 <=>
5194 nonvar(ProtoType),
5195 nonvar(Alias),
5196 functor(ProtoType,F,A),
5197 functor(Alias,F,A)
5198 |
5199 BaseType = Alias.
5201 unalias_atomic_builtin @
5202 unalias_type(Alias,BaseType)
5203 <=>
5204 atomic_builtin_type(Alias,_,_)
5205 |
5206 BaseType = Alias.
5208 unalias_compound_builtin @
5209 unalias_type(Alias,BaseType)
5210 <=>
5211 compound_builtin_type(Alias,_,_,_)
5212 |
5213 BaseType = Alias.
5215 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5216 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5217 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5218 :- chr_constraint types_modes_condition/3.
5219 :- chr_option(mode,types_modes_condition(+,+,?)).
5220 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5222 types_modes_condition([],[],T) <=> T=true.
5224 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5225 <=>
5226 functor(Head,F,A)
5227 |
5228 Head =.. [_|Args],
5229 Condition = (ModesCondition, TypesCondition, RestCondition),
5230 modes_condition(Modes,Args,ModesCondition),
5231 get_constraint_type_det(F/A,Types),
5232 UnrollHead =.. [_|RealArgs],
5233 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5234 types_modes_condition(Heads,UnrollHeads,RestCondition).
5236 types_modes_condition([Head|_],_,_)
5237 <=>
5238 functor(Head,F,A),
5239 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5242 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5243 %% modes_condition(+Modes,+Args,-Condition) is det.
5244 %
5245 % Return =Condition= on =Args= that checks =Modes=.
5246 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5247 modes_condition([],[],true).
5248 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5249 ( Mode == (+) ->
5250 Condition = ( ground(Arg) , RCondition )
5251 ; Mode == (-) ->
5252 Condition = ( var(Arg) , RCondition )
5253 ;
5254 Condition = RCondition
5255 ),
5256 modes_condition(Modes,Args,RCondition).
5258 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5259 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5260 %
5261 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5262 % =UnrollArgs= controls the depth of type definition unrolling.
5263 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5264 types_condition([],[],[],[],true).
5265 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5266 ( Mode == (-) ->
5267 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5268 ;
5269 get_type_definition_det(Type,Def),
5270 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5271 ( Mode == (+) ->
5272 TypeConditionList = TypeConditionList1
5273 ;
5274 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5275 )
5276 ),
5277 list2disj(TypeConditionList,DisjTypeConditionList),
5278 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5280 type_condition([],_,_,_,[]).
5281 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5282 ( var(DefCase) ->
5283 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5284 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5285 true
5286 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5287 true
5288 ;
5289 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5290 ),
5291 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5293 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5294 :- chr_type atomic_builtin_type ---> any
5295 ; number
5296 ; float
5297 ; int
5298 ; natural
5299 ; dense_int
5300 ; chr_identifier
5301 ; chr_identifier(any)
5302 ; /* all possible values are given */
5303 chr_constants(list(any))
5304 ; /* all possible values appear in rule heads */
5305 chr_constants.
5306 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5308 atomic_builtin_type(any,_Arg,true).
5309 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5310 atomic_builtin_type(int,Arg,integer(Arg)).
5311 atomic_builtin_type(number,Arg,number(Arg)).
5312 atomic_builtin_type(float,Arg,float(Arg)).
5313 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5314 atomic_builtin_type(chr_identifier,_Arg,true).
5315 atomic_builtin_type(chr_constants,_Arg,true).
5317 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5318 compound_builtin_type(chr_constants(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5319 once(( member(Constant,Constants),
5320 unifiable(Arg,Constant,_)
5321 )
5322 )
5323 ).
5325 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5326 ( nonvar(DefCase) ->
5327 functor(DefCase,F,A),
5328 ( A == 0 ->
5329 Condition = (Arg = DefCase)
5330 ; var(UnrollArg) ->
5331 Condition = functor(Arg,F,A)
5332 ; functor(UnrollArg,F,A) ->
5333 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5334 DefCase =.. [_|ArgTypes],
5335 UnrollArg =.. [_|UnrollArgs],
5336 functor(Template,F,A),
5337 Template =.. [_|TemplateArgs],
5338 replicate(A,Mode,ArgModes),
5339 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5340 ;
5341 Condition = functor(Arg,F,A)
5342 )
5343 ;
5344 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5345 ).
5348 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5349 % STATIC TYPE CHECKING
5350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5351 % Checks head constraints and CHR constraint calls in bodies.
5352 %
5353 % TODO:
5354 % - type clashes involving built-in types
5355 % - Prolog built-ins in guard and body
5356 % - indicate position in terms in error messages
5357 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5358 :- chr_constraint
5359 static_type_check/0.
5362 % 1. Check the declared types
5364 constraint_type(Constraint,ArgTypes), static_type_check
5365 ==>
5366 forall(
5367 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5368 ( get_type_definition(Type,_) ->
5369 true
5370 ;
5371 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5372 )
5373 ).
5375 % 2. Check the rules
5377 :- chr_type type_error_src ---> head(any) ; body(any).
5379 rule(_,Rule), static_type_check
5380 ==>
5381 copy_term_nat(Rule,RuleCopy),
5382 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5383 (
5384 catch(
5385 ( static_type_check_heads(Head1),
5386 static_type_check_heads(Head2),
5387 conj2list(Body,GoalList),
5388 static_type_check_body(GoalList)
5389 ),
5390 type_error(Error),
5391 ( Error = invalid_functor(Src,Term,Type) ->
5392 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5393 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5394 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5395 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5396 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5397 )
5398 ),
5399 fail % cleanup constraints
5400 ;
5401 true
5402 ).
5405 static_type_check <=> true.
5407 static_type_check_heads([]).
5408 static_type_check_heads([Head|Heads]) :-
5409 static_type_check_head(Head),
5410 static_type_check_heads(Heads).
5412 static_type_check_head(Head) :-
5413 functor(Head,F,A),
5414 get_constraint_type_det(F/A,Types),
5415 Head =..[_|Args],
5416 maplist(static_type_check_term(head(Head)),Args,Types).
5418 static_type_check_body([]).
5419 static_type_check_body([Goal|Goals]) :-
5420 functor(Goal,F,A),
5421 get_constraint_type_det(F/A,Types),
5422 Goal =..[_|Args],
5423 maplist(static_type_check_term(body(Goal)),Args,Types),
5424 static_type_check_body(Goals).
5426 :- chr_constraint static_type_check_term/3.
5427 :- chr_option(mode,static_type_check_term(?,?,?)).
5428 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5430 static_type_check_term(Src,Term,Type)
5431 <=>
5432 var(Term)
5433 |
5434 static_type_check_var(Src,Term,Type).
5435 static_type_check_term(Src,Term,Type)
5436 <=>
5437 atomic_builtin_type(Type,Term,Goal)
5438 |
5439 ( call(Goal) ->
5440 true
5441 ;
5442 throw(type_error(invalid_functor(Src,Term,Type)))
5443 ).
5444 static_type_check_term(Src,Term,Type)
5445 <=>
5446 compound_builtin_type(Type,Term,_,Goal)
5447 |
5448 ( call(Goal) ->
5449 true
5450 ;
5451 throw(type_error(invalid_functor(Src,Term,Type)))
5452 ).
5453 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5454 <=>
5455 functor(Type,F,A),
5456 functor(AType,F,A)
5457 |
5458 copy_term_nat(AType-ADef,Type-Def),
5459 static_type_check_term(Src,Term,Def).
5461 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5462 <=>
5463 functor(Type,F,A),
5464 functor(AType,F,A)
5465 |
5466 copy_term_nat(AType-ADef,Type-Variants),
5467 functor(Term,TF,TA),
5468 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5469 Term =.. [_|Args],
5470 Variant =.. [_|Types],
5471 maplist(static_type_check_term(Src),Args,Types)
5472 ;
5473 throw(type_error(invalid_functor(Src,Term,Type)))
5474 ).
5476 static_type_check_term(Src,Term,Type)
5477 <=>
5478 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5480 :- chr_constraint static_type_check_var/3.
5481 :- chr_option(mode,static_type_check_var(?,-,?)).
5482 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5484 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5485 <=>
5486 functor(AType,F,A),
5487 functor(Type,F,A)
5488 |
5489 copy_term_nat(AType-ADef,Type-Def),
5490 static_type_check_var(Src,Var,Def).
5492 static_type_check_var(Src,Var,Type)
5493 <=>
5494 atomic_builtin_type(Type,_,_)
5495 |
5496 static_atomic_builtin_type_check_var(Src,Var,Type).
5498 static_type_check_var(Src,Var,Type)
5499 <=>
5500 compound_builtin_type(Type,_,_,_)
5501 |
5502 true.
5505 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5506 <=>
5507 Type1 \== Type2
5508 |
5509 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5511 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5512 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5513 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5514 :- chr_constraint static_atomic_builtin_type_check_var/3.
5515 :- chr_option(mode,static_type_check_var(?,-,+)).
5516 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5518 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5519 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5520 <=>
5521 true.
5522 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5523 <=>
5524 true.
5525 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5526 <=>
5527 true.
5528 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5529 <=>
5530 true.
5531 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5532 <=>
5533 true.
5534 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5535 <=>
5536 true.
5537 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5538 <=>
5539 true.
5540 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5541 <=>
5542 true.
5543 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5544 <=>
5545 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5547 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5548 %% format_src(+type_error_src) is det.
5549 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5550 format_src(head(Head)) :- format('head ~w',[Head]).
5551 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5553 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5554 % Dynamic type checking
5555 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5557 :- chr_constraint
5558 dynamic_type_check/0,
5559 dynamic_type_check_clauses/1,
5560 get_dynamic_type_check_clauses/1.
5562 generate_dynamic_type_check_clauses(Clauses) :-
5563 ( chr_pp_flag(debugable,on) ->
5564 dynamic_type_check,
5565 get_dynamic_type_check_clauses(Clauses0),
5566 append(Clauses0,
5567 [('$dynamic_type_check'(Type,Term) :-
5568 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5569 )],
5570 Clauses)
5571 ;
5572 Clauses = []
5573 ).
5575 type_definition(T,D), dynamic_type_check
5576 ==>
5577 copy_term_nat(T-D,Type-Definition),
5578 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5579 dynamic_type_check_clauses(DynamicChecks).
5580 type_alias(A,B), dynamic_type_check
5581 ==>
5582 copy_term_nat(A-B,Alias-Body),
5583 dynamic_type_check_alias_clause(Alias,Body,Clause),
5584 dynamic_type_check_clauses([Clause]).
5586 dynamic_type_check <=>
5587 findall(
5588 ('$dynamic_type_check'(Type,Term) :- Goal),
5589 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5590 BuiltinChecks
5591 ),
5592 dynamic_type_check_clauses(BuiltinChecks).
5594 dynamic_type_check_clause(T,DC,Clause) :-
5595 copy_term(T-DC,Type-DefinitionClause),
5596 functor(DefinitionClause,F,A),
5597 functor(Term,F,A),
5598 DefinitionClause =.. [_|DCArgs],
5599 Term =.. [_|TermArgs],
5600 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5601 list2conj(RecursiveCallList,RecursiveCalls),
5602 Clause = (
5603 '$dynamic_type_check'(Type,Term) :-
5604 RecursiveCalls
5605 ).
5607 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5608 Clause = (
5609 '$dynamic_type_check'(Alias,Term) :-
5610 '$dynamic_type_check'(Body,Term)
5611 ).
5613 dynamic_type_check_call(Type,Term,Call) :-
5614 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5615 % Call = when(nonvar(Term),Goal)
5616 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5617 % Call = when(nonvar(Term),Goal)
5618 % ;
5619 ( Type == any ->
5620 Call = true
5621 ;
5622 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5623 )
5624 % )
5625 .
5627 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5628 <=>
5629 append(C1,C2,C),
5630 dynamic_type_check_clauses(C).
5632 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5633 <=>
5634 Q = C.
5635 get_dynamic_type_check_clauses(Q)
5636 <=>
5637 Q = [].
5639 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5640 % Atomic Types
5641 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5642 % Some optimizations can be applied for atomic types...
5643 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5645 atomic_types_suspended_constraint(C) :-
5646 C = _/N,
5647 get_constraint_type(C,ArgTypes),
5648 get_constraint_mode(C,ArgModes),
5649 findall(I,between(1,N,I),Indexes),
5650 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5652 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5653 ( is_indexed_argument(C,Index) ->
5654 ( Mode == (?) ->
5655 atomic_type(Type)
5656 ;
5657 true
5658 )
5659 ;
5660 true
5661 ).
5663 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5664 %% atomic_type(+Type) is semidet.
5665 %
5666 % Succeeds when all values of =Type= are atomic.
5667 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5668 :- chr_constraint atomic_type/1.
5670 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5672 type_definition(TypePat,Def) \ atomic_type(Type)
5673 <=>
5674 functor(Type,F,A), functor(TypePat,F,A)
5675 |
5676 forall(member(Term,Def),atomic(Term)).
5678 type_alias(TypePat,Alias) \ atomic_type(Type)
5679 <=>
5680 functor(Type,F,A), functor(TypePat,F,A)
5681 |
5682 atomic(Alias),
5683 copy_term_nat(TypePat-Alias,Type-NType),
5684 atomic_type(NType).
5686 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5687 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5688 %
5689 % Succeeds when all values of =Type= are atomic
5690 % and the atom values are finitely enumerable.
5691 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5692 :- chr_constraint enumerated_atomic_type/2.
5694 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5696 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5697 <=>
5698 functor(Type,F,A), functor(TypePat,F,A)
5699 |
5700 forall(member(Term,Def),atomic(Term)),
5701 Atoms = Def.
5703 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5704 <=>
5705 functor(Type,F,A), functor(TypePat,F,A)
5706 |
5707 atomic(Alias),
5708 copy_term_nat(TypePat-Alias,Type-NType),
5709 enumerated_atomic_type(NType,Atoms).
5710 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5712 :- chr_constraint
5713 stored/3, % constraint,occurrence,(yes/no/maybe)
5714 stored_completing/3,
5715 stored_complete/3,
5716 is_stored/1,
5717 is_finally_stored/1,
5718 check_all_passive/2.
5720 :- chr_option(mode,stored(+,+,+)).
5721 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5722 :- chr_type storedinfo ---> yes ; no ; maybe.
5723 :- chr_option(mode,stored_complete(+,+,+)).
5724 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5725 :- chr_option(mode,guard_list(+,+,+,+)).
5726 :- chr_option(mode,check_all_passive(+,+)).
5727 :- chr_option(type_declaration,check_all_passive(any,list)).
5729 % change yes in maybe when yes becomes passive
5730 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5731 stored(C,O,yes), stored_complete(C,RO,Yesses)
5732 <=> O < RO | NYesses is Yesses - 1,
5733 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5734 % change yes in maybe when not observed
5735 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5736 <=> O < RO |
5737 NYesses is Yesses - 1,
5738 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5740 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5741 ==> RO =< MO2 | % C2 is never stored
5742 passive(RuleNb,ID).
5747 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5749 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5750 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5751 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5753 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5754 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5755 check_all_passive(RuleNb,IDs2).
5757 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5758 check_all_passive(RuleNb,IDs).
5760 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5761 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5763 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5765 % collect the storage information
5766 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5767 <=> NO is O + 1, NYesses is Yesses + 1,
5768 stored_completing(C,NO,NYesses).
5769 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5770 <=> NO is O + 1,
5771 stored_completing(C,NO,Yesses).
5773 stored(C,O,no) \ stored_completing(C,O,Yesses)
5774 <=> stored_complete(C,O,Yesses).
5775 stored_completing(C,O,Yesses)
5776 <=> stored_complete(C,O,Yesses).
5778 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5779 O2 > O | passive(RuleNb,Id).
5781 % decide whether a constraint is stored
5782 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5783 <=> RO =< MO | fail.
5784 is_stored(C) <=> true.
5786 % decide whether a constraint is suspends after occurrences
5787 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5788 <=> RO =< MO | fail.
5789 is_finally_stored(C) <=> true.
5791 storage_analysis(Constraints) :-
5792 ( chr_pp_flag(storage_analysis,on) ->
5793 check_constraint_storages(Constraints)
5794 ;
5795 true
5796 ).
5798 check_constraint_storages([]).
5799 check_constraint_storages([C|Cs]) :-
5800 check_constraint_storage(C),
5801 check_constraint_storages(Cs).
5803 check_constraint_storage(C) :-
5804 get_max_occurrence(C,MO),
5805 check_occurrences_storage(C,1,MO).
5807 check_occurrences_storage(C,O,MO) :-
5808 ( O > MO ->
5809 stored_completing(C,1,0)
5810 ;
5811 check_occurrence_storage(C,O),
5812 NO is O + 1,
5813 check_occurrences_storage(C,NO,MO)
5814 ).
5816 check_occurrence_storage(C,O) :-
5817 get_occurrence(C,O,RuleNb,ID),
5818 ( is_passive(RuleNb,ID) ->
5819 stored(C,O,maybe)
5820 ;
5821 get_rule(RuleNb,PragmaRule),
5822 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5823 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5824 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5825 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5826 check_storage_head2(Head2,O,Heads1,Body)
5827 )
5828 ).
5830 check_storage_head1(Head,O,H1,H2,G) :-
5831 functor(Head,F,A),
5832 C = F/A,
5833 ( H1 == [Head],
5834 H2 == [],
5835 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5836 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5837 Head =.. [_|L],
5838 no_matching(L,[]) ->
5839 stored(C,O,no)
5840 ;
5841 stored(C,O,maybe)
5842 ).
5844 no_matching([],_).
5845 no_matching([X|Xs],Prev) :-
5846 var(X),
5847 \+ memberchk_eq(X,Prev),
5848 no_matching(Xs,[X|Prev]).
5850 check_storage_head2(Head,O,H1,B) :-
5851 functor(Head,F,A),
5852 C = F/A,
5853 ( %(
5854 ( H1 \== [], B == true )
5855 %;
5856 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5857 %)
5858 ->
5859 stored(C,O,maybe)
5860 ;
5861 stored(C,O,yes)
5862 ).
5864 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5866 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5867 %% ____ _ ____ _ _ _ _
5868 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5869 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5870 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5871 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5872 %% |_|
5874 constraints_code(Constraints,Clauses) :-
5875 (chr_pp_flag(reduced_indexing,on),
5876 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5877 none_suspended_on_variables
5878 ;
5879 true
5880 ),
5881 constraints_code1(Constraints,Clauses,[]).
5883 %===============================================================================
5884 :- chr_constraint constraints_code1/3.
5885 :- chr_option(mode,constraints_code1(+,+,+)).
5886 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5887 %-------------------------------------------------------------------------------
5888 constraints_code1([],L,T) <=> L = T.
5889 constraints_code1([C|RCs],L,T)
5890 <=>
5891 constraint_code(C,L,T1),
5892 constraints_code1(RCs,T1,T).
5893 %===============================================================================
5894 :- chr_constraint constraint_code/3.
5895 :- chr_option(mode,constraint_code(+,+,+)).
5896 %-------------------------------------------------------------------------------
5897 %% Generate code for a single CHR constraint
5898 constraint_code(Constraint, L, T)
5899 <=> true
5900 | ( (chr_pp_flag(debugable,on) ;
5901 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5902 ( may_trigger(Constraint) ;
5903 get_allocation_occurrence(Constraint,AO),
5904 get_max_occurrence(Constraint,MO), MO >= AO ) )
5905 ->
5906 constraint_prelude(Constraint,Clause),
5907 add_dummy_location(Clause,LocatedClause),
5908 L = [LocatedClause | L1]
5909 ;
5910 L = L1
5911 ),
5912 Id = [0],
5913 occurrences_code(Constraint,1,Id,NId,L1,L2),
5914 gen_cond_attach_clause(Constraint,NId,L2,T).
5916 %===============================================================================
5917 %% Generate prelude predicate for a constraint.
5918 %% f(...) :- f/a_0(...,Susp).
5919 constraint_prelude(F/A, Clause) :-
5920 vars_susp(A,Vars,Susp,VarsSusp),
5921 Head =.. [ F | Vars],
5922 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5923 build_head(F,A,[0],VarsSusp,Delegate),
5924 ( chr_pp_flag(debugable,on) ->
5925 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5926 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5927 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5928 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5930 ( get_constraint_type(F/A,ArgTypeList) ->
5931 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5932 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5933 ;
5934 DynamicTypeChecks = true
5935 ),
5937 Clause =
5938 ( Head :-
5939 DynamicTypeChecks,
5940 InsertGoal,
5941 InsertCall,
5942 AttachCall,
5943 Inactive,
5944 'chr debug_event'(insert(Head#Susp)),
5945 (
5946 'chr debug_event'(call(Susp)),
5947 Delegate
5948 ;
5949 'chr debug_event'(fail(Susp)), !,
5950 fail
5951 ),
5952 (
5953 'chr debug_event'(exit(Susp))
5954 ;
5955 'chr debug_event'(redo(Susp)),
5956 fail
5957 )
5958 )
5959 ; get_allocation_occurrence(F/A,0) ->
5960 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5961 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5962 Clause = ( Head :- Goal, Inactive, Delegate )
5963 ;
5964 Clause = ( Head :- Delegate )
5965 ).
5967 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5968 ( may_trigger(F/A) ->
5969 build_head(F,A,[0],VarsSusp,Delegate),
5970 ( chr_pp_flag(debugable,off) ->
5971 Goal = Delegate
5972 ;
5973 get_target_module(Mod),
5974 Goal = Mod:Delegate
5975 )
5976 ;
5977 Goal = true
5978 ).
5980 %===============================================================================
5981 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5982 :- chr_option(mode,has_active_occurrence(+)).
5983 :- chr_option(mode,has_active_occurrence(+,+)).
5984 %-------------------------------------------------------------------------------
5985 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5987 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5988 O > MO | fail.
5989 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5990 has_active_occurrence(C,O) <=>
5991 NO is O + 1,
5992 has_active_occurrence(C,NO).
5993 has_active_occurrence(C,O) <=> true.
5994 %===============================================================================
5996 gen_cond_attach_clause(F/A,Id,L,T) :-
5997 ( is_finally_stored(F/A) ->
5998 get_allocation_occurrence(F/A,AllocationOccurrence),
5999 get_max_occurrence(F/A,MaxOccurrence),
6000 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6001 ( only_ground_indexed_arguments(F/A) ->
6002 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6003 ;
6004 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6005 )
6006 ; vars_susp(A,Args,Susp,AllArgs),
6007 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6008 ),
6009 build_head(F,A,Id,AllArgs,Head),
6010 Clause = ( Head :- Body ),
6011 add_dummy_location(Clause,LocatedClause),
6012 L = [LocatedClause | T]
6013 ;
6014 L = T
6015 ).
6017 :- chr_constraint use_auxiliary_predicate/1.
6018 :- chr_option(mode,use_auxiliary_predicate(+)).
6020 :- chr_constraint use_auxiliary_predicate/2.
6021 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6023 :- chr_constraint is_used_auxiliary_predicate/1.
6024 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6026 :- chr_constraint is_used_auxiliary_predicate/2.
6027 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6030 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6032 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6034 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6036 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6038 is_used_auxiliary_predicate(P) <=> fail.
6040 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6041 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6043 is_used_auxiliary_predicate(P,C) <=> fail.
6045 %------------------------------------------------------------------------------%
6046 % Only generate import statements for actually used modules.
6047 %------------------------------------------------------------------------------%
6049 :- chr_constraint use_auxiliary_module/1.
6050 :- chr_option(mode,use_auxiliary_module(+)).
6052 :- chr_constraint is_used_auxiliary_module/1.
6053 :- chr_option(mode,is_used_auxiliary_module(+)).
6056 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6058 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6060 is_used_auxiliary_module(P) <=> fail.
6062 % only called for constraints with
6063 % at least one
6064 % non-ground indexed argument
6065 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6066 vars_susp(A,Args,Susp,AllArgs),
6067 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6068 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6069 Attach = true
6070 ;
6071 attach_constraint_atom(F/A,Vars,Susp,Attach)
6072 ),
6073 FTerm =.. [F|Args],
6074 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6075 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6076 ( may_trigger(F/A) ->
6077 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6078 Goal =
6079 (
6080 ( var(Susp) ->
6081 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6082 InsertCall,
6083 Attach
6084 ;
6085 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6086 )
6087 )
6088 ;
6089 Goal =
6090 (
6091 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6092 InsertCall,
6093 Attach
6094 )
6095 ).
6097 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6098 vars_susp(A,Args,Susp,AllArgs),
6099 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6100 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6101 attach_constraint_atom(F/A,Vars,Susp,Attach)
6102 ;
6103 Attach = true
6104 ),
6105 FTerm =.. [F|Args],
6106 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6107 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6108 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6109 Goal =
6110 (
6111 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6112 InsertCall
6113 )
6114 ;
6115 Goal =
6116 (
6117 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6118 InsertCall,
6119 Attach
6120 )
6121 ).
6123 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6124 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6125 attach_constraint_atom(FA,Vars,Susp,Attach)
6126 ;
6127 Attach = true
6128 ),
6129 insert_constraint_goal(FA,Susp,Args,InsertCall),
6130 ( chr_pp_flag(late_allocation,on) ->
6131 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6132 ;
6133 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6134 ).
6136 %-------------------------------------------------------------------------------
6137 :- chr_constraint occurrences_code/6.
6138 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6139 %-------------------------------------------------------------------------------
6140 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6141 <=> O > MO
6142 | NId = Id, L = T.
6143 occurrences_code(C,O,Id,NId,L,T)
6144 <=>
6145 occurrence_code(C,O,Id,Id1,L,L1),
6146 NO is O + 1,
6147 occurrences_code(C,NO,Id1,NId,L1,T).
6148 %-------------------------------------------------------------------------------
6149 :- chr_constraint occurrence_code/6.
6150 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6151 %-------------------------------------------------------------------------------
6152 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6153 <=>
6154 ( named_history(RuleNb,_,_) ->
6155 does_use_history(C,O)
6156 ;
6157 true
6158 ),
6159 NId = Id,
6160 L = T.
6161 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6162 <=> true |
6163 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6164 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6165 NId = Id,
6166 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6167 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6169 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6170 ( should_skip_to_next_id(C,O) ->
6171 inc_id(Id,NId),
6172 ( unconditional_occurrence(C,O) ->
6173 L1 = T
6174 ;
6175 gen_alloc_inc_clause(C,O,Id,L1,T)
6176 )
6177 ;
6178 NId = Id,
6179 L1 = T
6180 )
6181 ).
6183 occurrence_code(C,O,_,_,_,_)
6184 <=>
6185 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6186 %-------------------------------------------------------------------------------
6188 %% Generate code based on one removed head of a CHR rule
6189 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6190 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6191 Rule = rule(_,Head2,_,_),
6192 ( Head2 == [] ->
6193 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6194 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6195 ;
6196 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6197 ).
6199 %% Generate code based on one persistent head of a CHR rule
6200 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6201 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6202 Rule = rule(Head1,_,_,_),
6203 ( Head1 == [] ->
6204 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6205 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6206 ;
6207 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6208 ).
6210 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6211 vars_susp(A,Vars,Susp,VarsSusp),
6212 build_head(F,A,Id,VarsSusp,Head),
6213 inc_id(Id,IncId),
6214 build_head(F,A,IncId,VarsSusp,CallHead),
6215 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6216 Clause =
6217 (
6218 Head :-
6219 ConditionalAlloc,
6220 CallHead
6221 ),
6222 add_dummy_location(Clause,LocatedClause),
6223 L = [LocatedClause|T].
6225 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6226 get_allocation_occurrence(FA,AO),
6227 get_occurrence_code_id(FA,AO,AId),
6228 get_occurrence_code_id(FA,O,Id),
6229 ( chr_pp_flag(debugable,off), Id == AId ->
6230 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6231 ( may_trigger(FA) ->
6232 Goal = (var(Susp) -> Goal0 ; true)
6233 ;
6234 Goal = Goal0
6235 )
6236 ;
6237 Goal = true
6238 ).
6240 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6241 get_allocation_occurrence(FA,AO),
6242 ( chr_pp_flag(debugable,off), O < AO ->
6243 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6244 ( may_trigger(FA) ->
6245 Goal = (var(Susp) -> Goal0 ; true)
6246 ;
6247 Goal = Goal0
6248 )
6249 ;
6250 Goal = true
6251 ).
6253 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6255 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6256 %
6257 % Reorders guard goals with respect to partner constraint retrieval goals and
6258 % active constraint. Returns combined partner retrieval + guard goal.
6260 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6261 ( chr_pp_flag(guard_via_reschedule,on) ->
6262 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6263 list2conj(ScheduleSkeleton,GoalSkeleton)
6264 ;
6265 length(Retrievals,RL), length(LookupSkeleton,RL),
6266 length(GuardList,GL), length(GuardListSkeleton,GL),
6267 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6268 list2conj(GoalListSkeleton,GoalSkeleton)
6269 ).
6270 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6271 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6272 initialize_unit_dictionary(ActiveHead,Dict),
6273 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6274 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6275 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6276 dependency_reorder(Units,NUnits),
6277 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6278 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6279 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6281 wrap_in_functor(Functor,X,Term) :-
6282 Term =.. [Functor,X].
6284 wrappedunits2lists([],[],[],[]).
6285 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6286 Ss = [GoalCopy|TSs],
6287 ( WrappedGoal = lookup(Goal) ->
6288 Ls = [GoalCopy|TLs],
6289 Gs = TGs
6290 ; WrappedGoal = guard(Goal) ->
6291 Gs = [N-GoalCopy|TGs],
6292 Ls = TLs
6293 ),
6294 wrappedunits2lists(Units,TGs,TLs,TSs).
6296 guard_splitting(Rule,SplitGuardList) :-
6297 Rule = rule(H1,H2,Guard,_),
6298 append(H1,H2,Heads),
6299 conj2list(Guard,GuardList),
6300 term_variables(Heads,HeadVars),
6301 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6302 append(GuardPrefix,[RestGuard],SplitGuardList),
6303 term_variables(RestGuardList,GuardVars1),
6304 % variables that are declared to be ground don't need to be locked
6305 ground_vars(Heads,GroundVars),
6306 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6307 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6308 ( chr_pp_flag(guard_locks,on),
6309 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6310 once(pairup(Locks,Unlocks,LocksUnlocks))
6311 ;
6312 Locks = [],
6313 Unlocks = []
6314 ),
6315 list2conj(Locks,LockPhase),
6316 list2conj(Unlocks,UnlockPhase),
6317 list2conj(RestGuardList,RestGuard1),
6318 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6320 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6321 Rule = rule(_,_,_,Body),
6322 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6323 my_term_copy(Body,VarDict2,BodyCopy).
6326 split_off_simple_guard_new([],_,[],[]).
6327 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6328 ( simple_guard_new(G,VarDict) ->
6329 S = [G|Ss],
6330 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6331 ;
6332 S = [],
6333 C = [G|Gs]
6334 ).
6336 % simple guard: cheap and benign (does not bind variables)
6337 simple_guard_new(G,Vars) :-
6338 builtin_binds_b(G,BoundVars),
6339 \+ (( member(V,BoundVars),
6340 memberchk_eq(V,Vars)
6341 )).
6343 dependency_reorder(Units,NUnits) :-
6344 dependency_reorder(Units,[],NUnits).
6346 dependency_reorder([],Acc,Result) :-
6347 reverse(Acc,Result).
6349 dependency_reorder([Unit|Units],Acc,Result) :-
6350 Unit = unit(_GID,_Goal,Type,GIDs),
6351 ( Type == fixed ->
6352 NAcc = [Unit|Acc]
6353 ;
6354 dependency_insert(Acc,Unit,GIDs,NAcc)
6355 ),
6356 dependency_reorder(Units,NAcc,Result).
6358 dependency_insert([],Unit,_,[Unit]).
6359 dependency_insert([X|Xs],Unit,GIDs,L) :-
6360 X = unit(GID,_,_,_),
6361 ( memberchk(GID,GIDs) ->
6362 L = [Unit,X|Xs]
6363 ;
6364 L = [X | T],
6365 dependency_insert(Xs,Unit,GIDs,T)
6366 ).
6368 build_units(Retrievals,Guard,InitialDict,Units) :-
6369 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6370 build_guard_units(Guard,N,Dict,Tail).
6372 build_retrieval_units([],N,N,Dict,Dict,L,L).
6373 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6374 term_variables(U,Vs),
6375 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6376 L = [unit(N,U,fixed,GIDs)|L1],
6377 N1 is N + 1,
6378 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6380 initialize_unit_dictionary(Term,Dict) :-
6381 term_variables(Term,Vars),
6382 pair_all_with(Vars,0,Dict).
6384 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6385 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6386 ( lookup_eq(Dict,V,GID) ->
6387 ( (GID == This ; memberchk(GID,GIDs) ) ->
6388 GIDs1 = GIDs
6389 ;
6390 GIDs1 = [GID|GIDs]
6391 ),
6392 Dict1 = Dict
6393 ;
6394 Dict1 = [V - This|Dict],
6395 GIDs1 = GIDs
6396 ),
6397 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6399 build_guard_units(Guard,N,Dict,Units) :-
6400 ( Guard = [Goal] ->
6401 Units = [unit(N,Goal,fixed,[])]
6402 ; Guard = [Goal|Goals] ->
6403 term_variables(Goal,Vs),
6404 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6405 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6406 N1 is N + 1,
6407 build_guard_units(Goals,N1,NDict,RUnits)
6408 ).
6410 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6411 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6412 ( lookup_eq(Dict,V,GID) ->
6413 ( (GID == This ; memberchk(GID,GIDs) ) ->
6414 GIDs1 = GIDs
6415 ;
6416 GIDs1 = [GID|GIDs]
6417 ),
6418 Dict1 = [V - This|Dict]
6419 ;
6420 Dict1 = [V - This|Dict],
6421 GIDs1 = GIDs
6422 ),
6423 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6425 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6427 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6428 %% ____ _ ____ _ _
6429 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6430 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6431 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6432 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6433 %%
6434 %% _ _ _ ___ __
6435 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6436 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6437 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6438 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6439 %% |_|
6440 :- chr_constraint
6441 functional_dependency/4,
6442 get_functional_dependency/4.
6444 :- chr_option(mode,functional_dependency(+,+,?,?)).
6445 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6447 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6448 <=>
6449 RuleNb > 1, AO > O
6450 |
6451 functional_dependency(C,1,Pattern,Key).
6453 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6454 <=>
6455 RuleNb2 >= RuleNb1
6456 |
6457 QPattern = Pattern, QKey = Key.
6458 get_functional_dependency(_,_,_,_)
6459 <=>
6460 fail.
6462 functional_dependency_analysis(Rules) :-
6463 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6464 functional_dependency_analysis_main(Rules)
6465 ;
6466 true
6467 ).
6469 functional_dependency_analysis_main([]).
6470 functional_dependency_analysis_main([PRule|PRules]) :-
6471 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6472 functional_dependency(C,RuleNb,Pattern,Key)
6473 ;
6474 true
6475 ),
6476 functional_dependency_analysis_main(PRules).
6478 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6479 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6480 Rule = rule(H1,H2,Guard,_),
6481 ( H1 = [C1],
6482 H2 = [C2] ->
6483 true
6484 ; H1 = [C1,C2],
6485 H2 == [] ->
6486 true
6487 ),
6488 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6489 term_variables(C1,Vs),
6490 \+ (
6491 member(V1,Vs),
6492 lookup_eq(List,V1,V2),
6493 memberchk_eq(V2,Vs)
6494 ),
6495 select_pragma_unique_variables(Vs,List,Key1),
6496 copy_term_nat(C1-Key1,Pattern-Key),
6497 functor(C1,F,A).
6499 select_pragma_unique_variables([],_,[]).
6500 select_pragma_unique_variables([V|Vs],List,L) :-
6501 ( lookup_eq(List,V,_) ->
6502 L = T
6503 ;
6504 L = [V|T]
6505 ),
6506 select_pragma_unique_variables(Vs,List,T).
6508 % depends on functional dependency analysis
6509 % and shape of rule: C1 \ C2 <=> true.
6510 set_semantics_rules(Rules) :-
6511 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6512 set_semantics_rules_main(Rules)
6513 ;
6514 true
6515 ).
6517 set_semantics_rules_main([]).
6518 set_semantics_rules_main([R|Rs]) :-
6519 set_semantics_rule_main(R),
6520 set_semantics_rules_main(Rs).
6522 set_semantics_rule_main(PragmaRule) :-
6523 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6524 ( Rule = rule([C1],[C2],true,_),
6525 IDs = ids([ID1],[ID2]),
6526 \+ is_passive(RuleNb,ID1),
6527 functor(C1,F,A),
6528 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6529 copy_term_nat(Pattern-Key,C1-Key1),
6530 copy_term_nat(Pattern-Key,C2-Key2),
6531 Key1 == Key2 ->
6532 passive(RuleNb,ID2)
6533 ;
6534 true
6535 ).
6537 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6538 \+ any_passive_head(RuleNb),
6539 variable_replacement(C1-C2,C2-C1,List),
6540 copy_with_variable_replacement(G,OtherG,List),
6541 negate_b(G,NotG),
6542 once(entails_b(NotG,OtherG)).
6544 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6545 % where C1 and C2 are symmteric constraints
6546 symmetry_analysis(Rules) :-
6547 ( chr_pp_flag(check_unnecessary_active,off) ->
6548 true
6549 ;
6550 symmetry_analysis_main(Rules)
6551 ).
6553 symmetry_analysis_main([]).
6554 symmetry_analysis_main([R|Rs]) :-
6555 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6556 Rule = rule(H1,H2,_,_),
6557 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6558 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6559 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6560 ;
6561 true
6562 ),
6563 symmetry_analysis_main(Rs).
6565 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6566 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6567 ( \+ is_passive(RuleNb,ID),
6568 member2(PreHs,PreIDs,PreH-PreID),
6569 \+ is_passive(RuleNb,PreID),
6570 variable_replacement(PreH,H,List),
6571 copy_with_variable_replacement(Rule,Rule2,List),
6572 identical_guarded_rules(Rule,Rule2) ->
6573 passive(RuleNb,ID)
6574 ;
6575 true
6576 ),
6577 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6579 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6580 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6581 ( \+ is_passive(RuleNb,ID),
6582 member2(PreHs,PreIDs,PreH-PreID),
6583 \+ is_passive(RuleNb,PreID),
6584 variable_replacement(PreH,H,List),
6585 copy_with_variable_replacement(Rule,Rule2,List),
6586 identical_rules(Rule,Rule2) ->
6587 passive(RuleNb,ID)
6588 ;
6589 true
6590 ),
6591 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6593 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6595 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6596 %% ____ _ _ _ __ _ _ _
6597 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6598 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6599 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6600 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6601 %% |_|
6603 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6604 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6605 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6606 build_head(F,A,Id,HeadVars,ClauseHead),
6607 get_constraint_mode(F/A,Mode),
6608 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6611 guard_splitting(Rule,GuardList0),
6612 ( is_stored_in_guard(F/A, RuleNb) ->
6613 GuardList = [Hole1|GuardList0]
6614 ;
6615 GuardList = GuardList0
6616 ),
6617 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6619 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6621 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6623 ( is_stored_in_guard(F/A, RuleNb) ->
6624 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6625 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6626 GuardCopyList = [Hole1Copy|_],
6627 Hole1Copy = (Allocation, Attachment)
6628 ;
6629 true
6630 ),
6633 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6634 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6636 ( chr_pp_flag(debugable,on) ->
6637 Rule = rule(_,_,Guard,Body),
6638 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6639 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6640 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6641 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6642 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6643 ;
6644 Cut = ActualCut
6645 ),
6646 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6647 Clause = ( ClauseHead :-
6648 FirstMatching,
6649 RescheduledTest,
6650 Cut,
6651 SuspsDetachments,
6652 SuspDetachment,
6653 BodyCopy
6654 ),
6655 add_location(Clause,RuleNb,LocatedClause),
6656 L = [LocatedClause | T].
6658 add_location(Clause,RuleNb,NClause) :-
6659 ( chr_pp_flag(line_numbers,on) ->
6660 get_chr_source_file(File),
6661 get_line_number(RuleNb,LineNb),
6662 NClause = '$source_location'(File,LineNb):Clause
6663 ;
6664 NClause = Clause
6665 ).
6667 add_dummy_location(Clause,NClause) :-
6668 ( chr_pp_flag(line_numbers,on) ->
6669 get_chr_source_file(File),
6670 NClause = '$source_location'(File,1):Clause
6671 ;
6672 NClause = Clause
6673 ).
6674 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6675 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6676 %
6677 % Return goal matching newly introduced variables with variables in
6678 % previously looked-up heads.
6679 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6680 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6681 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6683 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6684 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6685 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6686 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6687 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6688 list2conj(GoalList,Goal).
6690 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6691 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6692 ( var(Arg) ->
6693 ( lookup_eq(VarDict,Arg,OtherVar) ->
6694 ( Mode = (+) ->
6695 ( memberchk_eq(Arg,GroundVars) ->
6696 GoalList = [Var = OtherVar | RestGoalList],
6697 GroundVars1 = GroundVars
6698 ;
6699 GoalList = [Var == OtherVar | RestGoalList],
6700 GroundVars1 = [Arg|GroundVars]
6701 )
6702 ;
6703 GoalList = [Var == OtherVar | RestGoalList],
6704 GroundVars1 = GroundVars
6705 ),
6706 VarDict1 = VarDict
6707 ;
6708 VarDict1 = [Arg-Var | VarDict],
6709 GoalList = RestGoalList,
6710 ( Mode = (+) ->
6711 GroundVars1 = [Arg|GroundVars]
6712 ;
6713 GroundVars1 = GroundVars
6714 )
6715 ),
6716 Pairs = Rest,
6717 RestModes = Modes
6718 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6719 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6720 GoalList = [Goal|RestGoalList],
6721 VarDict = VarDict1,
6722 GroundVars1 = GroundVars,
6723 Pairs = Rest,
6724 RestModes = Modes
6725 ; atomic(Arg) ->
6726 ( Mode = (+) ->
6727 GoalList = [ Var = Arg | RestGoalList]
6728 ;
6729 GoalList = [ Var == Arg | RestGoalList]
6730 ),
6731 VarDict = VarDict1,
6732 GroundVars1 = GroundVars,
6733 Pairs = Rest,
6734 RestModes = Modes
6735 ; Mode == (+), is_ground(GroundVars,Arg) ->
6736 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6737 GoalList = [ Var = ArgCopy | RestGoalList],
6738 VarDict = VarDict1,
6739 GroundVars1 = GroundVars,
6740 Pairs = Rest,
6741 RestModes = Modes
6742 ; Mode == (?), is_ground(GroundVars,Arg) ->
6743 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6744 GoalList = [ Var == ArgCopy | RestGoalList],
6745 VarDict = VarDict1,
6746 GroundVars1 = GroundVars,
6747 Pairs = Rest,
6748 RestModes = Modes
6749 ; Arg =.. [_|Args],
6750 functor(Arg,Fct,N),
6751 functor(Term,Fct,N),
6752 Term =.. [_|Vars],
6753 ( Mode = (+) ->
6754 GoalList = [ Var = Term | RestGoalList ]
6755 ;
6756 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6757 ),
6758 pairup(Args,Vars,NewPairs),
6759 append(NewPairs,Rest,Pairs),
6760 replicate(N,Mode,NewModes),
6761 append(NewModes,Modes,RestModes),
6762 VarDict1 = VarDict,
6763 GroundVars1 = GroundVars
6764 ),
6765 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6767 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6768 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6769 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6770 add_heads_types([],VarTypes,VarTypes).
6771 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6772 add_head_types(Head,VarTypes,VarTypes1),
6773 add_heads_types(Heads,VarTypes1,NVarTypes).
6775 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6776 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6777 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6778 add_head_types(Head,VarTypes,NVarTypes) :-
6779 functor(Head,F,A),
6780 get_constraint_type_det(F/A,ArgTypes),
6781 Head =.. [_|Args],
6782 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6784 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6785 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6786 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6787 add_args_types([],[],VarTypes,VarTypes).
6788 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6789 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6790 add_args_types(Args,Types,VarTypes1,NVarTypes).
6792 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6793 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6794 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6795 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6796 ( var(Term) ->
6797 ( lookup_eq(VarTypes,Term,_) ->
6798 NVarTypes = VarTypes
6799 ;
6800 NVarTypes = [Term-Type|VarTypes]
6801 )
6802 ; ground(Term) ->
6803 NVarTypes = VarTypes
6804 ; % TODO improve approximation!
6805 term_variables(Term,Vars),
6806 length(Vars,VarNb),
6807 replicate(VarNb,any,Types),
6808 add_args_types(Vars,Types,VarTypes,NVarTypes)
6809 ).
6813 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6814 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6815 %
6816 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6817 add_heads_ground_variables([],GroundVars,GroundVars).
6818 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6819 add_head_ground_variables(Head,GroundVars,GroundVars1),
6820 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6822 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6823 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6824 %
6825 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6826 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6827 functor(Head,F,A),
6828 get_constraint_mode(F/A,ArgModes),
6829 Head =.. [_|Args],
6830 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6833 add_arg_ground_variables([],[],GroundVars,GroundVars).
6834 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6835 ( Mode == (+) ->
6836 term_variables(Arg,Vars),
6837 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6838 ;
6839 GroundVars = GroundVars1
6840 ),
6841 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6843 add_var_ground_variables([],GroundVars,GroundVars).
6844 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6845 ( memberchk_eq(Var,GroundVars) ->
6846 GroundVars1 = GroundVars
6847 ;
6848 GroundVars1 = [Var|GroundVars]
6849 ),
6850 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6851 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6852 %% is_ground(+GroundVars,+Term) is semidet.
6853 %
6854 % Determine whether =Term= is always ground.
6855 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6856 is_ground(GroundVars,Term) :-
6857 ( ground(Term) ->
6858 true
6859 ; compound(Term) ->
6860 Term =.. [_|Args],
6861 maplist(is_ground(GroundVars),Args)
6862 ;
6863 memberchk_eq(Term,GroundVars)
6864 ).
6866 %% check_ground(+GroundVars,+Term,-Goal) is det.
6867 %
6868 % Return runtime check to see whether =Term= is ground.
6869 check_ground(GroundVars,Term,Goal) :-
6870 term_variables(Term,Variables),
6871 check_ground_variables(Variables,GroundVars,Goal).
6873 check_ground_variables([],_,true).
6874 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6875 ( memberchk_eq(Var,GroundVars) ->
6876 check_ground_variables(Vars,GroundVars,Goal)
6877 ;
6878 Goal = (ground(Var), RGoal),
6879 check_ground_variables(Vars,GroundVars,RGoal)
6880 ).
6882 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6883 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6885 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6886 ( Heads = [_|_] ->
6887 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6888 ;
6889 GoalList = [],
6890 Susps = [],
6891 VarDict = NVarDict,
6892 GroundVars = NGroundVars
6893 ).
6895 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6896 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6897 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6898 functor(H,F,A),
6899 head_info(H,A,Vars,_,_,Pairs),
6900 get_store_type(F/A,StoreType),
6901 ( StoreType == default ->
6902 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6903 delay_phase_end(validate_store_type_assumptions,
6904 ( static_suspension_term(F/A,Suspension),
6905 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6906 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6907 )
6908 ),
6909 % create_get_mutable_ref(active,State,GetMutable),
6910 get_constraint_mode(F/A,Mode),
6911 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6912 NPairs = Pairs,
6913 sbag_member_call(Susp,VarSusps,Sbag),
6914 ExistentialLookup = (
6915 ViaGoal,
6916 Sbag,
6917 Susp = Suspension, % not inlined
6918 GetState
6919 )
6920 ;
6921 delay_phase_end(validate_store_type_assumptions,
6922 ( static_suspension_term(F/A,Suspension),
6923 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6924 )
6925 ),
6926 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6927 get_constraint_mode(F/A,Mode),
6928 filter_mode(NPairs,Pairs,Mode,NMode),
6929 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6930 ),
6931 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6932 append(NPairs,VarDict1,DA_), % order important here
6933 translate(GroundVars1,DA_,GroundVarsA),
6934 translate(GroundVars1,VarDict1,GroundVarsB),
6935 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6936 Goal =
6937 (
6938 ExistentialLookup,
6939 DiffSuspGoals,
6940 MatchingGoal2
6941 ),
6942 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6944 inline_matching_goal(A==B,true,GVA,GVB) :-
6945 memberchk_eq(A,GVA),
6946 memberchk_eq(B,GVB),
6947 A=B, !.
6949 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6950 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6951 inline_matching_goal(A,A2,GVA,GVB),
6952 inline_matching_goal(B,B2,GVA,GVB).
6953 inline_matching_goal(X,X,_,_).
6956 filter_mode([],_,_,[]).
6957 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6958 ( Var == V ->
6959 Modes = [M|MT],
6960 filter_mode(Rest,R,Ms,MT)
6961 ;
6962 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6963 ).
6965 check_unique_keys([],_).
6966 check_unique_keys([V|Vs],Dict) :-
6967 lookup_eq(Dict,V,_),
6968 check_unique_keys(Vs,Dict).
6970 % Generates tests to ensure the found constraint differs from previously found constraints
6971 % TODO: detect more cases where constraints need be different
6972 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6973 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6974 list2conj(DiffSuspGoalList,DiffSuspGoals).
6976 different_from_other_susps_(_,[],_,_,[]) :- !.
6977 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6978 ( functor(Head,F,A), functor(PreHead,F,A),
6979 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6980 \+ \+ PreHeadCopy = HeadCopy ->
6982 List = [Susp \== PreSusp | Tail]
6983 ;
6984 List = Tail
6985 ),
6986 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6988 % passive_head_via(in,in,in,in,out,out,out) :-
6989 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6990 functor(Head,F,A),
6991 get_constraint_index(F/A,Pos),
6992 common_variables(Head,PrevHeads,CommonVars),
6993 global_list_store_name(F/A,Name),
6994 GlobalGoal = nb_getval(Name,AllSusps),
6995 get_constraint_mode(F/A,ArgModes),
6996 ( Vars == [] ->
6997 Goal = GlobalGoal
6998 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6999 translate([CommonVar],VarDict,[Var]),
7000 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7001 Goal = AttrGoal
7002 ;
7003 translate(CommonVars,VarDict,Vars),
7004 add_heads_types(PrevHeads,[],TypeDict),
7005 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7006 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7007 Goal =
7008 ( ViaGoal ->
7009 AttrGoal
7010 ;
7011 GlobalGoal
7012 )
7013 ).
7015 common_variables(T,Ts,Vs) :-
7016 term_variables(T,V1),
7017 term_variables(Ts,V2),
7018 intersect_eq(V1,V2,Vs).
7020 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7021 get_target_module(Mod),
7022 ( Vars = [A] ->
7023 lookup_eq(TypeDict,A,Type),
7024 ( atomic_type(Type) ->
7025 ViaGoal = var(A),
7026 A = V
7027 ;
7028 ViaGoal = 'chr newvia_1'(A,V)
7029 )
7030 ; Vars = [A,B] ->
7031 ViaGoal = 'chr newvia_2'(A,B,V)
7032 ;
7033 ViaGoal = 'chr newvia'(Vars,V)
7034 ),
7035 AttrGoal =
7036 ( get_attr(V,Mod,TSusps),
7037 TSuspsEqSusps % TSusps = Susps
7038 ),
7039 get_max_constraint_index(N),
7040 ( N == 1 ->
7041 TSuspsEqSusps = true, % TSusps = Susps
7042 AllSusps = TSusps
7043 ;
7044 get_constraint_index(FA,Pos),
7045 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7046 ).
7047 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7048 get_target_module(Mod),
7049 AttrGoal =
7050 ( get_attr(Var,Mod,TSusps),
7051 TSuspsEqSusps % TSusps = Susps
7052 ),
7053 get_max_constraint_index(N),
7054 ( N == 1 ->
7055 TSuspsEqSusps = true, % TSusps = Susps
7056 AllSusps = TSusps
7057 ;
7058 get_constraint_index(FA,Pos),
7059 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7060 ).
7062 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7063 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7064 list2conj(GuardCopyList,GuardCopy).
7066 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7067 Rule = rule(_,H,Guard,Body),
7068 conj2list(Guard,GuardList),
7069 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7070 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7072 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7073 term_variables(RestGuardList,GuardVars),
7074 term_variables(RestGuardListCopyCore,GuardCopyVars),
7075 % variables that are declared to be ground don't need to be locked
7076 ground_vars(H,GroundVars),
7077 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7078 ( chr_pp_flag(guard_locks,on),
7079 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7080 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7081 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7082 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7083 ),
7084 LocksUnlocks) ->
7085 once(pairup(Locks,Unlocks,LocksUnlocks))
7086 ;
7087 Locks = [],
7088 Unlocks = []
7089 ),
7090 list2conj(Locks,LockPhase),
7091 list2conj(Unlocks,UnlockPhase),
7092 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7093 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7094 my_term_copy(Body,VarDict2,BodyCopy).
7097 split_off_simple_guard([],_,[],[]).
7098 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7099 ( simple_guard(G,VarDict) ->
7100 S = [G|Ss],
7101 split_off_simple_guard(Gs,VarDict,Ss,C)
7102 ;
7103 S = [],
7104 C = [G|Gs]
7105 ).
7107 % simple guard: cheap and benign (does not bind variables)
7108 simple_guard(G,VarDict) :-
7109 binds_b(G,Vars),
7110 \+ (( member(V,Vars),
7111 lookup_eq(VarDict,V,_)
7112 )).
7114 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7115 functor(Head,F,A),
7116 C = F/A,
7117 ( is_stored(C) ->
7118 (
7119 (
7120 Id == [0], chr_pp_flag(store_in_guards, off)
7121 ;
7122 ( get_allocation_occurrence(C,AO),
7123 get_max_occurrence(C,MO),
7124 MO < AO )
7125 ),
7126 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7127 SuspDetachment = true
7128 ;
7129 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7130 ( chr_pp_flag(late_allocation,on) ->
7131 SuspDetachment =
7132 ( var(Susp) ->
7133 true
7134 ;
7135 UnCondSuspDetachment
7136 )
7137 ;
7138 SuspDetachment = UnCondSuspDetachment
7139 )
7140 )
7141 ;
7142 SuspDetachment = true
7143 ).
7145 partner_constraint_detachments([],[],_,true).
7146 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7147 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7148 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7150 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7151 functor(Head,F,A),
7152 C = F/A,
7153 ( is_stored(C) ->
7154 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7155 ( chr_pp_flag(debugable,on) ->
7156 DebugEvent = 'chr debug_event'(remove(Susp))
7157 ;
7158 DebugEvent = true
7159 ),
7160 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7161 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7162 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7163 detach_constraint_atom(C,Vars,Susp,Detach)
7164 ;
7165 Detach = true
7166 )
7167 ;
7168 SuspDetachment = true
7169 ).
7171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7173 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7174 %% ____ _ _ _ _
7175 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7176 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7177 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7178 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7179 %% |_| |___/
7181 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7182 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7183 Rule = rule(_Heads,Heads2,Guard,Body),
7185 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7186 get_constraint_mode(F/A,Mode),
7187 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7189 build_head(F,A,Id,HeadVars,ClauseHead),
7191 append(RestHeads,Heads2,Heads),
7192 append(OtherIDs,Heads2IDs,IDs),
7193 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7195 guard_splitting(Rule,GuardList0),
7196 ( is_stored_in_guard(F/A, RuleNb) ->
7197 GuardList = [Hole1|GuardList0]
7198 ;
7199 GuardList = GuardList0
7200 ),
7201 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7203 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7204 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7206 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7208 ( is_stored_in_guard(F/A, RuleNb) ->
7209 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7210 GuardCopyList = [Hole1Copy|_],
7211 Hole1Copy = Attachment
7212 ;
7213 true
7214 ),
7216 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7217 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7218 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7220 ( chr_pp_flag(debugable,on) ->
7221 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7222 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7223 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7224 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7225 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7226 instrument_goal((!),DebugTry,DebugApply,Cut)
7227 ;
7228 Cut = (!)
7229 ),
7231 Clause = ( ClauseHead :-
7232 FirstMatching,
7233 RescheduledTest,
7234 Cut,
7235 SuspsDetachments,
7236 SuspDetachment,
7237 BodyCopy
7238 ),
7239 add_location(Clause,RuleNb,LocatedClause),
7240 L = [LocatedClause | T].
7242 split_by_ids([],[],_,[],[]).
7243 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7244 ( memberchk_eq(I,I1s) ->
7245 S1s = [S | R1s],
7246 S2s = R2s
7247 ;
7248 S1s = R1s,
7249 S2s = [S | R2s]
7250 ),
7251 split_by_ids(Is,Ss,I1s,R1s,R2s).
7253 split_by_ids([],[],_,[],[],[],[]).
7254 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7255 ( memberchk_eq(I,I1s) ->
7256 S1s = [S | R1s],
7257 SI1s = [I|RSI1s],
7258 S2s = R2s,
7259 SI2s = RSI2s
7260 ;
7261 S1s = R1s,
7262 SI1s = RSI1s,
7263 S2s = [S | R2s],
7264 SI2s = [I|RSI2s]
7265 ),
7266 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7267 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7270 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7271 %% ____ _ _ _ ____
7272 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7273 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7274 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7275 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7276 %% |_| |___/
7278 %% Genereate prelude + worker predicate
7279 %% prelude calls worker
7280 %% worker iterates over one type of removed constraints
7281 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7282 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7283 Rule = rule(Heads1,_,Guard,Body),
7284 append(Heads1,RestHeads2,Heads),
7285 append(IDs1,RestIDs,IDs),
7286 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7287 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7288 extend_id(Id,Id1),
7289 ( memberchk_eq(NID,IDs2) ->
7290 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7291 ;
7292 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7293 ),
7294 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7295 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7297 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7298 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7299 Heads = [Head|RHeads],
7300 inc_id(Id,Id1),
7301 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7302 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7303 ( memberchk_eq(ID,IDs2) ->
7304 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7305 ;
7306 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7307 ).
7309 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7310 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7311 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7312 build_head(F,A,Id1,VarsSusp,ClauseHead),
7313 get_constraint_mode(F/A,Mode),
7314 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7316 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7318 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7320 extend_id(Id1,DelegateId),
7321 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7322 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7323 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7325 PreludeClause =
7326 ( ClauseHead :-
7327 FirstMatching,
7328 ModConstraintsGoal,
7329 !,
7330 ConstraintAllocationGoal,
7331 Delegate
7332 ),
7333 add_dummy_location(PreludeClause,LocatedPreludeClause),
7334 L = [LocatedPreludeClause|T].
7336 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7337 Term =.. [_|Args],
7338 delegate_variables(Term,Terms,VarDict,Args,Vars).
7340 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7341 term_variables(PrevTerms,PrevVars),
7342 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7344 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7345 term_variables(Term,V1),
7346 term_variables(Terms,V2),
7347 intersect_eq(V1,V2,V3),
7348 list_difference_eq(V3,PrevVars,V4),
7349 translate(V4,VarDict,Vars).
7352 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7353 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7354 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7355 Rule = rule(_,_,Guard,Body),
7356 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7358 gen_var(OtherSusp),
7359 gen_var(OtherSusps),
7361 functor(CurrentHead,OtherF,OtherA),
7362 gen_vars(OtherA,OtherVars),
7363 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7364 get_constraint_mode(OtherF/OtherA,Mode),
7365 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7367 delay_phase_end(validate_store_type_assumptions,
7368 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7369 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7370 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7371 )
7372 ),
7373 % create_get_mutable_ref(active,State,GetMutable),
7374 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7375 CurrentSuspTest = (
7376 OtherSusp = OtherSuspension,
7377 GetState,
7378 DiffSuspGoals,
7379 FirstMatching
7380 ),
7382 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7383 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7385 guard_splitting(Rule,GuardList0),
7386 ( is_stored_in_guard(F/A, RuleNb) ->
7387 GuardList = [Hole1|GuardList0]
7388 ;
7389 GuardList = GuardList0
7390 ),
7391 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7393 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7394 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7395 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7397 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7399 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7400 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7401 RecursiveVars2 = [[]|PreVarsAndSusps],
7402 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7404 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7405 ( is_stored_in_guard(F/A, RuleNb) ->
7406 GuardCopyList = [GuardAttachment|_] % once( ) ??
7407 ;
7408 true
7409 ),
7411 ( is_observed(F/A,O) ->
7412 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7413 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7414 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7415 ;
7416 Attachment = true,
7417 ConditionalRecursiveCall = RecursiveCall,
7418 ConditionalRecursiveCall2 = RecursiveCall2
7419 ),
7421 ( chr_pp_flag(debugable,on) ->
7422 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7423 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7424 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7425 ;
7426 DebugTry = true,
7427 DebugApply = true
7428 ),
7430 ( is_stored_in_guard(F/A, RuleNb) ->
7431 GuardAttachment = Attachment,
7432 BodyAttachment = true
7433 ;
7434 GuardAttachment = true,
7435 BodyAttachment = Attachment % will be true if not observed at all
7436 ),
7438 ( member(unique(ID1,UniqueKeys), Pragmas),
7439 check_unique_keys(UniqueKeys,VarDict) ->
7440 Clause =
7441 ( ClauseHead :-
7442 ( CurrentSuspTest ->
7443 ( RescheduledTest,
7444 DebugTry ->
7445 DebugApply,
7446 Susps1Detachments,
7447 BodyAttachment,
7448 BodyCopy,
7449 ConditionalRecursiveCall2
7450 ;
7451 RecursiveCall2
7452 )
7453 ;
7454 RecursiveCall
7455 )
7456 )
7457 ;
7458 Clause =
7459 ( ClauseHead :-
7460 ( CurrentSuspTest,
7461 RescheduledTest,
7462 DebugTry ->
7463 DebugApply,
7464 Susps1Detachments,
7465 BodyAttachment,
7466 BodyCopy,
7467 ConditionalRecursiveCall
7468 ;
7469 RecursiveCall
7470 )
7471 )
7472 ),
7473 add_location(Clause,RuleNb,LocatedClause),
7474 L = [LocatedClause | T].
7476 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7477 ( may_trigger(FA) ->
7478 does_use_field(FA,generation),
7479 delay_phase_end(validate_store_type_assumptions,
7480 ( static_suspension_term(FA,Suspension),
7481 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7482 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7483 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7484 )
7485 )
7486 ;
7487 delay_phase_end(validate_store_type_assumptions,
7488 ( static_suspension_term(FA,Suspension),
7489 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7490 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7491 )
7492 ),
7493 GetGeneration = true
7494 ),
7495 ConditionalCall =
7496 ( Susp = Suspension,
7497 GetState,
7498 GetGeneration ->
7499 UpdateState,
7500 Call
7501 ;
7502 true
7503 ).
7505 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7508 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7509 %% ____ _ _
7510 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7511 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7512 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7513 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7514 %% |_| |___/
7516 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7517 ( RestHeads == [] ->
7518 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7519 ;
7520 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7521 ).
7522 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7523 %% Single headed propagation
7524 %% everything in a single clause
7525 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7526 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7527 build_head(F,A,Id,VarsSusp,ClauseHead),
7529 inc_id(Id,NextId),
7530 build_head(F,A,NextId,VarsSusp,NextHead),
7532 get_constraint_mode(F/A,Mode),
7533 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7534 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7536 % - recursive call -
7537 RecursiveCall = NextHead,
7539 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7540 ActualCut = true
7541 ;
7542 ActualCut = !
7543 ),
7545 Rule = rule(_,_,Guard,Body),
7546 ( chr_pp_flag(debugable,on) ->
7547 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7548 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7549 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7550 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7551 ;
7552 Cut = ActualCut
7553 ),
7554 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7555 use_auxiliary_predicate(novel_production),
7556 use_auxiliary_predicate(extend_history),
7557 does_use_history(F/A,O),
7558 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7560 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7561 ( HistoryIDs == [] ->
7562 empty_named_history_novel_production(HistoryName,NovelProduction),
7563 empty_named_history_extend_history(HistoryName,ExtendHistory)
7564 ;
7565 Tuple = HistoryName
7566 )
7567 ;
7568 Tuple = RuleNb
7569 ),
7571 ( var(NovelProduction) ->
7572 NovelProduction = '$novel_production'(Susp,Tuple),
7573 ExtendHistory = '$extend_history'(Susp,Tuple)
7574 ;
7575 true
7576 ),
7578 ( is_observed(F/A,O) ->
7579 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7580 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7581 ;
7582 Attachment = true,
7583 ConditionalRecursiveCall = RecursiveCall
7584 )
7585 ;
7586 Allocation = true,
7587 NovelProduction = true,
7588 ExtendHistory = true,
7590 ( is_observed(F/A,O) ->
7591 get_allocation_occurrence(F/A,AllocO),
7592 ( O == AllocO ->
7593 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7594 Generation = 0
7595 ; % more room for improvement?
7596 Attachment = (Attachment1, Attachment2),
7597 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7598 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7599 ),
7600 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7601 ;
7602 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7603 ConditionalRecursiveCall = RecursiveCall
7604 )
7605 ),
7607 ( is_stored_in_guard(F/A, RuleNb) ->
7608 GuardAttachment = Attachment,
7609 BodyAttachment = true
7610 ;
7611 GuardAttachment = true,
7612 BodyAttachment = Attachment % will be true if not observed at all
7613 ),
7615 Clause = (
7616 ClauseHead :-
7617 HeadMatching,
7618 Allocation,
7619 NovelProduction,
7620 GuardAttachment,
7621 GuardCopy,
7622 Cut,
7623 ExtendHistory,
7624 BodyAttachment,
7625 BodyCopy,
7626 ConditionalRecursiveCall
7627 ),
7628 add_location(Clause,RuleNb,LocatedClause),
7629 ProgramList = [LocatedClause | ProgramTail].
7631 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7632 %% multi headed propagation
7633 %% prelude + predicates to accumulate the necessary combinations of suspended
7634 %% constraints + predicate to execute the body
7635 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7636 RestHeads = [First|Rest],
7637 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7638 extend_id(Id,ExtendedId),
7639 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7641 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7642 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7643 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7644 build_head(F,A,Id,VarsSusp,PreludeHead),
7645 get_constraint_mode(F/A,Mode),
7646 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7647 Rule = rule(_,_,Guard,Body),
7648 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7650 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7652 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7654 extend_id(Id,NestedId),
7655 append([Susps|VarsSusp],ExtraVars,NestedVars),
7656 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7657 NestedCall = NestedHead,
7659 Prelude = (
7660 PreludeHead :-
7661 FirstMatching,
7662 FirstSuspGoal,
7663 !,
7664 CondAllocation,
7665 NestedCall
7666 ),
7667 add_dummy_location(Prelude,LocatedPrelude),
7668 L = [LocatedPrelude|T].
7670 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7671 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7672 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7673 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7675 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7676 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7677 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7678 inc_id(Id,IncId),
7679 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7681 %check_fd_lookup_condition(_,_,_,_) :- fail.
7682 check_fd_lookup_condition(F,A,_,_) :-
7683 get_store_type(F/A,global_singleton), !.
7684 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7685 \+ may_trigger(F/A),
7686 get_functional_dependency(F/A,1,P,K),
7687 copy_term(P-K,CurrentHead-Key),
7688 term_variables(PreHeads,PreVars),
7689 intersect_eq(Key,PreVars,Key),!.
7691 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7692 Rule = rule(_,H2,Guard,Body),
7693 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7694 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7695 init(AllSusps,RestSusps),
7696 last(AllSusps,Susp),
7697 gen_var(OtherSusp),
7698 gen_var(OtherSusps),
7699 functor(CurrentHead,OtherF,OtherA),
7700 gen_vars(OtherA,OtherVars),
7701 delay_phase_end(validate_store_type_assumptions,
7702 ( static_suspension_term(OtherF/OtherA,Suspension),
7703 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7704 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7705 )
7706 ),
7707 % create_get_mutable_ref(active,State,GetMutable),
7708 CurrentSuspTest = (
7709 OtherSusp = Suspension,
7710 GetState
7711 ),
7712 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7713 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7714 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7715 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7716 RecursiveVars = PreVarsAndSusps1
7717 ;
7718 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7719 PrevId0 = Id
7720 ),
7721 ( PrevId0 = [_] ->
7722 PrevId = PrevId0
7723 ;
7724 PrevId = [O|PrevId0]
7725 ),
7726 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7727 RecursiveCall = RecursiveHead,
7728 CurrentHead =.. [_|OtherArgs],
7729 pairup(OtherArgs,OtherVars,OtherPairs),
7730 get_constraint_mode(OtherF/OtherA,Mode),
7731 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7733 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7734 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7735 get_occurrence(F/A,O,_,ID),
7737 ( is_observed(F/A,O) ->
7738 init(FirstVarsSusp,FirstVars),
7739 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7740 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7741 ;
7742 Attachment = true,
7743 ConditionalRecursiveCall = RecursiveCall
7744 ),
7745 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7746 NovelProduction = true,
7747 ExtendHistory = true
7748 ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
7749 NovelProduction = true,
7750 ExtendHistory = true
7751 ;
7752 get_occurrence(F/A,O,_,ID),
7753 use_auxiliary_predicate(novel_production),
7754 use_auxiliary_predicate(extend_history),
7755 does_use_history(F/A,O),
7756 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7757 ( HistoryIDs == [] ->
7758 empty_named_history_novel_production(HistoryName,NovelProduction),
7759 empty_named_history_extend_history(HistoryName,ExtendHistory)
7760 ;
7761 reverse([OtherSusp|RestSusps],NamedSusps),
7762 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7763 HistorySusps = [HistorySusp|_],
7765 ( length(HistoryIDs, 1) ->
7766 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7767 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7768 ;
7769 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7770 Tuple =.. [t,HistoryName|HistorySusps]
7771 )
7772 )
7773 ;
7774 HistorySusp = Susp,
7775 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7776 sort([ID|RestIDs],HistoryIDs),
7777 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7778 Tuple =.. [t,RuleNb|HistorySusps]
7779 ),
7781 ( var(NovelProduction) ->
7782 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7783 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7784 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7785 ;
7786 true
7787 )
7788 ),
7791 ( chr_pp_flag(debugable,on) ->
7792 Rule = rule(_,_,Guard,Body),
7793 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7794 get_occurrence(F/A,O,_,ID),
7795 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7796 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7797 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7798 ;
7799 DebugTry = true,
7800 DebugApply = true
7801 ),
7803 ( is_stored_in_guard(F/A, RuleNb) ->
7804 GuardAttachment = Attachment,
7805 BodyAttachment = true
7806 ;
7807 GuardAttachment = true,
7808 BodyAttachment = Attachment % will be true if not observed at all
7809 ),
7811 Clause = (
7812 ClauseHead :-
7813 ( CurrentSuspTest,
7814 DiffSuspGoals,
7815 Matching,
7816 NovelProduction,
7817 GuardAttachment,
7818 GuardCopy,
7819 DebugTry ->
7820 DebugApply,
7821 ExtendHistory,
7822 BodyAttachment,
7823 BodyCopy,
7824 ConditionalRecursiveCall
7825 ; RecursiveCall
7826 )
7827 ),
7828 add_location(Clause,RuleNb,LocatedClause),
7829 L = [LocatedClause|T].
7831 novel_production_calls([],[],[],_,_,true).
7832 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7833 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7834 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7835 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7837 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7838 reverse(ReversedRestSusps,RestSusps),
7839 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7841 named_history_susps([],_,_,[]).
7842 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7843 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7844 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7848 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7849 !,
7850 functor(Head,F,A),
7851 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7852 get_constraint_mode(F/A,Mode),
7853 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7854 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7855 append(VarsSusp,ExtraVars,HeadVars).
7856 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7857 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7858 functor(Head,F,A),
7859 gen_var(Susps),
7860 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7861 get_constraint_mode(F/A,Mode),
7862 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7863 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7864 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7866 % returns
7867 % VarDict for the copies of variables in the original heads
7868 % VarsSuspsList list of lists of arguments for the successive heads
7869 % FirstVarsSusp top level arguments
7870 % SuspList list of all suspensions
7871 % Iterators list of all iterators
7872 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7873 !,
7874 functor(Head,F,A),
7875 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7876 get_constraint_mode(F/A,Mode),
7877 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7878 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7879 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7880 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7881 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7882 functor(Head,F,A),
7883 gen_var(Susps),
7884 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7885 get_constraint_mode(F/A,Mode),
7886 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7887 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7888 append(HeadVars,[Susp,Susps],Vars).
7890 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7891 !,
7892 functor(Head,F,A),
7893 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7894 get_constraint_mode(F/A,Mode),
7895 head_arg_matches(Pairs,Mode,[],_,VarDict),
7896 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7897 append(VarsSusp,ExtraVars,HeadVars).
7898 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7899 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7900 functor(Head,F,A),
7901 gen_var(Susps),
7902 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7903 get_constraint_mode(F/A,Mode),
7904 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7905 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7906 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7908 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7910 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7911 %% ____ _ _ _ _
7912 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7913 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7914 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7915 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7916 %%
7917 %% ____ _ _ _
7918 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7919 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7920 %% | _ < __/ |_| | | | __/\ V / (_| | |
7921 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7922 %%
7923 %% ____ _ _
7924 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7925 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7926 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7927 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7928 %% |___/
7930 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7931 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7932 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7933 ;
7934 NRestHeads = RestHeads,
7935 NRestIDs = RestIDs
7936 ).
7938 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7939 term_variables(Head,Vars),
7940 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7941 copy_term_nat(InitialData,InitialDataCopy),
7942 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7943 InitialDataCopy = InitialData,
7944 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7945 reverse(RNRestHeads,NRestHeads),
7946 reverse(RNRestIDs,NRestIDs).
7948 final_data(Entry) :-
7949 Entry = entry(_,_,_,_,[],_).
7951 expand_data(Entry,NEntry,Cost) :-
7952 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7953 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7954 term_variables([Head1|Vars],Vars1),
7955 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7956 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7958 % Assigns score to head based on known variables and heads to lookup
7959 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7960 functor(Head,F,A),
7961 get_store_type(F/A,StoreType),
7962 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7964 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7965 term_variables(Head,HeadVars),
7966 term_variables(RestHeads,RestVars),
7967 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7968 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7969 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7970 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7971 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7972 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7973 term_variables(Head,HeadVars),
7974 term_variables(RestHeads,RestVars),
7975 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7976 Score is Score_ * 2.
7977 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7978 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7979 Score = 1. % guaranteed O(1)
7981 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7982 find_with_var_identity(
7983 S,
7984 t(Head,KnownVars,RestHeads),
7985 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7986 Scores
7987 ),
7988 min_list(Scores,Score).
7989 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7990 Score = 10.
7991 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7992 Score = 10.
7994 order_score_indexes([],_,_,Score,NScore) :-
7995 Score > 0, NScore = 100.
7996 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7997 multi_hash_key_args(I,Head,Args),
7998 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7999 Score1 is Score + 1
8000 ;
8001 Score1 = Score
8002 ),
8003 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
8005 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8006 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8007 ( K-R-O == 0-0-0 ->
8008 Score = 0
8009 ; K > 0 ->
8010 Score is max(10 - K,0)
8011 ; R > 0 ->
8012 Score is max(10 - R,1) * 10
8013 ;
8014 Score is max(10-O,1) * 100
8015 ).
8016 order_score_count_vars([],_,_,0-0-0).
8017 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8018 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8019 ( memberchk_eq(V,KnownVars) ->
8020 NK is K + 1,
8021 NR = R, NO = O
8022 ; memberchk_eq(V,RestVars) ->
8023 NR is R + 1,
8024 NK = K, NO = O
8025 ;
8026 NO is O + 1,
8027 NK = K, NR = R
8028 ).
8030 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8031 %% ___ _ _ _
8032 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8033 %% | || '_ \| | | '_ \| | '_ \ / _` |
8034 %% | || | | | | | | | | | | | | (_| |
8035 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8036 %% |___/
8038 %% SWI begin
8039 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8040 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8041 %% SWI end
8043 %% SICStus begin
8044 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8045 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8046 %% SICStus end
8048 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8050 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8051 %% _ _ _ _ _ _ _
8052 %% | | | | |_(_) (_) |_ _ _
8053 %% | | | | __| | | | __| | | |
8054 %% | |_| | |_| | | | |_| |_| |
8055 %% \___/ \__|_|_|_|\__|\__, |
8056 %% |___/
8058 % Create a fresh variable.
8059 gen_var(_).
8061 % Create =N= fresh variables.
8062 gen_vars(N,Xs) :-
8063 length(Xs,N).
8065 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8066 vars_susp(A,Vars,Susp,VarsSusp),
8067 Head =.. [_|Args],
8068 pairup(Args,Vars,HeadPairs).
8070 inc_id([N|Ns],[O|Ns]) :-
8071 O is N + 1.
8072 dec_id([N|Ns],[M|Ns]) :-
8073 M is N - 1.
8075 extend_id(Id,[0|Id]).
8077 next_id([_,N|Ns],[O|Ns]) :-
8078 O is N + 1.
8080 % return clause Head
8081 % for F/A constraint symbol, predicate identifier Id and arguments Head
8082 build_head(F,A,Id,Args,Head) :-
8083 buildName(F,A,Id,Name),
8084 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8085 ( may_trigger(F/A) ;
8086 get_allocation_occurrence(F/A,AO),
8087 get_max_occurrence(F/A,MO),
8088 MO >= AO ) ) ->
8089 Head =.. [Name|Args]
8090 ;
8091 init(Args,ArgsWOSusp), % XXX not entirely correct!
8092 Head =.. [Name|ArgsWOSusp]
8093 ).
8095 % return predicate name Result
8096 % for Fct/Aty constraint symbol and predicate identifier List
8097 buildName(Fct,Aty,List,Result) :-
8098 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8099 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8100 MO >= AO ) ; List \= [0])) ) ) ->
8101 atom_concat(Fct, '___' ,FctSlash),
8102 atomic_concat(FctSlash,Aty,FctSlashAty),
8103 buildName_(List,FctSlashAty,Result)
8104 ;
8105 Result = Fct
8106 ).
8108 buildName_([],Name,Name).
8109 buildName_([N|Ns],Name,Result) :-
8110 buildName_(Ns,Name,Name1),
8111 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8112 atomic_concat(NameDash,N,Result).
8114 vars_susp(A,Vars,Susp,VarsSusp) :-
8115 length(Vars,A),
8116 append(Vars,[Susp],VarsSusp).
8118 or_pattern(Pos,Pat) :-
8119 Pow is Pos - 1,
8120 Pat is 1 << Pow. % was 2 ** X
8122 and_pattern(Pos,Pat) :-
8123 X is Pos - 1,
8124 Y is 1 << X, % was 2 ** X
8125 Pat is (-1)*(Y + 1).
8127 make_name(Prefix,F/A,Name) :-
8128 atom_concat_list([Prefix,F,'___',A],Name).
8130 %===============================================================================
8131 % Attribute for attributed variables
8133 make_attr(N,Mask,SuspsList,Attr) :-
8134 length(SuspsList,N),
8135 Attr =.. [v,Mask|SuspsList].
8137 get_all_suspensions2(N,Attr,SuspensionsList) :-
8138 chr_pp_flag(dynattr,off), !,
8139 make_attr(N,_,SuspensionsList,Attr).
8141 % NEW
8142 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8143 % writeln(get_all_suspensions2),
8144 length(SuspensionsList,N),
8145 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8148 % NEW
8149 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8150 % writeln(normalize_attr),
8151 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8153 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8154 chr_pp_flag(dynattr,off), !,
8155 make_attr(N,_,SuspsList,Attr),
8156 nth1(Position,SuspsList,Suspensions).
8158 % NEW
8159 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8160 % writeln(get_suspensions),
8161 Goal =
8162 ( memberchk(Position-Suspensions,TAttr) ->
8163 true
8164 ;
8165 Suspensions = []
8166 ).
8168 %-------------------------------------------------------------------------------
8169 % +N: number of constraint symbols
8170 % +Suspension: source-level variable, for suspension
8171 % +Position: constraint symbol number
8172 % -Attr: source-level term, for new attribute
8173 singleton_attr(N,Suspension,Position,Attr) :-
8174 chr_pp_flag(dynattr,off), !,
8175 or_pattern(Position,Pattern),
8176 make_attr(N,Pattern,SuspsList,Attr),
8177 nth1(Position,SuspsList,[Suspension]),
8178 chr_delete(SuspsList,[Suspension],RestSuspsList),
8179 set_elems(RestSuspsList,[]).
8181 % NEW
8182 singleton_attr(N,Suspension,Position,Attr) :-
8183 % writeln(singleton_attr),
8184 Attr = [Position-[Suspension]].
8186 %-------------------------------------------------------------------------------
8187 % +N: number of constraint symbols
8188 % +Suspension: source-level variable, for suspension
8189 % +Position: constraint symbol number
8190 % +TAttr: source-level variable, for old attribute
8191 % -Goal: goal for creating new attribute
8192 % -NTAttr: source-level variable, for new attribute
8193 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8194 chr_pp_flag(dynattr,off), !,
8195 make_attr(N,Mask,SuspsList,Attr),
8196 or_pattern(Position,Pattern),
8197 nth1(Position,SuspsList,Susps),
8198 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8199 make_attr(N,Mask,SuspsList1,NewAttr1),
8200 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8201 make_attr(N,NewMask,SuspsList2,NewAttr2),
8202 Goal = (
8203 TAttr = Attr,
8204 ( Mask /\ Pattern =:= Pattern ->
8205 NTAttr = NewAttr1
8206 ;
8207 NewMask is Mask \/ Pattern,
8208 NTAttr = NewAttr2
8209 )
8210 ), !.
8212 % NEW
8213 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8214 % writeln(add_attr),
8215 Goal =
8216 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8217 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8218 ;
8219 NTAttr = [Position-[Suspension]|TAttr]
8220 ).
8222 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8223 chr_pp_flag(dynattr,off), !,
8224 or_pattern(Position,Pattern),
8225 and_pattern(Position,DelPattern),
8226 make_attr(N,Mask,SuspsList,Attr),
8227 nth1(Position,SuspsList,Susps),
8228 substitute_eq(Susps,SuspsList,[],SuspsList1),
8229 make_attr(N,NewMask,SuspsList1,Attr1),
8230 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8231 make_attr(N,Mask,SuspsList2,Attr2),
8232 get_target_module(Mod),
8233 Goal = (
8234 TAttr = Attr,
8235 ( Mask /\ Pattern =:= Pattern ->
8236 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8237 ( NewSusps == [] ->
8238 NewMask is Mask /\ DelPattern,
8239 ( NewMask == 0 ->
8240 del_attr(Var,Mod)
8241 ;
8242 put_attr(Var,Mod,Attr1)
8243 )
8244 ;
8245 put_attr(Var,Mod,Attr2)
8246 )
8247 ;
8248 true
8249 )
8250 ), !.
8252 % NEW
8253 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8254 % writeln(rem_attr),
8255 get_target_module(Mod),
8256 Goal =
8257 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8258 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8259 ( NSuspensions == [] ->
8260 ( RAttr == [] ->
8261 del_attr(Var,Mod)
8262 ;
8263 put_attr(Var,Mod,RAttr)
8264 )
8265 ;
8266 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8267 )
8268 ;
8269 true
8270 ).
8272 %-------------------------------------------------------------------------------
8273 % +N: number of constraint symbols
8274 % +TAttr1: source-level variable, for attribute
8275 % +TAttr2: source-level variable, for other attribute
8276 % -Goal: goal for merging the two attributes
8277 % -Attr: source-level term, for merged attribute
8278 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8279 chr_pp_flag(dynattr,off), !,
8280 make_attr(N,Mask1,SuspsList1,Attr1),
8281 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8282 Goal = (
8283 TAttr1 = Attr1,
8284 Goal2
8285 ).
8287 % NEW
8288 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8289 % writeln(merge_attributes),
8290 Goal = (
8291 sort(TAttr1,Sorted1),
8292 sort(TAttr2,Sorted2),
8293 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8294 ).
8297 %-------------------------------------------------------------------------------
8298 % +N: number of constraint symbols
8299 % +Mask1: ...
8300 % +SuspsList1: static term, for suspensions list
8301 % +TAttr2: source-level variable, for other attribute
8302 % -Goal: goal for merging the two attributes
8303 % -Attr: source-level term, for merged attribute
8304 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8305 make_attr(N,Mask2,SuspsList2,Attr2),
8306 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8307 list2conj(Gs,SortGoals),
8308 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8309 make_attr(N,Mask,SuspsList,Attr),
8310 Goal = (
8311 TAttr2 = Attr2,
8312 SortGoals,
8313 Mask is Mask1 \/ Mask2
8314 ).
8317 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8318 % Storetype dependent lookup
8320 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8321 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8322 %% -Goal,-SuspensionList) is det.
8323 %
8324 % Create a universal lookup goal for given head.
8325 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8326 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8327 functor(Head,F,A),
8328 get_store_type(F/A,StoreType),
8329 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8331 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8332 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8333 %% -Goal,-SuspensionList) is det.
8334 %
8335 % Create a universal lookup goal for given head.
8336 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8337 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8338 functor(Head,F,A),
8339 get_store_type(F/A,StoreType),
8340 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8342 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8343 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8344 %% +GroundVars,-Goal,-SuspensionList) is det.
8345 %
8346 % Create a universal lookup goal for given head.
8347 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8348 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8349 functor(Head,F,A),
8350 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8351 update_store_type(F/A,default).
8352 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8353 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8354 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8355 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8356 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8357 functor(Head,F,A),
8358 global_ground_store_name(F/A,StoreName),
8359 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8360 update_store_type(F/A,global_ground).
8361 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8362 arg(VarIndex,Head,OVar),
8363 arg(KeyIndex,Head,OKey),
8364 translate([OVar,OKey],VarDict,[Var,Key]),
8365 get_target_module(Module),
8366 Goal = (
8367 get_attr(Var,Module,AssocStore),
8368 lookup_assoc_store(AssocStore,Key,AllSusps)
8369 ).
8370 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8371 functor(Head,F,A),
8372 global_singleton_store_name(F/A,StoreName),
8373 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8374 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8375 update_store_type(F/A,global_singleton).
8376 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8377 once((
8378 member(ST,StoreTypes),
8379 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8380 )).
8381 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8382 functor(Head,F,A),
8383 arg(Index,Head,Var),
8384 translate([Var],VarDict,[KeyVar]),
8385 delay_phase_end(validate_store_type_assumptions,
8386 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8387 ),
8388 update_store_type(F/A,identifier_store(Index)),
8389 get_identifier_index(F/A,Index,_).
8390 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8391 functor(Head,F,A),
8392 arg(Index,Head,Var),
8393 ( var(Var) ->
8394 translate([Var],VarDict,[KeyVar]),
8395 Goal = StructGoal
8396 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8397 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8398 Goal = (LookupGoal,StructGoal)
8399 ),
8400 delay_phase_end(validate_store_type_assumptions,
8401 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8402 ),
8403 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8404 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8406 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8407 get_identifier_size(ISize),
8408 functor(Struct,struct,ISize),
8409 get_identifier_index(C,Index,IIndex),
8410 arg(IIndex,Struct,AllSusps),
8411 Goal = (KeyVar = Struct).
8413 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8414 type_indexed_identifier_structure(IndexType,Struct),
8415 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8416 arg(IIndex,Struct,AllSusps),
8417 Goal = (KeyVar = Struct).
8419 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8420 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8421 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8422 %
8423 % Create a universal hash lookup goal for given head.
8424 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8425 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8426 once((
8427 member(Index,Indexes),
8428 multi_hash_key_args(Index,Head,KeyArgs),
8429 (
8430 translate(KeyArgs,VarDict,KeyArgCopies)
8431 ;
8432 ground(KeyArgs), KeyArgCopies = KeyArgs
8433 )
8434 )),
8435 ( KeyArgCopies = [KeyCopy] ->
8436 true
8437 ;
8438 KeyCopy =.. [k|KeyArgCopies]
8439 ),
8440 functor(Head,F,A),
8441 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8443 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8444 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8446 Goal = (GroundCheck,LookupGoal),
8448 ( HashType == inthash ->
8449 update_store_type(F/A,multi_inthash([Index]))
8450 ;
8451 update_store_type(F/A,multi_hash([Index]))
8452 ).
8454 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8455 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8456 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8457 %% +VarArgDict,-NewVarArgDict) is det.
8458 %
8459 % Create existential lookup goal for given head.
8460 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8461 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8462 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8463 sbag_member_call(Susp,AllSusps,Sbag),
8464 functor(Head,F,A),
8465 delay_phase_end(validate_store_type_assumptions,
8466 ( static_suspension_term(F/A,SuspTerm),
8467 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8468 )
8469 ),
8470 Goal = (
8471 UniversalGoal,
8472 Sbag,
8473 Susp = SuspTerm,
8474 GetState
8475 ).
8476 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8477 functor(Head,F,A),
8478 global_singleton_store_name(F/A,StoreName),
8479 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8480 Goal = (
8481 GetStoreGoal, % nb_getval(StoreName,Susp),
8482 Susp \== [],
8483 Susp = SuspTerm
8484 ),
8485 update_store_type(F/A,global_singleton).
8486 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8487 once((
8488 member(ST,StoreTypes),
8489 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8490 )).
8491 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8492 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8493 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8494 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8495 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8496 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8497 hash_index_filter(Pairs,Index,NPairs),
8499 functor(Head,F,A),
8500 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8501 Sbag = (AllSusps = [Susp])
8502 ;
8503 sbag_member_call(Susp,AllSusps,Sbag)
8504 ),
8505 delay_phase_end(validate_store_type_assumptions,
8506 ( static_suspension_term(F/A,SuspTerm),
8507 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8508 )
8509 ),
8510 Goal = (
8511 LookupGoal,
8512 Sbag,
8513 Susp = SuspTerm, % not inlined
8514 GetState
8515 ).
8516 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8517 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8518 hash_index_filter(Pairs,Index,NPairs),
8520 functor(Head,F,A),
8521 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8522 Sbag = (AllSusps = [Susp])
8523 ;
8524 sbag_member_call(Susp,AllSusps,Sbag)
8525 ),
8526 delay_phase_end(validate_store_type_assumptions,
8527 ( static_suspension_term(F/A,SuspTerm),
8528 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8529 )
8530 ),
8531 Goal = (
8532 LookupGoal,
8533 Sbag,
8534 Susp = SuspTerm, % not inlined
8535 GetState
8536 ).
8537 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8538 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8539 sbag_member_call(Susp,Susps,Sbag),
8540 functor(Head,F,A),
8541 delay_phase_end(validate_store_type_assumptions,
8542 ( static_suspension_term(F/A,SuspTerm),
8543 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8544 )
8545 ),
8546 Goal = (
8547 UGoal,
8548 Sbag,
8549 Susp = SuspTerm, % not inlined
8550 GetState
8551 ).
8553 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8554 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8555 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8556 %% +VarArgDict,-NewVarArgDict) is det.
8557 %
8558 % Create existential hash lookup goal for given head.
8559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8560 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8561 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8563 hash_index_filter(Pairs,Index,NPairs),
8565 functor(Head,F,A),
8566 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8567 Sbag = (AllSusps = [Susp])
8568 ;
8569 sbag_member_call(Susp,AllSusps,Sbag)
8570 ),
8571 delay_phase_end(validate_store_type_assumptions,
8572 ( static_suspension_term(F/A,SuspTerm),
8573 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8574 )
8575 ),
8576 Goal = (
8577 LookupGoal,
8578 Sbag,
8579 Susp = SuspTerm, % not inlined
8580 GetState
8581 ).
8583 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8584 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8585 %
8586 % Filter out pairs already covered by given hash index.
8587 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8588 hash_index_filter(Pairs,Index,NPairs) :-
8589 ( integer(Index) ->
8590 NIndex = [Index]
8591 ;
8592 NIndex = Index
8593 ),
8594 hash_index_filter(Pairs,NIndex,1,NPairs).
8596 hash_index_filter([],_,_,[]).
8597 hash_index_filter([P|Ps],Index,N,NPairs) :-
8598 ( Index = [I|Is] ->
8599 NN is N + 1,
8600 ( I > N ->
8601 NPairs = [P|NPs],
8602 hash_index_filter(Ps,[I|Is],NN,NPs)
8603 ; I == N ->
8604 hash_index_filter(Ps,Is,NN,NPairs)
8605 )
8606 ;
8607 NPairs = [P|Ps]
8608 ).
8610 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8611 %------------------------------------------------------------------------------%
8612 %% assume_constraint_stores(+ConstraintSymbols) is det.
8613 %
8614 % Compute all constraint store types that are possible for the given
8615 % =ConstraintSymbols=.
8616 %------------------------------------------------------------------------------%
8617 assume_constraint_stores([]).
8618 assume_constraint_stores([C|Cs]) :-
8619 ( chr_pp_flag(debugable,off),
8620 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8621 is_stored(C),
8622 get_store_type(C,default) ->
8623 get_indexed_arguments(C,AllIndexedArgs),
8624 get_constraint_mode(C,Modes),
8625 % findall(Index,(member(Index,AllIndexedArgs),
8626 % nth1(Index,Modes,+)),IndexedArgs),
8627 % length(IndexedArgs,NbIndexedArgs),
8628 aggregate_all(bag(Index)-count,
8629 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8630 IndexedArgs-NbIndexedArgs),
8631 % Construct Index Combinations
8632 ( NbIndexedArgs > 10 ->
8633 findall([Index],member(Index,IndexedArgs),Indexes)
8634 ;
8635 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8636 predsort(longer_list,UnsortedIndexes,Indexes)
8637 ),
8638 % EXPERIMENTAL HEURISTIC
8639 % findall(Index, (
8640 % member(Arg1,IndexedArgs),
8641 % member(Arg2,IndexedArgs),
8642 % Arg1 =< Arg2,
8643 % sort([Arg1,Arg2], Index)
8644 % ), UnsortedIndexes),
8645 % predsort(longer_list,UnsortedIndexes,Indexes),
8646 % Choose Index Type
8647 ( get_functional_dependency(C,1,Pattern,Key),
8648 all_distinct_var_args(Pattern), Key == [] ->
8649 assumed_store_type(C,global_singleton)
8650 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8651 get_constraint_type_det(C,ArgTypes),
8652 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8654 ( IntHashIndexes = [] ->
8655 Stores = Stores1
8656 ;
8657 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8658 ),
8659 ( HashIndexes = [] ->
8660 Stores1 = Stores2
8661 ;
8662 Stores1 = [multi_hash(HashIndexes)|Stores2]
8663 ),
8664 ( IdentifierIndexes = [] ->
8665 Stores2 = Stores3
8666 ;
8667 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8668 append(WrappedIdentifierIndexes,Stores3,Stores2)
8669 ),
8670 append(CompoundIdentifierIndexes,Stores4,Stores3),
8671 ( only_ground_indexed_arguments(C)
8672 -> Stores4 = [global_ground]
8673 ; Stores4 = [default]
8674 ),
8675 assumed_store_type(C,multi_store(Stores))
8676 ; true
8677 )
8678 ;
8679 true
8680 ),
8681 assume_constraint_stores(Cs).
8683 %------------------------------------------------------------------------------%
8684 %% partition_indexes(+Indexes,+Types,
8685 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8686 %------------------------------------------------------------------------------%
8687 partition_indexes([],_,[],[],[],[]).
8688 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8689 ( Index = [I],
8690 nth1(I,Types,Type),
8691 unalias_type(Type,UnAliasedType),
8692 UnAliasedType == chr_identifier ->
8693 IdentifierIndexes = [I|RIdentifierIndexes],
8694 IntHashIndexes = RIntHashIndexes,
8695 HashIndexes = RHashIndexes,
8696 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8697 ; Index = [I],
8698 nth1(I,Types,Type),
8699 unalias_type(Type,UnAliasedType),
8700 nonvar(UnAliasedType),
8701 UnAliasedType = chr_identifier(IndexType) ->
8702 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8703 IdentifierIndexes = RIdentifierIndexes,
8704 IntHashIndexes = RIntHashIndexes,
8705 HashIndexes = RHashIndexes
8706 ; Index = [I],
8707 nth1(I,Types,Type),
8708 unalias_type(Type,UnAliasedType),
8709 UnAliasedType == dense_int ->
8710 IntHashIndexes = [Index|RIntHashIndexes],
8711 HashIndexes = RHashIndexes,
8712 IdentifierIndexes = RIdentifierIndexes,
8713 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8714 ; member(I,Index),
8715 nth1(I,Types,Type),
8716 unalias_type(Type,UnAliasedType),
8717 nonvar(UnAliasedType),
8718 UnAliasedType = chr_identifier(_) ->
8719 % don't use chr_identifiers in hash indexes
8720 IntHashIndexes = RIntHashIndexes,
8721 HashIndexes = RHashIndexes,
8722 IdentifierIndexes = RIdentifierIndexes,
8723 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8724 ;
8725 IntHashIndexes = RIntHashIndexes,
8726 HashIndexes = [Index|RHashIndexes],
8727 IdentifierIndexes = RIdentifierIndexes,
8728 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8729 ),
8730 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8732 longer_list(R,L1,L2) :-
8733 length(L1,N1),
8734 length(L2,N2),
8735 compare(Rt,N2,N1),
8736 ( Rt == (=) ->
8737 compare(R,L1,L2)
8738 ;
8739 R = Rt
8740 ).
8742 all_distinct_var_args(Term) :-
8743 copy_term_nat(Term,TermCopy),
8744 functor(Term,F,A),
8745 functor(Pattern,F,A),
8746 Pattern =@= Term.
8748 get_indexed_arguments(C,IndexedArgs) :-
8749 C = F/A,
8750 get_indexed_arguments(1,A,C,IndexedArgs).
8752 get_indexed_arguments(I,N,C,L) :-
8753 ( I > N ->
8754 L = []
8755 ; ( is_indexed_argument(C,I) ->
8756 L = [I|T]
8757 ;
8758 L = T
8759 ),
8760 J is I + 1,
8761 get_indexed_arguments(J,N,C,T)
8762 ).
8764 validate_store_type_assumptions([]).
8765 validate_store_type_assumptions([C|Cs]) :-
8766 validate_store_type_assumption(C),
8767 validate_store_type_assumptions(Cs).
8769 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8770 % new code generation
8771 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8772 Rule = rule(H1,_,Guard,Body),
8773 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8774 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8775 flatten(VarsAndSuspsList,VarsAndSusps),
8776 Vars = [ [] | VarsAndSusps],
8777 build_head(F,A,[O|Id],Vars,Head),
8778 ( PrevId0 = [_] ->
8779 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8780 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8781 PrevId = [PredictedPrevId] % PrevId = PrevId0
8782 ;
8783 PrevId = [O|PrevId0]
8784 ),
8785 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8786 Clause = ( Head :- PredecessorCall),
8787 add_dummy_location(Clause,LocatedClause),
8788 L = [LocatedClause | T].
8789 % ( H1 == [],
8790 % functor(CurrentHead,CF,CA),
8791 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8792 % L = T
8793 % ;
8794 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8795 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8796 % flatten(VarsAndSuspsList,VarsAndSusps),
8797 % Vars = [ [] | VarsAndSusps],
8798 % build_head(F,A,Id,Vars,Head),
8799 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8800 % Clause = ( Head :- PredecessorCall),
8801 % L = [Clause | T]
8802 % ).
8804 % skips back intelligently over global_singleton lookups
8805 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8806 ( Id = [0|_] ->
8807 % TOM: add partial success continuation optimization here!
8808 next_id(Id,PrevId),
8809 PrevVarsAndSusps = BaseCallArgs
8810 ;
8811 VarsAndSuspsList = [_|AllButFirstList],
8812 dec_id(Id,PrevId1),
8813 ( PrevHeads = [PrevHead|PrevHeads1],
8814 functor(PrevHead,F,A),
8815 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8816 PrevIterators = [_|PrevIterators1],
8817 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8818 ;
8819 PrevId = PrevId1,
8820 flatten(AllButFirstList,AllButFirst),
8821 PrevIterators = [PrevIterator|_],
8822 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8823 )
8824 ).
8826 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8827 Rule = rule(_,_,Guard,Body),
8828 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8829 init(AllSusps,PreSusps),
8830 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8831 gen_var(OtherSusps),
8832 functor(CurrentHead,OtherF,OtherA),
8833 gen_vars(OtherA,OtherVars),
8834 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8835 get_constraint_mode(OtherF/OtherA,Mode),
8836 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8838 delay_phase_end(validate_store_type_assumptions,
8839 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8840 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8841 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8842 )
8843 ),
8845 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8846 % create_get_mutable_ref(active,State,GetMutable),
8847 CurrentSuspTest = (
8848 OtherSusp = OtherSuspension,
8849 GetState,
8850 DiffSuspGoals,
8851 FirstMatching
8852 ),
8853 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8854 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8855 inc_id(Id,NestedId),
8856 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8857 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8858 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8859 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8860 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
8862 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8863 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8864 RecursiveVars = PreVarsAndSusps1
8865 ;
8866 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8867 PrevId0 = Id
8868 ),
8869 ( PrevId0 = [_] ->
8870 PrevId = PrevId0
8871 ;
8872 PrevId = [O|PrevId0]
8873 ),
8874 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8876 Clause = (
8877 ClauseHead :-
8878 ( CurrentSuspTest,
8879 NextSuspGoal
8880 ->
8881 NestedHead
8882 ; RecursiveHead
8883 )
8884 ),
8885 add_dummy_location(Clause,LocatedClause),
8886 L = [LocatedClause|T].
8888 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8890 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8891 % Observation Analysis
8892 %
8893 % CLASSIFICATION
8894 % Enabled
8895 %
8896 % Analysis based on Abstract Interpretation paper.
8897 %
8898 % TODO:
8899 % stronger analysis domain [research]
8901 :- chr_constraint
8902 initial_call_pattern/1,
8903 call_pattern/1,
8904 call_pattern_worker/1,
8905 final_answer_pattern/2,
8906 abstract_constraints/1,
8907 depends_on/2,
8908 depends_on_ap/4,
8909 depends_on_goal/2,
8910 ai_observed_internal/2,
8911 % ai_observed/2,
8912 ai_not_observed_internal/2,
8913 ai_not_observed/2,
8914 ai_is_observed/2,
8915 depends_on_as/3,
8916 ai_observation_gather_results/0.
8918 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8919 :- chr_type program_point == any.
8921 :- chr_option(mode,initial_call_pattern(+)).
8922 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8924 :- chr_option(mode,call_pattern(+)).
8925 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8927 :- chr_option(mode,call_pattern_worker(+)).
8928 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8930 :- chr_option(mode,final_answer_pattern(+,+)).
8931 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8933 :- chr_option(mode,abstract_constraints(+)).
8934 :- chr_option(type_declaration,abstract_constraints(list)).
8936 :- chr_option(mode,depends_on(+,+)).
8937 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8939 :- chr_option(mode,depends_on_as(+,+,+)).
8940 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8941 :- chr_option(mode,depends_on_goal(+,+)).
8942 :- chr_option(mode,ai_is_observed(+,+)).
8943 :- chr_option(mode,ai_not_observed(+,+)).
8944 % :- chr_option(mode,ai_observed(+,+)).
8945 :- chr_option(mode,ai_not_observed_internal(+,+)).
8946 :- chr_option(mode,ai_observed_internal(+,+)).
8949 abstract_constraints_fd @
8950 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8952 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8953 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8954 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8956 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8957 ai_is_observed(_,_) <=> true.
8959 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8960 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8961 ai_observation_gather_results <=> true.
8963 %------------------------------------------------------------------------------%
8964 % Main Analysis Entry
8965 %------------------------------------------------------------------------------%
8966 ai_observation_analysis(ACs) :-
8967 ( chr_pp_flag(ai_observation_analysis,on),
8968 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8969 list_to_ord_set(ACs,ACSet),
8970 abstract_constraints(ACSet),
8971 ai_observation_schedule_initial_calls(ACSet,ACSet),
8972 ai_observation_gather_results
8973 ;
8974 true
8975 ).
8977 ai_observation_schedule_initial_calls([],_).
8978 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8979 ai_observation_schedule_initial_call(AC,ACs),
8980 ai_observation_schedule_initial_calls(RACs,ACs).
8982 ai_observation_schedule_initial_call(AC,ACs) :-
8983 ai_observation_top(AC,CallPattern),
8984 % ai_observation_bot(AC,ACs,CallPattern),
8985 initial_call_pattern(CallPattern).
8987 ai_observation_schedule_new_calls([],AP).
8988 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8989 AP = odom(_,Set),
8990 initial_call_pattern(odom(AC,Set)),
8991 ai_observation_schedule_new_calls(ACs,AP).
8993 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8994 <=>
8995 ai_observation_leq(AP2,AP1)
8996 |
8997 true.
8999 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9001 initial_call_pattern(CP) ==> call_pattern(CP).
9003 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9004 ==>
9005 ai_observation_schedule_new_calls(ACs,AP)
9006 pragma
9007 passive(ID3).
9009 call_pattern(CP) \ call_pattern(CP) <=> true.
9011 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9012 final_answer_pattern(CP1,AP).
9014 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9016 call_pattern(CP) ==> call_pattern_worker(CP).
9018 %------------------------------------------------------------------------------%
9019 % Abstract Goal
9020 %------------------------------------------------------------------------------%
9022 % AbstractGoala
9023 %call_pattern(odom([],Set)) ==>
9024 % final_answer_pattern(odom([],Set),odom([],Set)).
9026 call_pattern_worker(odom([],Set)) <=>
9027 % writeln(' - AbstractGoal'(odom([],Set))),
9028 final_answer_pattern(odom([],Set),odom([],Set)).
9030 % AbstractGoalb
9031 call_pattern_worker(odom([G|Gs],Set)) <=>
9032 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9033 CP1 = odom(G,Set),
9034 depends_on_goal(odom([G|Gs],Set),CP1),
9035 call_pattern(CP1).
9037 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9038 <=> true pragma passive(ID).
9039 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9040 ==>
9041 CP1 = odom([_|Gs],_),
9042 AP2 = odom([],Set),
9043 CCP = odom(Gs,Set),
9044 call_pattern(CCP),
9045 depends_on(CP1,CCP).
9047 %------------------------------------------------------------------------------%
9048 % Abstract Disjunction
9049 %------------------------------------------------------------------------------%
9051 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9052 CP = odom((AG1;AG2),Set),
9053 InitialAnswerApproximation = odom([],Set),
9054 final_answer_pattern(CP,InitialAnswerApproximation),
9055 CP1 = odom(AG1,Set),
9056 CP2 = odom(AG2,Set),
9057 call_pattern(CP1),
9058 call_pattern(CP2),
9059 depends_on_as(CP,CP1,CP2).
9061 %------------------------------------------------------------------------------%
9062 % Abstract Solve
9063 %------------------------------------------------------------------------------%
9064 call_pattern_worker(odom(builtin,Set)) <=>
9065 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9066 ord_empty(EmptySet),
9067 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9069 %------------------------------------------------------------------------------%
9070 % Abstract Drop
9071 %------------------------------------------------------------------------------%
9072 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9073 <=>
9074 O > MO
9075 |
9076 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9077 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9078 pragma
9079 passive(ID2).
9081 %------------------------------------------------------------------------------%
9082 % Abstract Activate
9083 %------------------------------------------------------------------------------%
9084 call_pattern_worker(odom(AC,Set))
9085 <=>
9086 AC = _ / _
9087 |
9088 % writeln(' - AbstractActivate'(odom(AC,Set))),
9089 CP = odom(occ(AC,1),Set),
9090 call_pattern(CP),
9091 depends_on(odom(AC,Set),CP).
9093 %------------------------------------------------------------------------------%
9094 % Abstract Passive
9095 %------------------------------------------------------------------------------%
9096 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9097 <=>
9098 is_passive(RuleNb,ID)
9099 |
9100 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9101 % DEFAULT
9102 NO is O + 1,
9103 DCP = odom(occ(C,NO),Set),
9104 call_pattern(DCP),
9105 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9106 depends_on(odom(occ(C,O),Set),DCP)
9107 pragma
9108 passive(ID2).
9109 %------------------------------------------------------------------------------%
9110 % Abstract Simplify
9111 %------------------------------------------------------------------------------%
9113 % AbstractSimplify
9114 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9115 <=>
9116 \+ is_passive(RuleNb,ID)
9117 |
9118 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9119 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9120 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9121 ai_observation_memo_abstract_goal(RuleNb,AG),
9122 call_pattern(odom(AG,Set2)),
9123 % DEFAULT
9124 NO is O + 1,
9125 DCP = odom(occ(C,NO),Set),
9126 call_pattern(DCP),
9127 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9128 % DEADLOCK AVOIDANCE
9129 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9130 pragma
9131 passive(ID2).
9133 depends_on_as(CP,CPS,CPD),
9134 final_answer_pattern(CPS,APS),
9135 final_answer_pattern(CPD,APD) ==>
9136 ai_observation_lub(APS,APD,AP),
9137 final_answer_pattern(CP,AP).
9140 :- chr_constraint
9141 ai_observation_memo_simplification_rest_heads/3,
9142 ai_observation_memoed_simplification_rest_heads/3.
9144 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9145 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9147 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9148 <=>
9149 QRH = RH.
9150 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9151 <=>
9152 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9153 once(select2(ID,_,IDs1,H1,_,RestH1)),
9154 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9155 ai_observation_abstract_constraints(H2,ACs,AH2),
9156 append(ARestHeads,AH2,AbstractHeads),
9157 sort(AbstractHeads,QRH),
9158 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9159 pragma
9160 passive(ID1),
9161 passive(ID2),
9162 passive(ID3).
9164 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9166 %------------------------------------------------------------------------------%
9167 % Abstract Propagate
9168 %------------------------------------------------------------------------------%
9171 % AbstractPropagate
9172 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9173 <=>
9174 \+ is_passive(RuleNb,ID)
9175 |
9176 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9177 % observe partners
9178 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9179 ai_observation_observe_set(Set,AHs,Set2),
9180 ord_add_element(Set2,C,Set3),
9181 ai_observation_memo_abstract_goal(RuleNb,AG),
9182 call_pattern(odom(AG,Set3)),
9183 ( ord_memberchk(C,Set2) ->
9184 Delete = no
9185 ;
9186 Delete = yes
9187 ),
9188 % DEFAULT
9189 NO is O + 1,
9190 DCP = odom(occ(C,NO),Set),
9191 call_pattern(DCP),
9192 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9193 pragma
9194 passive(ID2).
9196 :- chr_constraint
9197 ai_observation_memo_propagation_rest_heads/3,
9198 ai_observation_memoed_propagation_rest_heads/3.
9200 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9201 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9203 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9204 <=>
9205 QRH = RH.
9206 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9207 <=>
9208 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9209 once(select2(ID,_,IDs2,H2,_,RestH2)),
9210 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9211 ai_observation_abstract_constraints(H1,ACs,AH1),
9212 append(ARestHeads,AH1,AbstractHeads),
9213 sort(AbstractHeads,QRH),
9214 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9215 pragma
9216 passive(ID1),
9217 passive(ID2),
9218 passive(ID3).
9220 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9222 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9223 final_answer_pattern(CP,APD).
9224 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9225 final_answer_pattern(CPD,APD) ==>
9226 true |
9227 CP = odom(occ(C,O),_),
9228 ( ai_observation_is_observed(APP,C) ->
9229 ai_observed_internal(C,O)
9230 ;
9231 ai_not_observed_internal(C,O)
9232 ),
9233 ( Delete == yes ->
9234 APP = odom([],Set0),
9235 ord_del_element(Set0,C,Set),
9236 NAPP = odom([],Set)
9237 ;
9238 NAPP = APP
9239 ),
9240 ai_observation_lub(NAPP,APD,AP),
9241 final_answer_pattern(CP,AP).
9243 %------------------------------------------------------------------------------%
9244 % Catch All
9245 %------------------------------------------------------------------------------%
9247 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9249 %------------------------------------------------------------------------------%
9250 % Auxiliary Predicates
9251 %------------------------------------------------------------------------------%
9253 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9254 ord_intersection(S1,S2,S3).
9256 ai_observation_bot(AG,AS,odom(AG,AS)).
9258 ai_observation_top(AG,odom(AG,EmptyS)) :-
9259 ord_empty(EmptyS).
9261 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9262 ord_subset(S2,S1).
9264 ai_observation_observe_set(S,ACSet,NS) :-
9265 ord_subtract(S,ACSet,NS).
9267 ai_observation_abstract_constraint(C,ACs,AC) :-
9268 functor(C,F,A),
9269 AC = F/A,
9270 memberchk(AC,ACs).
9272 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9273 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9275 %------------------------------------------------------------------------------%
9276 % Abstraction of Rule Bodies
9277 %------------------------------------------------------------------------------%
9279 :- chr_constraint
9280 ai_observation_memoed_abstract_goal/2,
9281 ai_observation_memo_abstract_goal/2.
9283 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9284 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9286 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9287 <=>
9288 QAG = AG
9289 pragma
9290 passive(ID1).
9292 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9293 <=>
9294 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9295 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9296 QAG = AG,
9297 ai_observation_memoed_abstract_goal(RuleNb,AG)
9298 pragma
9299 passive(ID1),
9300 passive(ID2).
9302 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9303 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9304 term_variables((H1,H2,Guard),HVars),
9305 append(H1,H2,Heads),
9306 % variables that are declared to be ground are safe,
9307 ground_vars(Heads,GroundVars),
9308 % so we remove them from the list of 'dangerous' head variables
9309 list_difference_eq(HVars,GroundVars,HV),
9310 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9311 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9312 % HV are 'dangerous' variables, all others are fresh and safe
9314 ground_vars([],[]).
9315 ground_vars([H|Hs],GroundVars) :-
9316 functor(H,F,A),
9317 get_constraint_mode(F/A,Mode),
9318 % TOM: fix this code!
9319 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9320 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9321 ground_vars(Hs,GroundVars2),
9322 append(GroundVars1,GroundVars2,GroundVars).
9324 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9325 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9326 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9327 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9328 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9329 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9330 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9331 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9332 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9333 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9334 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9335 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9336 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9337 % non-CHR constraint is safe if it only binds fresh variables
9338 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9339 builtin_binds_b(G,Vars),
9340 intersect_eq(Vars,HV,[]),
9341 !.
9342 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9343 AG = builtin. % default case if goal is not recognized/safe
9345 ai_observation_is_observed(odom(_,ACSet),AC) :-
9346 \+ ord_memberchk(AC,ACSet).
9348 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9349 unconditional_occurrence(C,O) :-
9350 get_occurrence(C,O,RuleNb,ID),
9351 get_rule(RuleNb,PRule),
9352 PRule = pragma(ORule,_,_,_,_),
9353 copy_term_nat(ORule,Rule),
9354 Rule = rule(H1,H2,Guard,_),
9355 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9356 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9357 once((
9358 H1 = [Head], H2 == []
9359 ;
9360 H2 = [Head], H1 == [], \+ may_trigger(C)
9361 )),
9362 functor(Head,F,A),
9363 Head =.. [_|Args],
9364 unconditional_occurrence_args(Args).
9366 unconditional_occurrence_args([]).
9367 unconditional_occurrence_args([X|Xs]) :-
9368 var(X),
9369 X = x,
9370 unconditional_occurrence_args(Xs).
9372 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9374 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9375 % Partial wake analysis
9376 %
9377 % In a Var = Var unification do not wake up constraints of both variables,
9378 % but rather only those of one variable.
9379 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9381 :- chr_constraint partial_wake_analysis/0.
9382 :- chr_constraint no_partial_wake/1.
9383 :- chr_option(mode,no_partial_wake(+)).
9384 :- chr_constraint wakes_partially/1.
9385 :- chr_option(mode,wakes_partially(+)).
9387 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9388 ==>
9389 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9390 ( is_passive(RuleNb,ID) ->
9391 true
9392 ; Type == simplification ->
9393 select(H,H1,RestH1),
9394 H =.. [_|Args],
9395 term_variables(Guard,Vars),
9396 partial_wake_args(Args,ArgModes,Vars,FA)
9397 ; % Type == propagation ->
9398 select(H,H2,RestH2),
9399 H =.. [_|Args],
9400 term_variables(Guard,Vars),
9401 partial_wake_args(Args,ArgModes,Vars,FA)
9402 ).
9404 partial_wake_args([],_,_,_).
9405 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9406 ( Mode \== (+) ->
9407 ( nonvar(Arg) ->
9408 no_partial_wake(C)
9409 ; memberchk_eq(Arg,Vars) ->
9410 no_partial_wake(C)
9411 ;
9412 true
9413 )
9414 ;
9415 true
9416 ),
9417 partial_wake_args(Args,Modes,Vars,C).
9419 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9421 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9423 wakes_partially(C) <=> true.
9426 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9427 % Generate rules that implement chr_show_store/1 functionality.
9428 %
9429 % CLASSIFICATION
9430 % Experimental
9431 % Unused
9432 %
9433 % Generates additional rules:
9434 %
9435 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9436 % ...
9437 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9438 % $show <=> true.
9440 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9441 ( chr_pp_flag(show,on) ->
9442 Constraints = ['$show'/0|Constraints0],
9443 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9444 inc_rule_count(RuleNb),
9445 Rule = pragma(
9446 rule(['$show'],[],true,true),
9447 ids([0],[]),
9448 [],
9449 no,
9450 RuleNb
9451 )
9452 ;
9453 Constraints = Constraints0,
9454 Rules = Rules0
9455 ).
9457 generate_show_rules([],Rules,Rules).
9458 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9459 functor(C,F,A),
9460 inc_rule_count(RuleNb),
9461 Rule = pragma(
9462 rule([],['$show',C],true,writeln(C)),
9463 ids([],[0,1]),
9464 [passive(1)],
9465 no,
9466 RuleNb
9467 ),
9468 generate_show_rules(Rest,Tail,Rules).
9470 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9471 % Custom supension term layout
9473 static_suspension_term(F/A,Suspension) :-
9474 suspension_term_base(F/A,Base),
9475 Arity is Base + A,
9476 functor(Suspension,suspension,Arity).
9478 has_suspension_field(FA,Field) :-
9479 suspension_term_base_fields(FA,Fields),
9480 memberchk(Field,Fields).
9482 suspension_term_base(FA,Base) :-
9483 suspension_term_base_fields(FA,Fields),
9484 length(Fields,Base).
9486 suspension_term_base_fields(FA,Fields) :-
9487 ( chr_pp_flag(debugable,on) ->
9488 % 1. ID
9489 % 2. State
9490 % 3. Propagation History
9491 % 4. Generation Number
9492 % 5. Continuation Goal
9493 % 6. Functor
9494 Fields = [id,state,history,generation,continuation,functor]
9495 ;
9496 ( uses_history(FA) ->
9497 Fields = [id,state,history|Fields2]
9498 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9499 Fields = [state|Fields2]
9500 ;
9501 Fields = [id,state|Fields2]
9502 ),
9503 ( only_ground_indexed_arguments(FA) ->
9504 get_store_type(FA,StoreType),
9505 basic_store_types(StoreType,BasicStoreTypes),
9506 ( memberchk(global_ground,BasicStoreTypes) ->
9507 % 1. ID
9508 % 2. State
9509 % 3. Propagation History
9510 % 4. Global List Prev
9511 Fields2 = [global_list_prev|Fields3]
9512 ;
9513 % 1. ID
9514 % 2. State
9515 % 3. Propagation History
9516 Fields2 = Fields3
9517 ),
9518 ( chr_pp_flag(ht_removal,on)
9519 -> ht_prev_fields(BasicStoreTypes,Fields3)
9520 ; Fields3 = []
9521 )
9522 ; may_trigger(FA) ->
9523 % 1. ID
9524 % 2. State
9525 % 3. Propagation History
9526 ( uses_field(FA,generation) ->
9527 % 4. Generation Number
9528 % 5. Global List Prev
9529 Fields2 = [generation,global_list_prev|Fields3]
9530 ;
9531 Fields2 = [global_list_prev|Fields3]
9532 ),
9533 ( chr_pp_flag(mixed_stores,on),
9534 chr_pp_flag(ht_removal,on)
9535 -> get_store_type(FA,StoreType),
9536 basic_store_types(StoreType,BasicStoreTypes),
9537 ht_prev_fields(BasicStoreTypes,Fields3)
9538 ; Fields3 = []
9539 )
9540 ;
9541 % 1. ID
9542 % 2. State
9543 % 3. Propagation History
9544 % 4. Global List Prev
9545 Fields2 = [global_list_prev|Fields3],
9546 ( chr_pp_flag(mixed_stores,on),
9547 chr_pp_flag(ht_removal,on)
9548 -> get_store_type(FA,StoreType),
9549 basic_store_types(StoreType,BasicStoreTypes),
9550 ht_prev_fields(BasicStoreTypes,Fields3)
9551 ; Fields3 = []
9552 )
9553 )
9554 ).
9556 ht_prev_fields(Stores,Prevs) :-
9557 ht_prev_fields_int(Stores,PrevsList),
9558 append(PrevsList,Prevs).
9559 ht_prev_fields_int([],[]).
9560 ht_prev_fields_int([H|T],Fields) :-
9561 ( H = multi_hash(Indexes)
9562 -> maplist(ht_prev_field,Indexes,FH),
9563 Fields = [FH|FT]
9564 ; Fields = FT
9565 ),
9566 ht_prev_fields_int(T,FT).
9568 ht_prev_field(Index,Field) :-
9569 ( integer(Index)
9570 -> atom_concat('multi_hash_prev-',Index,Field)
9571 ; Index = [_|_]
9572 -> concat_atom(['multi_hash_prev-'|Index],Field)
9573 ).
9575 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9576 suspension_term_base_fields(FA,Fields),
9577 nth1(Index,Fields,FieldName), !,
9578 arg(Index,StaticSuspension,Field).
9579 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9580 suspension_term_base(FA,Base),
9581 StaticSuspension =.. [_|Args],
9582 drop(Base,Args,Field).
9583 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9584 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9587 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9588 suspension_term_base_fields(FA,Fields),
9589 nth1(Index,Fields,FieldName), !,
9590 Goal = arg(Index,DynamicSuspension,Field).
9591 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9592 static_suspension_term(FA,StaticSuspension),
9593 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9594 Goal = (DynamicSuspension = StaticSuspension).
9595 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9596 suspension_term_base(FA,Base),
9597 Index is I + Base,
9598 Goal = arg(Index,DynamicSuspension,Field).
9599 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9600 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9603 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9604 suspension_term_base_fields(FA,Fields),
9605 nth1(Index,Fields,FieldName), !,
9606 Goal = setarg(Index,DynamicSuspension,Field).
9607 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9608 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9610 basic_store_types(multi_store(Types),Types) :- !.
9611 basic_store_types(Type,[Type]).
9613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9614 %
9616 :- chr_constraint
9617 phase_end/1,
9618 delay_phase_end/2.
9620 :- chr_option(mode,phase_end(+)).
9621 :- chr_option(mode,delay_phase_end(+,?)).
9623 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9624 % phase_end(Phase) <=> true.
9627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9628 :- chr_constraint
9629 does_use_history/2,
9630 uses_history/1,
9631 novel_production_call/4.
9633 :- chr_option(mode,uses_history(+)).
9634 :- chr_option(mode,does_use_history(+,+)).
9635 :- chr_option(mode,novel_production_call(+,+,?,?)).
9637 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9638 does_use_history(FA,_) \ uses_history(FA) <=> true.
9639 uses_history(_FA) <=> fail.
9641 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9642 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9644 :- chr_constraint
9645 does_use_field/2,
9646 uses_field/2.
9648 :- chr_option(mode,uses_field(+,+)).
9649 :- chr_option(mode,does_use_field(+,+)).
9651 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9652 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9653 uses_field(_FA,_Field) <=> fail.
9655 :- chr_constraint
9656 uses_state/2,
9657 if_used_state/5,
9658 used_states_known/0.
9660 :- chr_option(mode,uses_state(+,+)).
9661 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9664 % states ::= not_stored_yet | passive | active | triggered | removed
9665 %
9666 % allocate CREATES not_stored_yet
9667 % remove CHECKS not_stored_yet
9668 % activate CHECKS not_stored_yet
9669 %
9670 % ==> no allocate THEN no not_stored_yet
9672 % recurs CREATES inactive
9673 % lookup CHECKS inactive
9675 % insert CREATES active
9676 % activate CREATES active
9677 % lookup CHECKS active
9678 % recurs CHECKS active
9680 % runsusp CREATES triggered
9681 % lookup CHECKS triggered
9682 %
9683 % ==> no runsusp THEN no triggered
9685 % remove CREATES removed
9686 % runsusp CHECKS removed
9687 % lookup CHECKS removed
9688 % recurs CHECKS removed
9689 %
9690 % ==> no remove THEN no removed
9692 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9694 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9696 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9697 <=> ResultGoal = Used.
9698 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9699 <=> ResultGoal = NotUsed.
9701 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9702 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9703 % (Feature for SSS)
9704 %
9705 % 1. Checking
9706 % ~~~~~~~~~~~
9707 %
9708 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9709 %
9710 % :- chr_option(declare_stored_constraints,on).
9711 %
9712 % the compiler will check for the storedness of constraints.
9713 %
9714 % By default, the compiler assumes that the programmer wants his constraints to
9715 % be never-stored. Hence, a warning will be issues when a constraint is actually
9716 % stored.
9717 %
9718 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9719 % to a constraint declaration, i.e. writes
9720 %
9721 % :- chr_constraint c(...) # stored.
9722 %
9723 % In that case a warning is issued when the constraint is never-stored.
9724 %
9725 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9726 % constraints are stored anyway.
9727 %
9728 %
9729 % 2. Rule Generation
9730 % ~~~~~~~~~~~~~~~~~~
9731 %
9732 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9733 %
9734 % :- chr_option(declare_stored_constraints,on).
9735 %
9736 % the compiler will generate default simplification rules for constraints.
9737 %
9738 % By default, no default rule is generated for a constraint. However, if the
9739 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9740 %
9741 % :- chr_constraint c(...) # default(Goal).
9742 %
9743 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9744 % the compiler generates a rule:
9745 %
9746 % c(_,...,_) <=> Goal.
9747 %
9748 % at the end of the program. If multiple default rules are generated, for several constraints,
9749 % then the order of the default rules is not specified.
9752 :- chr_constraint stored_assertion/1.
9753 :- chr_option(mode,stored_assertion(+)).
9754 :- chr_option(type_declaration,stored_assertion(constraint)).
9756 :- chr_constraint never_stored_default/2.
9757 :- chr_option(mode,never_stored_default(+,?)).
9758 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9760 % Rule Generation
9761 % ~~~~~~~~~~~~~~~
9763 generate_never_stored_rules(Constraints,Rules) :-
9764 ( chr_pp_flag(declare_stored_constraints,on) ->
9765 never_stored_rules(Constraints,Rules)
9766 ;
9767 Rules = []
9768 ).
9770 :- chr_constraint never_stored_rules/2.
9771 :- chr_option(mode,never_stored_rules(+,?)).
9772 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9774 never_stored_rules([],Rules) <=> Rules = [].
9775 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9776 Constraint = F/A,
9777 functor(Head,F,A),
9778 inc_rule_count(RuleNb),
9779 Rule = pragma(
9780 rule([Head],[],true,Goal),
9781 ids([0],[]),
9782 [],
9783 no,
9784 RuleNb
9785 ),
9786 Rules = [Rule|Tail],
9787 never_stored_rules(Constraints,Tail).
9788 never_stored_rules([_|Constraints],Rules) <=>
9789 never_stored_rules(Constraints,Rules).
9791 % Checking
9792 % ~~~~~~~~
9794 check_storedness_assertions(Constraints) :-
9795 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9796 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9797 ;
9798 true
9799 ).
9802 :- chr_constraint check_storedness_assertion/1.
9803 :- chr_option(mode,check_storedness_assertion(+)).
9804 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9806 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9807 <=> ( is_stored(Constraint) ->
9808 true
9809 ;
9810 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9811 ).
9812 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9813 <=> ( is_finally_stored(Constraint) ->
9814 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9815 ; is_stored(Constraint) ->
9816 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9817 ;
9818 true
9819 ).
9820 % never-stored, no default goal
9821 check_storedness_assertion(Constraint)
9822 <=> ( is_finally_stored(Constraint) ->
9823 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9824 ; is_stored(Constraint) ->
9825 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9826 ;
9827 true
9828 ).
9830 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9831 % success continuation analysis
9833 % TODO
9834 % also use for forward jumping improvement!
9835 % use Prolog indexing for generated code
9836 %
9837 % EXPORTED
9838 %
9839 % should_skip_to_next_id(C,O)
9840 %
9841 % get_occurrence_code_id(C,O,Id)
9842 %
9843 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9845 continuation_analysis(ConstraintSymbols) :-
9846 maplist(analyse_continuations,ConstraintSymbols).
9848 analyse_continuations(C) :-
9849 % 1. compute success continuations of the
9850 % occurrences of constraint C
9851 continuation_analysis(C,1),
9852 % 2. determine for which occurrences
9853 % to skip to next code id
9854 get_max_occurrence(C,MO),
9855 LO is MO + 1,
9856 bulk_propagation(C,1,LO),
9857 % 3. determine code id for each occurrence
9858 set_occurrence_code_id(C,1,0).
9860 % 1. Compute the success continuations of constrait C
9861 %-------------------------------------------------------------------------------
9863 continuation_analysis(C,O) :-
9864 get_max_occurrence(C,MO),
9865 ( O > MO ->
9866 true
9867 ; O == MO ->
9868 NextO is O + 1,
9869 continuation_occurrence(C,O,NextO)
9870 ;
9871 constraint_continuation(C,O,MO,NextO),
9872 continuation_occurrence(C,O,NextO),
9873 NO is O + 1,
9874 continuation_analysis(C,NO)
9875 ).
9877 constraint_continuation(C,O,MO,NextO) :-
9878 ( get_occurrence_head(C,O,Head) ->
9879 NO is O + 1,
9880 ( between(NO,MO,NextO),
9881 get_occurrence_head(C,NextO,NextHead),
9882 unifiable(Head,NextHead,_) ->
9883 true
9884 ;
9885 NextO is MO + 1
9886 )
9887 ; % current occurrence is passive
9888 NextO = MO
9889 ).
9891 get_occurrence_head(C,O,Head) :-
9892 get_occurrence(C,O,RuleNb,Id),
9893 \+ is_passive(RuleNb,Id),
9894 get_rule(RuleNb,Rule),
9895 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
9896 ( select2(Id,Head,Ids1,H1,_,_) -> true
9897 ; select2(Id,Head,Ids2,H2,_,_)
9898 ).
9900 :- chr_constraint continuation_occurrence/3.
9901 :- chr_option(mode,continuation_occurrence(+,+,+)).
9903 :- chr_constraint get_success_continuation_occurrence/3.
9904 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
9906 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
9907 <=>
9908 X = NO.
9910 get_success_continuation_occurrence(C,O,X)
9911 <=>
9912 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
9914 % 2. figure out when to skip to next code id
9915 %-------------------------------------------------------------------------------
9916 % don't go beyond the last occurrence
9917 % we have to go to next id for storage here
9919 :- chr_constraint skip_to_next_id/2.
9920 :- chr_option(mode,skip_to_next_id(+,+)).
9922 :- chr_constraint should_skip_to_next_id/2.
9923 :- chr_option(mode,should_skip_to_next_id(+,+)).
9925 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
9926 <=>
9927 true.
9929 should_skip_to_next_id(_,_)
9930 <=>
9931 fail.
9933 :- chr_constraint bulk_propagation/3.
9934 :- chr_option(mode,bulk_propagation(+,+,+)).
9936 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
9937 <=>
9938 O >= MO
9939 |
9940 skip_to_next_id(C,O).
9941 % we have to go to the next id here because
9942 % a predecessor needs it
9943 bulk_propagation(C,O,LO)
9944 <=>
9945 LO =:= O + 1
9946 |
9947 skip_to_next_id(C,O),
9948 get_max_occurrence(C,MO),
9949 NLO is MO + 1,
9950 bulk_propagation(C,LO,NLO).
9951 % we have to go to the next id here because
9952 % we're running into a simplification rule
9953 % IMPROVE: propagate back to propagation predecessor (IF ANY)
9954 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
9955 <=>
9956 NO =:= O + 1
9957 |
9958 skip_to_next_id(C,O),
9959 get_max_occurrence(C,MO),
9960 NLO is MO + 1,
9961 bulk_propagation(C,NO,NLO).
9962 % we skip the next id here
9963 % and go to the next occurrence
9964 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
9965 <=>
9966 NextO > O + 1
9967 |
9968 NLO is min(LO,NextO),
9969 NO is O + 1,
9970 bulk_propagation(C,NO,NLO).
9971 % default case
9972 % err on the safe side
9973 bulk_propagation(C,O,LO)
9974 <=>
9975 skip_to_next_id(C,O),
9976 get_max_occurrence(C,MO),
9977 NLO is MO + 1,
9978 NO is O + 1,
9979 bulk_propagation(C,NO,NLO).
9981 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
9983 % if this occurrence is passive, but has to skip,
9984 % then the previous one must skip instead...
9985 % IMPROVE reasoning is conservative
9986 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
9987 ==>
9988 O > 1
9989 |
9990 PO is O - 1,
9991 skip_to_next_id(C,PO).
9993 % 3. determine code id of each occurrence
9994 %-------------------------------------------------------------------------------
9996 :- chr_constraint set_occurrence_code_id/3.
9997 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
9999 :- chr_constraint occurrence_code_id/3.
10000 :- chr_option(mode,occurrence_code_id(+,+,+)).
10002 % stop at the end
10003 set_occurrence_code_id(C,O,IdNb)
10004 <=>
10005 get_max_occurrence(C,MO),
10006 O > MO
10007 |
10008 occurrence_code_id(C,O,IdNb).
10010 % passive occurrences don't change the code id
10011 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10012 <=>
10013 occurrence_code_id(C,O,IdNb),
10014 NO is O + 1,
10015 set_occurrence_code_id(C,NO,IdNb).
10017 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10018 <=>
10019 occurrence_code_id(C,O,IdNb),
10020 NO is O + 1,
10021 set_occurrence_code_id(C,NO,IdNb).
10023 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10024 <=>
10025 occurrence_code_id(C,O,IdNb),
10026 NO is O + 1,
10027 NIdNb is IdNb + 1,
10028 set_occurrence_code_id(C,NO,NIdNb).
10030 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10031 <=>
10032 occurrence_code_id(C,O,IdNb),
10033 NO is O + 1,
10034 set_occurrence_code_id(C,NO,IdNb).
10036 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10038 :- chr_constraint get_occurrence_code_id/3.
10039 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10041 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10042 <=>
10043 X = IdNb.
10045 get_occurrence_code_id(C,O,X)
10046 <=>
10047 ( O == 0 ->
10048 true % X = 0
10049 ;
10050 format('no occurrence code for ~w!\n',[C:O])
10051 ).
10053 get_success_continuation_code_id(C,O,NextId) :-
10054 get_success_continuation_occurrence(C,O,NextO),
10055 get_occurrence_code_id(C,NextO,NextId).
10057 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10059 dump_code(Clauses) :-
10060 ( chr_pp_flag(dump,on),
10061 member(Clause,Clauses),
10062 portray_clause(Clause),
10063 fail
10064 ;
10065 true
10066 ).