| blob | 0e8df518751591e941444ed7dc5d669cc4b7ffba |
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 %% TODO {{{
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 :- use_module(library(assoc)).
142 %% SWI end }}}
144 % imports and operators {{{
145 :- use_module(hprolog).
146 :- use_module(pairlist).
147 :- use_module(a_star).
148 :- use_module(listmap).
149 :- use_module(clean_code).
150 :- use_module(builtins).
151 :- use_module(find).
152 :- use_module(binomialheap).
153 :- use_module(guard_entailment).
154 :- use_module(chr_compiler_options).
155 :- use_module(chr_compiler_utility).
156 :- use_module(chr_compiler_errors).
157 :- include(chr_op).
158 :- op(1150, fx, chr_type).
159 :- op(1150, fx, chr_declaration).
160 :- op(1130, xfx, --->).
161 :- op(980, fx, (+)).
162 :- op(980, fx, (-)).
163 :- op(980, fx, (?)).
164 :- op(1150, fx, constraints).
165 :- op(1150, fx, chr_constraint).
166 % }}}
168 :- chr_option(debug,off).
169 :- chr_option(optimize,full).
170 :- chr_option(check_guard_bindings,off).
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 % Type Declarations {{{
174 :- chr_type list(T) ---> [] ; [T|list(T)].
176 :- chr_type list == list(any).
178 :- chr_type mode ---> (+) ; (-) ; (?).
180 :- chr_type maybe(T) ---> yes(T) ; no.
182 :- chr_type constraint ---> any / any.
184 :- chr_type module_name == any.
186 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
187 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
188 :- chr_type idspair ---> ids(list(id),list(id)).
190 :- chr_type pragma_type ---> passive(id)
191 ; mpassive(list(id))
192 ; already_in_heads
193 ; already_in_heads(id)
194 ; no_history
195 ; history(history_name,list(id)).
196 :- chr_type history_name== any.
198 :- chr_type rule_name == any.
199 :- chr_type rule_nb == natural.
200 :- chr_type id == natural.
201 :- chr_type occurrence == int.
203 :- chr_type goal == any.
205 :- chr_type store_type ---> default
206 ; multi_store(list(store_type))
207 ; multi_hash(list(list(int)))
208 ; multi_inthash(list(list(int)))
209 ; global_singleton
210 ; global_ground
211 % EXPERIMENTAL STORES
212 ; atomic_constants(list(int),list(any),coverage)
213 ; ground_constants(list(int),list(any),coverage)
214 ; var_assoc_store(int,list(int))
215 ; identifier_store(int)
216 ; type_indexed_identifier_store(int,any).
217 :- chr_type coverage ---> complete ; incomplete.
218 % }}}
219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
221 %------------------------------------------------------------------------------%
222 :- chr_constraint chr_source_file/1.
223 :- chr_option(mode,chr_source_file(+)).
224 :- chr_option(type_declaration,chr_source_file(module_name)).
225 %------------------------------------------------------------------------------%
226 chr_source_file(_) \ chr_source_file(_) <=> true.
228 %------------------------------------------------------------------------------%
229 :- chr_constraint get_chr_source_file/1.
230 :- chr_option(mode,get_chr_source_file(-)).
231 :- chr_option(type_declaration,get_chr_source_file(module_name)).
232 %------------------------------------------------------------------------------%
233 chr_source_file(Mod) \ get_chr_source_file(Query)
234 <=> Query = Mod .
235 get_chr_source_file(Query)
236 <=> Query = user.
239 %------------------------------------------------------------------------------%
240 :- chr_constraint target_module/1.
241 :- chr_option(mode,target_module(+)).
242 :- chr_option(type_declaration,target_module(module_name)).
243 %------------------------------------------------------------------------------%
244 target_module(_) \ target_module(_) <=> true.
246 %------------------------------------------------------------------------------%
247 :- chr_constraint get_target_module/1.
248 :- chr_option(mode,get_target_module(-)).
249 :- chr_option(type_declaration,get_target_module(module_name)).
250 %------------------------------------------------------------------------------%
251 target_module(Mod) \ get_target_module(Query)
252 <=> Query = Mod .
253 get_target_module(Query)
254 <=> Query = user.
256 %------------------------------------------------------------------------------%
257 :- chr_constraint line_number/2.
258 :- chr_option(mode,line_number(+,+)).
259 :- chr_option(type_declaration,line_number(rule_nb,int)).
260 %------------------------------------------------------------------------------%
261 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
263 %------------------------------------------------------------------------------%
264 :- chr_constraint get_line_number/2.
265 :- chr_option(mode,get_line_number(+,-)).
266 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
267 %------------------------------------------------------------------------------%
268 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
269 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
271 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
272 :- chr_option(mode,indexed_argument(+,+)).
273 :- chr_option(type_declaration,indexed_argument(constraint,int)).
275 :- chr_constraint is_indexed_argument/2.
276 :- chr_option(mode,is_indexed_argument(+,+)).
277 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
279 :- chr_constraint constraint_mode/2.
280 :- chr_option(mode,constraint_mode(+,+)).
281 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
283 :- chr_constraint get_constraint_mode/2.
284 :- chr_option(mode,get_constraint_mode(+,-)).
285 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
287 :- chr_constraint may_trigger/1.
288 :- chr_option(mode,may_trigger(+)).
289 :- chr_option(type_declaration,may_trigger(constraint)).
291 :- chr_constraint only_ground_indexed_arguments/1.
292 :- chr_option(mode,only_ground_indexed_arguments(+)).
293 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
295 :- chr_constraint none_suspended_on_variables/0.
297 :- chr_constraint are_none_suspended_on_variables/0.
299 :- chr_constraint store_type/2.
300 :- chr_option(mode,store_type(+,+)).
301 :- chr_option(type_declaration,store_type(constraint,store_type)).
303 :- chr_constraint get_store_type/2.
304 :- chr_option(mode,get_store_type(+,?)).
305 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
307 :- chr_constraint update_store_type/2.
308 :- chr_option(mode,update_store_type(+,+)).
309 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
311 :- chr_constraint actual_store_types/2.
312 :- chr_option(mode,actual_store_types(+,+)).
313 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
315 :- chr_constraint assumed_store_type/2.
316 :- chr_option(mode,assumed_store_type(+,+)).
317 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
319 :- chr_constraint validate_store_type_assumption/1.
320 :- chr_option(mode,validate_store_type_assumption(+)).
321 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
323 :- chr_constraint rule_count/1.
324 :- chr_option(mode,rule_count(+)).
325 :- chr_option(type_declaration,rule_count(natural)).
327 :- chr_constraint inc_rule_count/1.
328 :- chr_option(mode,inc_rule_count(-)).
329 :- chr_option(type_declaration,inc_rule_count(natural)).
331 rule_count(_) \ rule_count(_)
332 <=> true.
333 rule_count(C), inc_rule_count(NC)
334 <=> NC is C + 1, rule_count(NC).
335 inc_rule_count(NC)
336 <=> NC = 1, rule_count(NC).
338 :- chr_constraint passive/2.
339 :- chr_option(mode,passive(+,+)).
340 :- chr_option(type_declaration,passive(rule_nb,id)).
342 :- chr_constraint is_passive/2.
343 :- chr_option(mode,is_passive(+,+)).
344 :- chr_option(type_declaration,is_passive(rule_nb,id)).
346 :- chr_constraint any_passive_head/1.
347 :- chr_option(mode,any_passive_head(+)).
349 :- chr_constraint new_occurrence/4.
350 :- chr_option(mode,new_occurrence(+,+,+,+)).
352 :- chr_constraint occurrence/5.
353 :- chr_option(mode,occurrence(+,+,+,+,+)).
355 :- chr_type occurrence_type ---> simplification ; propagation.
356 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
358 :- chr_constraint get_occurrence/4.
359 :- chr_option(mode,get_occurrence(+,+,-,-)).
361 :- chr_constraint get_occurrence/5.
362 :- chr_option(mode,get_occurrence(+,+,-,-,-)).
364 :- chr_constraint get_occurrence_from_id/4.
365 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
367 :- chr_constraint max_occurrence/2.
368 :- chr_option(mode,max_occurrence(+,+)).
370 :- chr_constraint get_max_occurrence/2.
371 :- chr_option(mode,get_max_occurrence(+,-)).
373 :- chr_constraint allocation_occurrence/2.
374 :- chr_option(mode,allocation_occurrence(+,+)).
376 :- chr_constraint get_allocation_occurrence/2.
377 :- chr_option(mode,get_allocation_occurrence(+,-)).
379 :- chr_constraint rule/2.
380 :- chr_option(mode,rule(+,+)).
381 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
383 :- chr_constraint get_rule/2.
384 :- chr_option(mode,get_rule(+,-)).
385 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
387 :- chr_constraint least_occurrence/2.
388 :- chr_option(mode,least_occurrence(+,+)).
389 :- chr_option(type_declaration,least_occurrence(any,list)).
391 :- chr_constraint is_least_occurrence/1.
392 :- chr_option(mode,is_least_occurrence(+)).
395 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
396 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
397 is_indexed_argument(_,_) <=> fail.
399 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
402 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
403 Q = Mode.
404 get_constraint_mode(FA,Q) <=>
405 FA = _ / N,
406 replicate(N,(?),Q).
408 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
410 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
411 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
412 nth1(I,Mode,M),
413 M \== (+) |
414 is_stored(FA).
415 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
417 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
418 <=>
419 nth1(I,Mode,M),
420 M \== (+)
421 |
422 fail.
423 only_ground_indexed_arguments(_) <=>
424 true.
426 none_suspended_on_variables \ none_suspended_on_variables <=> true.
427 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
428 are_none_suspended_on_variables <=> fail.
429 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
430 % STORE TYPES
431 %
432 % The functionality for inspecting and deciding on the different types of constraint
433 % store / indexes for constraints.
435 store_type(FA,StoreType)
436 ==> chr_pp_flag(verbose,on)
437 |
438 format('The indexes for ~w are:\n',[FA]),
439 format_storetype(StoreType).
440 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
442 format_storetype(multi_store(StoreTypes)) :- !,
443 maplist(format_storetype,StoreTypes).
444 format_storetype(atomic_constants(Index,Constants,_)) :-
445 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
446 format_storetype(ground_constants(Index,Constants,_)) :-
447 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
448 format_storetype(StoreType) :-
449 format('\t* ~w\n',[StoreType]).
452 % 1. Inspection
453 % ~~~~~~~~~~~~~
454 %
455 %
457 get_store_type_normal @
458 store_type(FA,Store) \ get_store_type(FA,Query)
459 <=> Query = Store.
461 get_store_type_assumed @
462 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
463 <=> Query = Store.
465 get_store_type_default @
466 get_store_type(_,Query)
467 <=> Query = default.
469 % 2. Store type registration
470 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
472 actual_store_types(C,STs) \ update_store_type(C,ST)
473 <=> memberchk(ST,STs) | true.
474 update_store_type(C,ST), actual_store_types(C,STs)
475 <=>
476 actual_store_types(C,[ST|STs]).
477 update_store_type(C,ST)
478 <=>
479 actual_store_types(C,[ST]).
481 % 3. Final decision on store types
482 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
485 <=>
486 true % chr_pp_flag(experiment,on)
487 |
488 delete(STs,multi_hash([Index]),STs0),
489 Index = [IndexPos],
490 ( get_constraint_arg_type(C,IndexPos,Type),
491 enumerated_atomic_type(Type,Atoms) ->
492 /* use the type constants rather than the collected keys */
493 Constants = Atoms,
494 Completeness = complete
495 ;
496 Constants = Keys,
497 Completeness = incomplete
498 ),
499 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
500 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
501 <=>
502 true % chr_pp_flag(experiment,on)
503 |
504 ( Index = [IndexPos],
505 get_constraint_arg_type(C,IndexPos,Type),
506 Type = chr_enum(Constants)
507 ->
508 Completeness = complete
509 ;
510 Constants = Constants0,
511 Completeness = incomplete
512 ),
513 delete(STs,multi_hash([Index]),STs0),
514 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
516 get_constraint_arg_type(C,Pos,Type) :-
517 get_constraint_type(C,Types),
518 nth1(Pos,Types,Type0),
519 unalias_type(Type0,Type).
521 validate_store_type_assumption(C) \ actual_store_types(C,STs)
522 <=>
523 % chr_pp_flag(experiment,on),
524 memberchk(multi_hash([[Index]]),STs),
525 get_constraint_type(C,Types),
526 nth1(Index,Types,Type),
527 enumerated_atomic_type(Type,Atoms)
528 |
529 delete(STs,multi_hash([[Index]]),STs0),
530 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
531 validate_store_type_assumption(C) \ actual_store_types(C,STs)
532 <=>
533 memberchk(multi_hash([[Index]]),STs),
534 get_constraint_arg_type(C,Index,Type),
535 Type = chr_enum(Constants)
536 |
537 delete(STs,multi_hash([[Index]]),STs0),
538 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
539 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
540 <=>
541 ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) ->
542 Stores = [global_ground|STs]
543 ;
544 Stores = STs
545 ),
546 store_type(C,multi_store(Stores)).
547 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
548 <=>
549 store_type(C,multi_store(STs)).
550 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
551 <=>
552 chr_pp_flag(debugable,on)
553 |
554 store_type(C,default).
555 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
556 <=> store_type(C,global_ground).
557 validate_store_type_assumption(C)
558 <=> true.
560 partial_store(ground_constants(_,_,incomplete)).
561 partial_store(atomic_constants(_,_,incomplete)).
563 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
564 passive(R,ID) \ passive(R,ID) <=> true.
566 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
567 is_passive(_,_) <=> fail.
569 passive(RuleNb,_) \ any_passive_head(RuleNb)
570 <=> true.
571 any_passive_head(_)
572 <=> fail.
573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
575 max_occurrence(C,N) \ max_occurrence(C,M)
576 <=> N >= M | true.
578 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
579 NO is MO + 1,
580 occurrence(C,NO,RuleNb,ID,Type),
581 max_occurrence(C,NO).
582 new_occurrence(C,RuleNb,ID,_) <=>
583 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
585 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
586 <=> Q = MON.
587 get_max_occurrence(C,Q)
588 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
590 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
591 <=> Rule = QRule, ID = QID.
592 get_occurrence(C,O,_,_)
593 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
595 occurrence(C,ON,Rule,ID,OccType) \ get_occurrence(C,ON,QRule,QID,QOccType)
596 <=> Rule = QRule, ID = QID, OccType = QOccType.
597 get_occurrence(C,O,_,_,_)
598 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
600 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
601 <=> QC = C, QON = ON.
602 get_occurrence_from_id(C,O,_,_)
603 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
605 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
606 % Late allocation
608 late_allocation_analysis(Cs) :-
609 ( chr_pp_flag(late_allocation,on) ->
610 maplist(late_allocation, Cs)
611 ;
612 true
613 ).
615 late_allocation(C) :- late_allocation(C,0).
616 late_allocation(C,O) :- allocation_occurrence(C,O), !.
617 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
619 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
621 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
623 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
624 \+ is_passive(RuleNb,Id),
625 Type == propagation,
626 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
627 true
628 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
629 is_observed(C,O)
630 ; is_least_occurrence(RuleNb) -> % propagation rule
631 is_observed(C,O)
632 ;
633 true
634 ).
636 stored_in_guard_before_next_kept_occurrence(C,O) :-
637 chr_pp_flag(store_in_guards, on),
638 NO is O + 1,
639 stored_in_guard_lookahead(C,NO).
641 :- chr_constraint stored_in_guard_lookahead/2.
642 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
644 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
645 NO is O + 1, stored_in_guard_lookahead(C,NO).
646 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
647 Type == simplification,
648 ( is_stored_in_guard(C,RuleNb) ->
649 true
650 ;
651 NO is O + 1, stored_in_guard_lookahead(C,NO)
652 ).
653 stored_in_guard_lookahead(_,_) <=> fail.
656 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
657 \ least_occurrence(RuleNb,[ID|IDs])
658 <=> AO >= O, \+ may_trigger(C) |
659 least_occurrence(RuleNb,IDs).
660 rule(RuleNb,Rule), passive(RuleNb,ID)
661 \ least_occurrence(RuleNb,[ID|IDs])
662 <=> least_occurrence(RuleNb,IDs).
664 rule(RuleNb,Rule)
665 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
666 least_occurrence(RuleNb,IDs).
668 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
669 <=> true.
670 is_least_occurrence(_)
671 <=> fail.
673 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
674 <=> Q = O.
675 get_allocation_occurrence(_,Q)
676 <=> chr_pp_flag(late_allocation,off), Q=0.
677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
679 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
680 <=> Q = Rule.
681 get_rule(_,_)
682 <=> fail.
684 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
686 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
687 %
688 % Default store constraint index assignment.
690 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
691 :- chr_option(mode,constraint_index(+,+)).
692 :- chr_option(type_declaration,constraint_index(constraint,int)).
694 :- chr_constraint get_constraint_index/2.
695 :- chr_option(mode,get_constraint_index(+,-)).
696 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
698 :- chr_constraint get_indexed_constraint/2.
699 :- chr_option(mode,get_indexed_constraint(+,-)).
700 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
702 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
703 :- chr_option(mode,max_constraint_index(+)).
704 :- chr_option(type_declaration,max_constraint_index(int)).
706 :- chr_constraint get_max_constraint_index/1.
707 :- chr_option(mode,get_max_constraint_index(-)).
708 :- chr_option(type_declaration,get_max_constraint_index(int)).
710 constraint_index(C,Index) \ get_constraint_index(C,Query)
711 <=> Query = Index.
712 get_constraint_index(C,Query)
713 <=> fail.
715 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
716 <=> Q = C.
717 get_indexed_constraint(Index,Q)
718 <=> fail.
720 max_constraint_index(Index) \ get_max_constraint_index(Query)
721 <=> Query = Index.
722 get_max_constraint_index(Query)
723 <=> Query = 0.
725 set_constraint_indices(Constraints) :-
726 set_constraint_indices(Constraints,1).
727 set_constraint_indices([],M) :-
728 N is M - 1,
729 max_constraint_index(N).
730 set_constraint_indices([C|Cs],N) :-
731 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
732 ; get_store_type(C,var_assoc_store(_,_))) ->
733 constraint_index(C,N),
734 M is N + 1,
735 set_constraint_indices(Cs,M)
736 ;
737 set_constraint_indices(Cs,N)
738 ).
740 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
741 % Identifier Indexes
743 :- chr_constraint identifier_size/1.
744 :- chr_option(mode,identifier_size(+)).
745 :- chr_option(type_declaration,identifier_size(natural)).
747 identifier_size(_) \ identifier_size(_)
748 <=>
749 true.
751 :- chr_constraint get_identifier_size/1.
752 :- chr_option(mode,get_identifier_size(-)).
753 :- chr_option(type_declaration,get_identifier_size(natural)).
755 identifier_size(Size) \ get_identifier_size(Q)
756 <=>
757 Q = Size.
759 get_identifier_size(Q)
760 <=>
761 Q = 1.
763 :- chr_constraint identifier_index/3.
764 :- chr_option(mode,identifier_index(+,+,+)).
765 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
767 identifier_index(C,I,_) \ identifier_index(C,I,_)
768 <=>
769 true.
771 :- chr_constraint get_identifier_index/3.
772 :- chr_option(mode,get_identifier_index(+,+,-)).
773 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
775 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
776 <=>
777 Q = II.
778 identifier_size(Size), get_identifier_index(C,I,Q)
779 <=>
780 NSize is Size + 1,
781 identifier_index(C,I,NSize),
782 identifier_size(NSize),
783 Q = NSize.
784 get_identifier_index(C,I,Q)
785 <=>
786 identifier_index(C,I,2),
787 identifier_size(2),
788 Q = 2.
790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
791 % Type Indexed Identifier Indexes
793 :- chr_constraint type_indexed_identifier_size/2.
794 :- chr_option(mode,type_indexed_identifier_size(+,+)).
795 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
797 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
798 <=>
799 true.
801 :- chr_constraint get_type_indexed_identifier_size/2.
802 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
803 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
805 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
806 <=>
807 Q = Size.
809 get_type_indexed_identifier_size(IndexType,Q)
810 <=>
811 Q = 1.
813 :- chr_constraint type_indexed_identifier_index/4.
814 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
815 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
817 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
818 <=>
819 true.
821 :- chr_constraint get_type_indexed_identifier_index/4.
822 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
823 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
825 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
826 <=>
827 Q = II.
828 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
829 <=>
830 NSize is Size + 1,
831 type_indexed_identifier_index(IndexType,C,I,NSize),
832 type_indexed_identifier_size(IndexType,NSize),
833 Q = NSize.
834 get_type_indexed_identifier_index(IndexType,C,I,Q)
835 <=>
836 type_indexed_identifier_index(IndexType,C,I,2),
837 type_indexed_identifier_size(IndexType,2),
838 Q = 2.
840 type_indexed_identifier_structure(IndexType,Structure) :-
841 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
842 get_type_indexed_identifier_size(IndexType,Arity),
843 functor(Structure,Functor,Arity).
844 type_indexed_identifier_name(IndexType,Prefix,Name) :-
845 ( atom(IndexType) ->
846 IndexTypeName = IndexType
847 ;
848 term_to_atom(IndexType,IndexTypeName)
849 ),
850 atom_concat_list([Prefix,'_',IndexTypeName],Name).
852 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
857 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
858 %%
859 %% Translation
861 chr_translate(Declarations,NewDeclarations) :-
862 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
864 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
865 chr_banner,
866 restart_after_flattening(Declarations0,Declarations),
867 init_chr_pp_flags,
868 chr_source_file(File),
869 /* sort out the interesting stuff from the input */
870 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
871 chr_compiler_options:sanity_check,
873 dump_code(Declarations),
875 check_declared_constraints(Constraints0),
876 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
877 add_constraints(Constraints),
878 add_rules(Rules1),
879 generate_never_stored_rules(Constraints,NewRules),
880 add_rules(NewRules),
881 append(Rules1,NewRules,Rules),
882 chr_analysis(Rules,Constraints,Declarations),
883 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
884 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
885 phase_end(validate_store_type_assumptions),
886 used_states_known,
887 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
888 insert_declarations(OtherClauses, Clauses0),
889 chr_module_declaration(CHRModuleDeclaration),
890 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
891 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
892 append([Clauses0,GeneratedClauses], NewDeclarations),
893 dump_code(NewDeclarations),
894 !. /* cut choicepoint of restart_after_flattening */
896 chr_analysis(Rules,Constraints,Declarations) :-
897 maplist(pragma_rule_to_ast_rule,Rules,AstRules),
898 check_rules(Rules,AstRules,Constraints),
899 time('type checking',chr_translate:static_type_check(Rules,AstRules)),
900 /* constants */
901 collect_constants(Rules,AstRules,Constraints,Declarations),
902 add_occurrences(Rules,AstRules),
903 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
904 time('set semantics',chr_translate:set_semantics_rules(Rules)),
905 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
906 time('guard simplification',chr_translate:guard_simplification),
907 time('late storage',chr_translate:storage_analysis(Constraints)),
908 time('observation',chr_translate:observation_analysis(Constraints)),
909 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
910 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
911 partial_wake_analysis,
912 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
913 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
914 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
915 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
917 store_management_preds(Constraints,Clauses) :-
918 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
919 generate_attr_unify_hook(AttrUnifyHookClauses),
920 generate_attach_increment(AttachIncrementClauses),
921 generate_extra_clauses(Constraints,ExtraClauses),
922 generate_insert_delete_constraints(Constraints,DeleteClauses),
923 generate_attach_code(Constraints,StoreClauses),
924 generate_counter_code(CounterClauses),
925 generate_dynamic_type_check_clauses(TypeCheckClauses),
926 append([AttachAConstraintClauses
927 ,AttachIncrementClauses
928 ,AttrUnifyHookClauses
929 ,ExtraClauses
930 ,DeleteClauses
931 ,StoreClauses
932 ,CounterClauses
933 ,TypeCheckClauses
934 ]
935 ,Clauses).
938 insert_declarations(Clauses0, Clauses) :-
939 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
940 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
942 auxiliary_module(chr_hashtable_store).
943 auxiliary_module(chr_integertable_store).
944 auxiliary_module(chr_assoc_store).
946 generate_counter_code(Clauses) :-
947 ( chr_pp_flag(store_counter,on) ->
948 Clauses = [
949 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
950 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
951 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
952 (:- '$counter_init'('$insert_counter')),
953 (:- '$counter_init'('$delete_counter')),
954 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
955 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
956 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
957 ]
958 ;
959 Clauses = []
960 ).
962 % for systems with multifile declaration
963 chr_module_declaration(CHRModuleDeclaration) :-
964 get_target_module(Mod),
965 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
966 CHRModuleDeclaration = [
967 (:- multifile chr:'$chr_module'/1),
968 chr:'$chr_module'(Mod)
969 ]
970 ;
971 CHRModuleDeclaration = []
972 ).
975 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
976 %%
977 %% Partitioning of clauses into constraint declarations, chr rules and other
978 %% clauses
980 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
981 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
982 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
983 partition_clauses([],[],[],[]).
984 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
985 ( parse_rule(Clause,Rule) ->
986 ConstraintDeclarations = RestConstraintDeclarations,
987 Rules = [Rule|RestRules],
988 OtherClauses = RestOtherClauses
989 ; is_declaration(Clause,ConstraintDeclaration) ->
990 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
991 Rules = RestRules,
992 OtherClauses = RestOtherClauses
993 ; is_module_declaration(Clause,Mod) ->
994 target_module(Mod),
995 ConstraintDeclarations = RestConstraintDeclarations,
996 Rules = RestRules,
997 OtherClauses = [Clause|RestOtherClauses]
998 ; is_type_definition(Clause) ->
999 ConstraintDeclarations = RestConstraintDeclarations,
1000 Rules = RestRules,
1001 OtherClauses = RestOtherClauses
1002 ; is_chr_declaration(Clause) ->
1003 ConstraintDeclarations = RestConstraintDeclarations,
1004 Rules = RestRules,
1005 OtherClauses = RestOtherClauses
1006 ; Clause = (handler _) ->
1007 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
1008 ConstraintDeclarations = RestConstraintDeclarations,
1009 Rules = RestRules,
1010 OtherClauses = RestOtherClauses
1011 ; Clause = (rules _) ->
1012 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1013 ConstraintDeclarations = RestConstraintDeclarations,
1014 Rules = RestRules,
1015 OtherClauses = RestOtherClauses
1016 ; Clause = option(OptionName,OptionValue) ->
1017 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1018 handle_option(OptionName,OptionValue),
1019 ConstraintDeclarations = RestConstraintDeclarations,
1020 Rules = RestRules,
1021 OtherClauses = RestOtherClauses
1022 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1023 handle_option(OptionName,OptionValue),
1024 ConstraintDeclarations = RestConstraintDeclarations,
1025 Rules = RestRules,
1026 OtherClauses = RestOtherClauses
1027 ; Clause = ('$chr_compiled_with_version'(_)) ->
1028 ConstraintDeclarations = RestConstraintDeclarations,
1029 Rules = RestRules,
1030 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1031 ; ConstraintDeclarations = RestConstraintDeclarations,
1032 Rules = RestRules,
1033 OtherClauses = [Clause|RestOtherClauses]
1034 ),
1035 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1037 '$chr_compiled_with_version'(2).
1039 is_declaration(D, Constraints) :- %% constraint declaration
1040 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1041 conj2list(Cs,Constraints0)
1042 ;
1043 ( D = (:- Decl) ->
1044 Decl =.. [constraints,Cs]
1045 ;
1046 D =.. [constraints,Cs]
1047 ),
1048 conj2list(Cs,Constraints0),
1049 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1050 ),
1051 extract_type_mode(Constraints0,Constraints).
1053 extract_type_mode([],[]).
1054 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1055 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1056 ( C0 = C # Annotation ->
1057 functor(C,F,A),
1058 extract_annotation(Annotation,F/A)
1059 ;
1060 C0 = C,
1061 functor(C,F,A)
1062 ),
1063 ConstraintSymbol = F/A,
1064 C =.. [_|Args],
1065 extract_types_and_modes(Args,ArgTypes,ArgModes),
1066 assert_constraint_type(ConstraintSymbol,ArgTypes),
1067 constraint_mode(ConstraintSymbol,ArgModes),
1068 extract_type_mode(R,R2).
1070 extract_annotation(stored,Symbol) :-
1071 stored_assertion(Symbol).
1072 extract_annotation(default(Goal),Symbol) :-
1073 never_stored_default(Symbol,Goal).
1075 extract_types_and_modes([],[],[]).
1076 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1077 extract_type_and_mode(X,T,M),
1078 extract_types_and_modes(R,R2,R3).
1080 extract_type_and_mode(+(T),T,(+)) :- !.
1081 extract_type_and_mode(?(T),T,(?)) :- !.
1082 extract_type_and_mode(-(T),T,(-)) :- !.
1083 extract_type_and_mode((+),any,(+)) :- !.
1084 extract_type_and_mode((?),any,(?)) :- !.
1085 extract_type_and_mode((-),any,(-)) :- !.
1086 extract_type_and_mode(Illegal,_,_) :-
1087 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1089 is_chr_declaration(Declaration) :-
1090 Declaration = (:- chr_declaration Decl),
1091 ( Decl = (Pattern ---> Information) ->
1092 background_info(Pattern,Information)
1093 ; Decl = Information ->
1094 background_info([Information])
1095 ).
1096 is_type_definition(Declaration) :-
1097 is_type_definition(Declaration,Result),
1098 assert_type_definition(Result).
1100 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1101 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1103 is_type_definition(Declaration,Result) :-
1104 ( Declaration = (:- TDef) ->
1105 true
1106 ;
1107 Declaration = TDef
1108 ),
1109 TDef =.. [chr_type,TypeDef],
1110 ( TypeDef = (Name ---> Def) ->
1111 tdisj2list(Def,DefList),
1112 Result = typedef(Name,DefList)
1113 ; TypeDef = (Alias == Name) ->
1114 Result = alias(Alias,Name)
1115 ;
1116 Result = typedef(TypeDef,[]),
1117 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1118 ).
1120 %% tdisj2list(+Goal,-ListOfGoals) is det.
1121 %
1122 % no removal of fails, e.g. :- type bool ---> true ; fail.
1123 tdisj2list(Conj,L) :-
1124 tdisj2list(Conj,L,[]).
1126 tdisj2list(Conj,L,T) :-
1127 Conj = (G1;G2), !,
1128 tdisj2list(G1,L,T1),
1129 tdisj2list(G2,T1,T).
1130 tdisj2list(G,[G | T],T).
1133 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1134 %% parse_rule(+term,-pragma_rule) is semidet.
1135 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1136 parse_rule(RI,R) :- %% name @ rule
1137 RI = (Name @ RI2), !,
1138 rule(RI2,yes(Name),R).
1139 parse_rule(RI,R) :-
1140 rule(RI,no,R).
1142 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1143 %% parse_rule(+term,-pragma_rule) is semidet.
1144 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1145 rule(RI,Name,R) :-
1146 RI = (RI2 pragma P), !, %% pragmas
1147 ( var(P) ->
1148 Ps = [_] % intercept variable
1149 ;
1150 conj2list(P,Ps)
1151 ),
1152 inc_rule_count(RuleCount),
1153 R = pragma(R1,IDs,Ps,Name,RuleCount),
1154 is_rule(RI2,R1,IDs,R).
1155 rule(RI,Name,R) :-
1156 inc_rule_count(RuleCount),
1157 R = pragma(R1,IDs,[],Name,RuleCount),
1158 is_rule(RI,R1,IDs,R).
1160 is_rule(RI,R,IDs,RC) :- %% propagation rule
1161 RI = (H ==> B), !,
1162 conj2list(H,Head2i),
1163 get_ids(Head2i,IDs2,Head2,RC),
1164 IDs = ids([],IDs2),
1165 ( B = (G | RB) ->
1166 R = rule([],Head2,G,RB)
1167 ;
1168 R = rule([],Head2,true,B)
1169 ).
1170 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1171 RI = (H <=> B), !,
1172 ( B = (G | RB) ->
1173 Guard = G,
1174 Body = RB
1175 ; Guard = true,
1176 Body = B
1177 ),
1178 ( H = (H1 \ H2) ->
1179 conj2list(H1,Head2i),
1180 conj2list(H2,Head1i),
1181 get_ids(Head2i,IDs2,Head2,0,N,RC),
1182 get_ids(Head1i,IDs1,Head1,N,_,RC),
1183 IDs = ids(IDs1,IDs2)
1184 ; conj2list(H,Head1i),
1185 Head2 = [],
1186 get_ids(Head1i,IDs1,Head1,RC),
1187 IDs = ids(IDs1,[])
1188 ),
1189 R = rule(Head1,Head2,Guard,Body).
1191 get_ids(Cs,IDs,NCs,RC) :-
1192 get_ids(Cs,IDs,NCs,0,_,RC).
1194 get_ids([],[],[],N,N,_).
1195 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1196 ( C = (NC # N1) ->
1197 ( var(N1) ->
1198 N1 = N
1199 ;
1200 check_direct_pragma(N1,N,RC)
1201 )
1202 ;
1203 NC = C
1204 ),
1205 M is N + 1,
1206 get_ids(Cs,IDs,NCs, M,NN,RC).
1208 check_direct_pragma(passive,Id,PragmaRule) :- !,
1209 PragmaRule = pragma(_,_,_,_,RuleNb),
1210 passive(RuleNb,Id).
1211 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1212 ( direct_pragma(FullPragma),
1213 atom_concat(Abbrev,Remainder,FullPragma) ->
1214 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1215 ;
1216 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1217 ).
1219 direct_pragma(passive).
1221 is_module_declaration((:- module(Mod)),Mod).
1222 is_module_declaration((:- module(Mod,_)),Mod).
1224 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1226 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1227 % Add constraints
1228 add_constraints([]).
1229 add_constraints([C|Cs]) :-
1230 max_occurrence(C,0),
1231 C = _/A,
1232 length(Mode,A),
1233 set_elems(Mode,?),
1234 constraint_mode(C,Mode),
1235 add_constraints(Cs).
1237 % Add rules
1238 add_rules([]).
1239 add_rules([Rule|Rules]) :-
1240 Rule = pragma(_,_,_,_,RuleNb),
1241 rule(RuleNb,Rule),
1242 add_rules(Rules).
1244 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1246 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1247 %% Some input verification:
1249 check_declared_constraints(Constraints) :-
1250 tree_set_empty(Acc),
1251 check_declared_constraints(Constraints,Acc).
1253 check_declared_constraints([],_).
1254 check_declared_constraints([C|Cs],Acc) :-
1255 ( tree_set_memberchk(C,Acc) ->
1256 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1257 ;
1258 true
1259 ),
1260 tree_set_add(Acc,C,NAcc),
1261 check_declared_constraints(Cs,NAcc).
1263 %% - all constraints in heads are declared constraints
1264 %% - all passive pragmas refer to actual head constraints
1266 check_rules(PragmaRules,AstRules,Decls) :-
1267 maplist(check_rule(Decls),PragmaRules,AstRules).
1269 check_rule(Decls,PragmaRule,AstRule) :-
1270 PragmaRule = pragma(_Rule,_IDs,Pragmas,_Name,_N),
1271 check_ast_rule_indexing(AstRule,PragmaRule),
1272 % check_rule_indexing(PragmaRule),
1273 check_ast_trivial_propagation_rule(AstRule,PragmaRule),
1274 % check_trivial_propagation_rule(PragmaRule),
1275 check_ast_head_constraints(AstRule,Decls,PragmaRule),
1276 % Rule = rule(H1,H2,_,_),
1277 % check_head_constraints(H1,Decls,PragmaRule),
1278 % check_head_constraints(H2,Decls,PragmaRule),
1279 check_pragmas(Pragmas,PragmaRule).
1281 %-------------------------------------------------------------------------------
1282 % Make all heads passive in trivial propagation rule
1283 % ... ==> ... | true.
1284 check_ast_trivial_propagation_rule(AstRule,PragmaRule) :-
1285 AstRule = ast_rule(AstHead,_,_,AstBody,_),
1286 ( AstHead = propagation(_),
1287 Body == [] ->
1288 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1289 set_rule_passive(PragmaRule)
1290 ;
1291 true
1292 ).
1294 set_rule_passive(PragmaRule) :-
1295 PragmaRule = pragma(_Rule,_IDs,_Pragmas,_Name,RuleNb),
1296 set_all_passive(RuleNb).
1298 check_trivial_propagation_rule(PragmaRule) :-
1299 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1300 ( Rule = rule([],_,_,true) ->
1301 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1302 set_all_passive(RuleNb)
1303 ;
1304 true
1305 ).
1307 %-------------------------------------------------------------------------------
1308 check_ast_head_constraints(ast_rule(AstHead,_,_,_,_),Decls,PragmaRule) :-
1309 check_ast_head_constraints_(AstHead,Decls,PragmaRule).
1311 check_ast_head_constraints_(simplification(AstConstraints),Decls,PragmaRule) :-
1312 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints).
1313 check_ast_head_constraints_(propagation(AstConstraints),Decls,PragmaRule) :-
1314 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints).
1315 check_ast_head_constraints_(simpagation(AstConstraints1,AstConstraints2),Decls,PragmaRule) :-
1316 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints1).
1317 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints2).
1319 check_ast_head_constraint(Decls,PragmaRule,chr_constraint(Symbol,_,Constraint)) :-
1320 ( memberchk(Symbol,Decls) ->
1321 true
1322 ;
1323 chr_error(syntax(Constraint),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1324 ).
1326 check_head_constraints([],_,_).
1327 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1328 functor(Constr,F,A),
1329 ( memberchk(F/A,Decls) ->
1330 check_head_constraints(Rest,Decls,PragmaRule)
1331 ;
1332 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1333 ).
1334 %-------------------------------------------------------------------------------
1336 check_pragmas([],_).
1337 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1338 check_pragma(Pragma,PragmaRule),
1339 check_pragmas(Pragmas,PragmaRule).
1341 check_pragma(Pragma,PragmaRule) :-
1342 var(Pragma), !,
1343 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1344 check_pragma(passive(ID), PragmaRule) :-
1345 !,
1346 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1347 ( memberchk_eq(ID,IDs1) ->
1348 true
1349 ; memberchk_eq(ID,IDs2) ->
1350 true
1351 ;
1352 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1353 ),
1354 passive(RuleNb,ID).
1356 check_pragma(mpassive(IDs), PragmaRule) :-
1357 !,
1358 PragmaRule = pragma(_,_,_,_,RuleNb),
1359 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1360 maplist(passive(RuleNb),IDs).
1362 check_pragma(Pragma, PragmaRule) :-
1363 Pragma = already_in_heads,
1364 !,
1365 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1367 check_pragma(Pragma, PragmaRule) :-
1368 Pragma = already_in_head(_),
1369 !,
1370 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1372 check_pragma(Pragma, PragmaRule) :-
1373 Pragma = no_history,
1374 !,
1375 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1376 PragmaRule = pragma(_,_,_,_,N),
1377 no_history(N).
1379 check_pragma(Pragma, PragmaRule) :-
1380 Pragma = history(HistoryName,IDs),
1381 !,
1382 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1383 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1384 ( IDs1 \== [] ->
1385 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1386 ; \+ atom(HistoryName) ->
1387 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1388 ; \+ is_set(IDs) ->
1389 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1390 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1391 history(RuleNb,HistoryName,IDs)
1392 ;
1393 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1394 ).
1395 check_pragma(Pragma,PragmaRule) :-
1396 Pragma = line_number(LineNumber),
1397 !,
1398 PragmaRule = pragma(_,_,_,_,RuleNb),
1399 line_number(RuleNb,LineNumber).
1401 check_history_pragma_ids([], _, _).
1402 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1403 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1404 check_history_pragma_ids(IDs,IDs1,IDs2).
1406 check_pragma(Pragma,PragmaRule) :-
1407 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1409 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1410 %% no_history(+RuleNb) is det.
1411 :- chr_constraint no_history/1.
1412 :- chr_option(mode,no_history(+)).
1413 :- chr_option(type_declaration,no_history(int)).
1415 %% has_no_history(+RuleNb) is semidet.
1416 :- chr_constraint has_no_history/1.
1417 :- chr_option(mode,has_no_history(+)).
1418 :- chr_option(type_declaration,has_no_history(int)).
1420 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1421 has_no_history(_) <=> fail.
1423 :- chr_constraint history/3.
1424 :- chr_option(mode,history(+,+,+)).
1425 :- chr_option(type_declaration,history(any,any,list)).
1427 :- chr_constraint named_history/3.
1429 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1430 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1432 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1433 length(IDs1,L1), length(IDs2,L2),
1434 ( L1 \== L2 ->
1435 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1436 ;
1437 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1438 ).
1440 test_named_history_id_pairs(_, [], _, []).
1441 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1442 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1443 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1445 :- chr_constraint test_named_history_id_pair/4.
1446 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1448 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1449 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1450 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1451 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1453 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1454 named_history(_,_,_) <=> fail.
1456 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1459 format_rule(PragmaRule) :-
1460 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1461 ( MaybeName = yes(Name) ->
1462 write('rule '), write(Name)
1463 ;
1464 write('rule number '), write(RuleNumber)
1465 ),
1466 get_line_number(RuleNumber,LineNumber),
1467 write(' (line '),
1468 write(LineNumber),
1469 write(')').
1471 check_ast_rule_indexing(AstRule,PragmaRule) :-
1472 AstRule = ast_rule(AstHead,AstGuard,_,_,_),
1473 tree_set_empty(EmptyVarSet),
1474 ast_head_variables(AstHead,EmptyVarSet,VarSet),
1475 ast_remove_anti_monotonic_guards(AstGuard,VarSet,MonotonicAstGuard),
1476 ast_term_list_variables(MonotonicAstGuard,EmptyVarSet,GuardVarSet),
1477 check_ast_head_indexing(AstHead,GuardVarSet),
1478 % check_indexing(H1,NG-H2),
1479 % check_indexing(H2,NG-H1),
1480 % EXPERIMENT
1481 ( chr_pp_flag(term_indexing,on) ->
1482 PragmaRule = pragma(Rule,_,_,_,_),
1483 Rule = rule(H1,H2,G,_),
1484 term_variables(H1-H2,HeadVars),
1485 remove_anti_monotonic_guards(G,HeadVars,NG),
1486 term_variables(NG,GuardVariables),
1487 append(H1,H2,Heads),
1488 check_specs_indexing(Heads,GuardVariables,Specs)
1489 ;
1490 true
1491 ).
1493 check_ast_head_indexing(simplification(H1),VarSet) :-
1494 check_ast_indexing(H1,VarSet).
1495 check_ast_head_indexing(propagation(H2),VarSet) :-
1496 check_ast_indexing(H2,VarSet).
1497 check_ast_head_indexing(simpagation(H1,H2),VarSet) :-
1498 ast_constraint_list_variables(H2,VarSet,VarSet1),
1499 check_ast_indexing(H1,VarSet1),
1500 ast_constraint_list_variables(H1,VarSet,VarSet2),
1501 check_ast_indexing(H2,VarSet2).
1503 check_rule_indexing(PragmaRule) :-
1504 PragmaRule = pragma(Rule,_,_,_,_),
1505 Rule = rule(H1,H2,G,_),
1506 term_variables(H1-H2,HeadVars),
1507 remove_anti_monotonic_guards(G,HeadVars,NG),
1508 check_indexing(H1,NG-H2),
1509 check_indexing(H2,NG-H1),
1510 % EXPERIMENT
1511 ( chr_pp_flag(term_indexing,on) ->
1512 term_variables(NG,GuardVariables),
1513 append(H1,H2,Heads),
1514 check_specs_indexing(Heads,GuardVariables,Specs)
1515 ;
1516 true
1517 ).
1519 :- chr_constraint indexing_spec/2.
1520 :- chr_option(mode,indexing_spec(+,+)).
1522 :- chr_constraint get_indexing_spec/2.
1523 :- chr_option(mode,get_indexing_spec(+,-)).
1526 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1527 get_indexing_spec(_,Spec) <=> Spec = [].
1529 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1530 <=>
1531 append(Specs1,Specs2,Specs),
1532 indexing_spec(FA,Specs).
1534 remove_anti_monotonic_guards(G,Vars,NG) :-
1535 conj2list(G,GL),
1536 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1537 list2conj(NGL,NG).
1539 remove_anti_monotonic_guard_list([],_,[]).
1540 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1541 ( G = var(X), memberchk_eq(X,Vars) ->
1542 NGs = RGs
1543 ;
1544 NGs = [G|RGs]
1545 ),
1546 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1548 ast_remove_anti_monotonic_guards([],_,[]).
1549 ast_remove_anti_monotonic_guards([G|Gs],VarSet,NGs) :-
1550 ( G = compound(var,1,[X],_),
1551 ast_var_memberchk(X,VarSet) ->
1552 NGs = RGs
1553 ;
1554 NGs = [G|RGs]
1555 ),
1556 ast_remove_anti_monotonic_guards(Gs,VarSet,RGs).
1557 %-------------------------------------------------------------------------------
1559 check_ast_indexing([],_).
1560 check_ast_indexing([Head|Heads],VarSet) :-
1561 Head = chr_constraint(Symbol,Args,_Constraint),
1562 ast_constraint_list_variables(Heads,VarSet,VarSet1),
1563 check_ast_indexing(Args,1,Symbol,VarSet1),
1564 ast_constraint_variables(Head,VarSet,NVarSet),
1565 check_ast_indexing(Heads,NVarSet).
1567 check_ast_indexing([],_,_,_).
1568 check_ast_indexing([Arg|Args],I,Symbol,VarSet) :-
1569 ( is_indexed_argument(Symbol,I) ->
1570 true
1571 ; ast_nonvar(Arg) ->
1572 indexed_argument(Symbol,I)
1573 ; % ast_var(Arg) ->
1574 ast_term_list_variables(Args,VarSet,VarSet1),
1575 ( ast_var_memberchk(Arg,VarSet1) ->
1576 indexed_argument(Symbol,I)
1577 ;
1578 true
1579 )
1580 ),
1581 J is I + 1,
1582 ast_term_variables(Arg,VarSet,NVarSet),
1583 check_ast_indexing(Args,J,Symbol,NVarSet).
1585 % check_indexing(list(chr_constraint),variables)
1586 check_indexing([],_).
1587 check_indexing([Head|Heads],Other) :-
1588 functor(Head,F,A),
1589 Head =.. [_|Args],
1590 term_variables(Heads-Other,OtherVars),
1591 check_indexing(Args,1,F/A,OtherVars),
1592 check_indexing(Heads,[Head|Other]).
1594 check_indexing([],_,_,_).
1595 check_indexing([Arg|Args],I,FA,OtherVars) :-
1596 ( is_indexed_argument(FA,I) ->
1597 true
1598 ; nonvar(Arg) ->
1599 indexed_argument(FA,I)
1600 ; % var(Arg) ->
1601 term_variables(Args,ArgsVars),
1602 append(ArgsVars,OtherVars,RestVars),
1603 ( memberchk_eq(Arg,RestVars) ->
1604 indexed_argument(FA,I)
1605 ;
1606 true
1607 )
1608 ),
1609 J is I + 1,
1610 term_variables(Arg,NVars),
1611 append(NVars,OtherVars,NOtherVars),
1612 check_indexing(Args,J,FA,NOtherVars).
1613 %-------------------------------------------------------------------------------
1615 check_specs_indexing([],_,[]).
1616 check_specs_indexing([Head|Heads],Variables,Specs) :-
1617 Specs = [Spec|RSpecs],
1618 term_variables(Heads,OtherVariables,Variables),
1619 check_spec_indexing(Head,OtherVariables,Spec),
1620 term_variables(Head,NVariables,Variables),
1621 check_specs_indexing(Heads,NVariables,RSpecs).
1623 check_spec_indexing(Head,OtherVariables,Spec) :-
1624 functor(Head,F,A),
1625 Spec = spec(F,A,ArgSpecs),
1626 Head =.. [_|Args],
1627 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1628 indexing_spec(F/A,[ArgSpecs]).
1630 check_args_spec_indexing([],_,_,[]).
1631 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1632 term_variables(Args,Variables,OtherVariables),
1633 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1634 ArgSpecs = [ArgSpec|RArgSpecs]
1635 ;
1636 ArgSpecs = RArgSpecs
1637 ),
1638 J is I + 1,
1639 term_variables(Arg,NOtherVariables,OtherVariables),
1640 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1642 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1643 ( var(Arg) ->
1644 memberchk_eq(Arg,Variables),
1645 ArgSpec = specinfo(I,any,[])
1646 ;
1647 functor(Arg,F,A),
1648 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1649 Arg =.. [_|Args],
1650 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1651 ).
1653 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1655 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1656 % Occurrences
1658 add_occurrences(PragmaRules,AstRules) :-
1659 maplist(add_rule_occurrences,PragmaRules,AstRules).
1661 add_rule_occurrences(PragmaRule,AstRule) :-
1662 PragmaRule = pragma(_,IDs,_,_,Nb),
1663 AstRule = ast_rule(AstHead,_,_,_,_),
1664 add_head_occurrences(AstHead,IDs,Nb).
1666 add_head_occurrences(simplification(H1),ids(IDs1,_),Nb) :-
1667 maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1).
1668 add_head_occurrences(propagation(H2),ids(_,IDs2),Nb) :-
1669 maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2).
1670 add_head_occurrences(simpagation(H1,H2),ids(IDs1,IDs2),Nb) :-
1671 maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1),
1672 maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2).
1674 add_constraint_occurrence(Nb,OccType,Constraint,ID) :-
1675 Constraint = chr_constraint(Symbol,_,_),
1676 new_occurrence(Symbol,Nb,ID,OccType).
1678 % add_occurrences([],[]).
1679 % add_occurrences([Rule|Rules],[]) :-
1680 % Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1681 % add_occurrences(H1,IDs1,simplification,Nb),
1682 % add_occurrences(H2,IDs2,propagation,Nb),
1683 % add_occurrences(Rules).
1684 %
1685 % add_occurrences([],[],_,_).
1686 % add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1687 % functor(H,F,A),
1688 % FA = F/A,
1689 % new_occurrence(FA,RuleNb,ID,Type),
1690 % add_occurrences(Hs,IDs,Type,RuleNb).
1692 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1694 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1695 % Observation Analysis
1696 %
1697 % CLASSIFICATION
1698 %
1699 %
1700 %
1701 %
1702 %
1703 %
1705 :- chr_constraint observation_analysis/1.
1706 :- chr_option(mode, observation_analysis(+)).
1708 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1709 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1710 ( chr_pp_flag(store_in_guards, on) ->
1711 observation_analysis(RuleNb, Guard, guard, Cs)
1712 ;
1713 true
1714 ),
1715 observation_analysis(RuleNb, Body, body, Cs)
1717 pragma passive(Id).
1718 observation_analysis(_) <=> true.
1720 observation_analysis(RuleNb, Term, GB, Cs) :-
1721 ( all_spawned(RuleNb,GB) ->
1722 true
1723 ; var(Term) ->
1724 spawns_all(RuleNb,GB)
1725 ; Term = true ->
1726 true
1727 ; Term = fail ->
1728 true
1729 ; Term = '!' ->
1730 true
1731 ; Term = (T1,T2) ->
1732 observation_analysis(RuleNb,T1,GB,Cs),
1733 observation_analysis(RuleNb,T2,GB,Cs)
1734 ; Term = (T1;T2) ->
1735 observation_analysis(RuleNb,T1,GB,Cs),
1736 observation_analysis(RuleNb,T2,GB,Cs)
1737 ; Term = (T1->T2) ->
1738 observation_analysis(RuleNb,T1,GB,Cs),
1739 observation_analysis(RuleNb,T2,GB,Cs)
1740 ; Term = (\+ T) ->
1741 observation_analysis(RuleNb,T,GB,Cs)
1742 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1743 spawns(RuleNb,GB,F/A)
1744 ; Term = (_ = _) ->
1745 spawns_all_triggers(RuleNb,GB)
1746 ; Term = (_ is _) ->
1747 spawns_all_triggers(RuleNb,GB)
1748 ; builtin_binds_b(Term,Vars) ->
1749 ( Vars == [] ->
1750 true
1751 ;
1752 spawns_all_triggers(RuleNb,GB)
1753 )
1754 ;
1755 spawns_all(RuleNb,GB)
1756 ).
1758 :- chr_constraint spawns/3.
1759 :- chr_option(mode, spawns(+,+,+)).
1760 :- chr_type spawns_type ---> guard ; body.
1761 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1763 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1764 :- chr_option(mode, spawns_all(+,+)).
1765 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1766 :- chr_option(mode, spawns_all_triggers(+,+)).
1767 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1769 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1770 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1771 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1772 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1773 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1774 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1776 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1777 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1778 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1779 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1781 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1782 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1784 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1785 \
1786 spawns(RuleNb1,GB,C1)
1787 <=>
1788 \+ is_passive(RuleNb2,O)
1789 |
1790 spawns_all(RuleNb1,GB)
1791 pragma
1792 passive(Id).
1794 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1795 ==>
1796 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1797 \+ is_passive(RuleNb2,O), may_trigger(C1)
1798 |
1799 spawns_all_triggers_implies_spawns_all
1800 pragma
1801 passive(Id).
1803 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1804 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1805 spawns_all_triggers_implies_spawns_all \
1806 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1808 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1809 \
1810 spawns(RuleNb1,GB,C1)
1811 <=>
1812 may_trigger(C1),
1813 \+ is_passive(RuleNb2,O)
1814 |
1815 spawns_all_triggers(RuleNb1,GB)
1816 pragma
1817 passive(Id).
1819 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1820 spawns(RuleNb1,GB,C1)
1821 ==>
1822 \+ may_trigger(C1),
1823 \+ is_passive(RuleNb2,O)
1824 |
1825 spawns_all_triggers(RuleNb1,GB)
1826 pragma
1827 passive(Id).
1829 % a bit dangerous this rule: could start propagating too much too soon?
1830 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1831 spawns(RuleNb1,GB,C1)
1832 ==>
1833 RuleNb1 \== RuleNb2, C1 \== C2,
1834 \+ is_passive(RuleNb2,O)
1835 |
1836 spawns(RuleNb1,GB,C2)
1837 pragma
1838 passive(Id).
1840 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1841 spawns_all_triggers(RuleNb1,GB)
1842 ==>
1843 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1844 |
1845 spawns(RuleNb1,GB,C2)
1846 pragma
1847 passive(Id).
1850 :- chr_constraint all_spawned/2.
1851 :- chr_option(mode, all_spawned(+,+)).
1852 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1853 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1854 all_spawned(RuleNb,GB) <=> fail.
1857 % Overview of the supported queries:
1858 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1859 % only succeeds if the occurrence is observed by the
1860 % guard resp. body (depending on the last argument) of its rule
1861 % is_observed(+functor/artiy, +occurrence_number, -)
1862 % succeeds if the occurrence is observed by either the guard or
1863 % the body of its rule
1864 % NOTE: the last argument is NOT bound by this query
1865 %
1866 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1867 % succeeds if the given constraint is observed by the given
1868 % guard resp. body
1869 % do_is_observed(+functor/artiy,+rule_number)
1870 % succeeds if the given constraint is observed by the given
1871 % rule (either its guard or its body)
1874 is_observed(C,O) :-
1875 is_observed(C,O,_),
1876 ai_is_observed(C,O).
1878 is_stored_in_guard(C,RuleNb) :-
1879 chr_pp_flag(store_in_guards, on),
1880 do_is_observed(C,RuleNb,guard).
1882 :- chr_constraint is_observed/3.
1883 :- chr_option(mode, is_observed(+,+,+)).
1884 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1885 is_observed(_,_,_) <=> fail. % this will not happen in practice
1888 :- chr_constraint do_is_observed/3.
1889 :- chr_option(mode, do_is_observed(+,+,?)).
1890 :- chr_constraint do_is_observed/2.
1891 :- chr_option(mode, do_is_observed(+,+)).
1893 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1895 % (1) spawns_all
1896 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1897 % and some non-passive occurrence of some (possibly other) constraint
1898 % exists in a rule (could be same rule) with at least one occurrence of C
1900 spawns_all(RuleNb,GB),
1901 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1902 \
1903 do_is_observed(C,RuleNb,GB)
1904 <=>
1905 \+ is_passive(RuleNb2,O)
1906 |
1907 true.
1909 spawns_all(RuleNb,_),
1910 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1911 \
1912 do_is_observed(C,RuleNb)
1913 <=>
1914 \+ is_passive(RuleNb2,O)
1915 |
1916 true.
1918 % (2) spawns
1919 % a constraint C is observed if the GB of the rule it occurs in spawns a
1920 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1921 % as an occurrence of C
1923 spawns(RuleNb,GB,C2),
1924 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1925 \
1926 do_is_observed(C,RuleNb,GB)
1927 <=>
1928 \+ is_passive(RuleNb2,O)
1929 |
1930 true.
1932 spawns(RuleNb,_,C2),
1933 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1934 \
1935 do_is_observed(C,RuleNb)
1936 <=>
1937 \+ is_passive(RuleNb2,O)
1938 |
1939 true.
1941 % (3) spawns_all_triggers
1942 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1943 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1944 % exists in a rule (could be same rule) with at least one occurrence of C
1946 spawns_all_triggers(RuleNb,GB),
1947 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1948 \
1949 do_is_observed(C,RuleNb,GB)
1950 <=>
1951 \+ is_passive(RuleNb2,O), may_trigger(C2)
1952 |
1953 true.
1955 spawns_all_triggers(RuleNb,_),
1956 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1957 \
1958 do_is_observed(C,RuleNb)
1959 <=>
1960 \+ is_passive(RuleNb2,O), may_trigger(C2)
1961 |
1962 true.
1964 % (4) conservativeness
1965 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1966 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1971 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1973 %%
1974 %% Generated predicates
1975 %% attach_$CONSTRAINT
1976 %% attach_increment
1977 %% detach_$CONSTRAINT
1978 %% attr_unify_hook
1980 %% attach_$CONSTRAINT
1981 generate_attach_detach_a_constraint_all([],[]).
1982 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1983 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1984 generate_attach_a_constraint(Constraint,Clauses1),
1985 generate_detach_a_constraint(Constraint,Clauses2)
1986 ;
1987 Clauses1 = [],
1988 Clauses2 = []
1989 ),
1990 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1991 append([Clauses1,Clauses2,Clauses3],Clauses).
1993 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1994 generate_attach_a_constraint_nil(Constraint,Clause1),
1995 generate_attach_a_constraint_cons(Constraint,Clause2).
1997 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1998 make_name('attach_',FA,Name),
1999 Atom =.. [Name,Vars,Susp].
2001 generate_attach_a_constraint_nil(FA,Clause) :-
2002 Clause = (Head :- true),
2003 attach_constraint_atom(FA,[],_,Head).
2005 generate_attach_a_constraint_cons(FA,Clause) :-
2006 Clause = (Head :- Body),
2007 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
2008 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
2009 Body = ( AttachBody, Subscribe, RecursiveCall ),
2010 get_max_constraint_index(N),
2011 ( N == 1 ->
2012 generate_attach_body_1(FA,Var,Susp,AttachBody)
2013 ;
2014 generate_attach_body_n(FA,Var,Susp,AttachBody)
2015 ),
2016 % SWI-Prolog specific code
2017 chr_pp_flag(solver_events,NMod),
2018 ( NMod \== none ->
2019 Args = [[Var|_],Susp],
2020 get_target_module(Mod),
2021 use_auxiliary_predicate(run_suspensions),
2022 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
2023 ;
2024 Subscribe = true
2025 ).
2027 generate_attach_body_1(FA,Var,Susp,Body) :-
2028 get_target_module(Mod),
2029 Body =
2030 ( get_attr(Var, Mod, Susps) ->
2031 put_attr(Var, Mod, [Susp|Susps])
2032 ;
2033 put_attr(Var, Mod, [Susp])
2034 ).
2036 generate_attach_body_n(F/A,Var,Susp,Body) :-
2037 chr_pp_flag(experiment,off), !,
2038 get_constraint_index(F/A,Position),
2039 get_max_constraint_index(Total),
2040 get_target_module(Mod),
2041 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
2042 singleton_attr(Total,Susp,Position,NewAttr3),
2043 Body =
2044 ( get_attr(Var,Mod,TAttr) ->
2045 AddGoal,
2046 put_attr(Var,Mod,NTAttr)
2047 ;
2048 put_attr(Var,Mod,NewAttr3)
2049 ), !.
2050 generate_attach_body_n(F/A,Var,Susp,Body) :-
2051 chr_pp_flag(experiment,on), !,
2052 get_constraint_index(F/A,Position),
2053 or_pattern(Position,Pattern),
2054 Position1 is Position + 1,
2055 get_max_constraint_index(Total),
2056 get_target_module(Mod),
2057 singleton_attr(Total,Susp,Position,NewAttr3),
2058 Body =
2059 ( get_attr(Var,Mod,TAttr) ->
2060 arg(1,TAttr,BitVector),
2061 arg(Position1,TAttr,Susps),
2062 NBitVector is BitVector \/ Pattern,
2063 setarg(1,TAttr,NBitVector),
2064 setarg(Position1,TAttr,[Susp|Susps])
2065 ;
2066 put_attr(Var,Mod,NewAttr3)
2067 ), !.
2069 %% detach_$CONSTRAINT
2070 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
2071 generate_detach_a_constraint_nil(Constraint,Clause1),
2072 generate_detach_a_constraint_cons(Constraint,Clause2).
2074 detach_constraint_atom(FA,Vars,Susp,Atom) :-
2075 make_name('detach_',FA,Name),
2076 Atom =.. [Name,Vars,Susp].
2078 generate_detach_a_constraint_nil(FA,Clause) :-
2079 Clause = ( Head :- true),
2080 detach_constraint_atom(FA,[],_,Head).
2082 generate_detach_a_constraint_cons(FA,Clause) :-
2083 Clause = (Head :- Body),
2084 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
2085 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
2086 Body = ( DetachBody, RecursiveCall ),
2087 get_max_constraint_index(N),
2088 ( N == 1 ->
2089 generate_detach_body_1(FA,Var,Susp,DetachBody)
2090 ;
2091 generate_detach_body_n(FA,Var,Susp,DetachBody)
2092 ).
2094 generate_detach_body_1(FA,Var,Susp,Body) :-
2095 get_target_module(Mod),
2096 Body =
2097 ( get_attr(Var,Mod,Susps) ->
2098 'chr sbag_del_element'(Susps,Susp,NewSusps),
2099 ( NewSusps == [] ->
2100 del_attr(Var,Mod)
2101 ;
2102 put_attr(Var,Mod,NewSusps)
2103 )
2104 ;
2105 true
2106 ).
2108 generate_detach_body_n(F/A,Var,Susp,Body) :-
2109 get_constraint_index(F/A,Position),
2110 get_max_constraint_index(Total),
2111 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
2112 get_target_module(Mod),
2113 Body =
2114 ( get_attr(Var,Mod,TAttr) ->
2115 RemGoal
2116 ;
2117 true
2118 ), !.
2120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2121 %-------------------------------------------------------------------------------
2122 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
2123 :- chr_constraint generate_indexed_variables_body/4.
2124 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
2125 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
2126 %-------------------------------------------------------------------------------
2127 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
2128 get_indexing_spec(F/A,Specs),
2129 ( chr_pp_flag(term_indexing,on) ->
2130 spectermvars(Specs,Args,F,A,Body,Vars)
2131 ;
2132 get_constraint_type_det(F/A,ArgTypes),
2133 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
2134 ( MaybeBody == empty ->
2135 Body = true,
2136 Vars = []
2137 ; N == 0 ->
2138 ( Args = [Term] ->
2139 true
2140 ;
2141 Term =.. [term|Args]
2142 ),
2143 Body = term_variables(Term,Vars)
2144 ;
2145 MaybeBody = Body
2146 )
2147 ).
2148 generate_indexed_variables_body(FA,_,_,_) <=>
2149 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
2150 %===============================================================================
2152 create_indexed_variables_body([],[],[],_,_,_,empty,0).
2153 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
2154 J is I + 1,
2155 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
2156 ( Mode == (?),
2157 is_indexed_argument(FA,I) ->
2158 ( atomic_type(Type) ->
2159 Body =
2160 (
2161 ( var(V) ->
2162 Vars = [V|Tail]
2163 ;
2164 Vars = Tail
2165 ),
2166 Continuation
2167 ),
2168 ( RBody == empty ->
2169 Continuation = true, Tail = []
2170 ;
2171 Continuation = RBody
2172 )
2173 ;
2174 ( RBody == empty ->
2175 Body = term_variables(V,Vars)
2176 ;
2177 Body = (term_variables(V,Vars,Tail),RBody)
2178 )
2179 ),
2180 N = M
2181 ; Mode == (-), is_indexed_argument(FA,I) ->
2182 ( RBody == empty ->
2183 Body = (Vars = [V])
2184 ;
2185 Body = (Vars = [V|Tail],RBody)
2186 ),
2187 N is M + 1
2188 ;
2189 Vars = Tail,
2190 Body = RBody,
2191 N is M + 1
2192 ).
2193 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2194 % EXPERIMENTAL
2195 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2196 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2198 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2199 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2200 Goal = (ArgGoal,RGoal),
2201 argspecs(Specs,I,TempArgSpecs,RSpecs),
2202 merge_argspecs(TempArgSpecs,ArgSpecs),
2203 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2204 J is I + 1,
2205 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2207 argspecs([],_,[],[]).
2208 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2209 argspecs(Rest,I,ArgSpecs,RestSpecs).
2210 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2211 ( I == J ->
2212 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2213 ( Specs = [] ->
2214 RRestSpecs = RestSpecs
2215 ;
2216 RestSpecs = [Specs|RRestSpecs]
2217 )
2218 ;
2219 ArgSpecs = RArgSpecs,
2220 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2221 ),
2222 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2224 merge_argspecs(In,Out) :-
2225 sort(In,Sorted),
2226 merge_argspecs_(Sorted,Out).
2228 merge_argspecs_([],[]).
2229 merge_argspecs_([X],R) :- !, R = [X].
2230 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2231 ( (F1 == any ; F2 == any) ->
2232 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2233 ; F1 == F2 ->
2234 append(A1,A2,A),
2235 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2236 ;
2237 R = [specinfo(I,F1,A1)|RR],
2238 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2239 ).
2241 arggoal(List,Arg,Goal,L,T) :-
2242 ( List == [] ->
2243 L = T,
2244 Goal = true
2245 ; List = [specinfo(_,any,_)] ->
2246 Goal = term_variables(Arg,L,T)
2247 ;
2248 Goal =
2249 ( var(Arg) ->
2250 L = [Arg|T]
2251 ;
2252 Cases
2253 ),
2254 arggoal_cases(List,Arg,L,T,Cases)
2255 ).
2257 arggoal_cases([],_,L,T,L=T).
2258 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2259 ( ArgSpecs == [] ->
2260 Cases = RCases
2261 ; ArgSpecs == [[]] ->
2262 Cases = RCases
2263 ; FA = F/A ->
2264 Cases = (Case ; RCases),
2265 functor(Term,F,A),
2266 Term =.. [_|Args],
2267 Case = (Arg = Term -> ArgsGoal),
2268 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2269 ),
2270 arggoal_cases(Rest,Arg,L,T,RCases).
2271 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2273 generate_extra_clauses(Constraints,List) :-
2274 generate_activate_clauses(Constraints,List,Tail0),
2275 generate_remove_clauses(Constraints,Tail0,Tail1),
2276 generate_allocate_clauses(Constraints,Tail1,Tail2),
2277 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2278 generate_novel_production(Tail3,Tail4),
2279 generate_extend_history(Tail4,Tail5),
2280 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2281 generate_empty_named_history_initialisations(Tail6,Tail7),
2282 Tail7 = [].
2284 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2285 % remove_constraint_internal/[1/3]
2287 generate_remove_clauses([],List,List).
2288 generate_remove_clauses([C|Cs],List,Tail) :-
2289 generate_remove_clause(C,List,List1),
2290 generate_remove_clauses(Cs,List1,Tail).
2292 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2293 uses_state(Constraint,removed),
2294 ( chr_pp_flag(inline_insertremove,off) ->
2295 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2296 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2297 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2298 ;
2299 delay_phase_end(validate_store_type_assumptions,
2300 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2301 )
2302 ).
2304 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2305 make_name('$remove_constraint_internal_',Constraint,Name),
2306 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2307 Goal =.. [Name, Susp,Delete]
2308 ;
2309 Goal =.. [Name,Susp,Agenda,Delete]
2310 ).
2312 generate_remove_clause(Constraint,List,Tail) :-
2313 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2314 List = [RemoveClause|Tail],
2315 RemoveClause = (Head :- RemoveBody),
2316 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2317 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2318 ;
2319 List = Tail
2320 ).
2322 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2323 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2324 ( Role == active ->
2325 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2326 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2327 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2328 ; Role == partner ->
2329 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2330 GetStateValue = true,
2331 MaybeDelete = DeleteYes
2332 ),
2333 RemoveBody =
2334 (
2335 GetState,
2336 GetStateValue,
2337 UpdateState,
2338 MaybeDelete
2339 )
2340 ;
2341 static_suspension_term(Constraint,Susp2),
2342 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2343 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2344 ( chr_pp_flag(debugable,on) ->
2345 Constraint = Functor / _,
2346 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2347 ;
2348 true
2349 ),
2350 ( Role == active ->
2351 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2352 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2353 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2354 ; Role == partner ->
2355 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2356 GetStateValue = true,
2357 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2358 ),
2359 RemoveBody =
2360 (
2361 Susp = Susp2,
2362 GetStateValue,
2363 UpdateState,
2364 MaybeDelete
2365 )
2366 ).
2368 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2369 % activate_constraint/4
2371 generate_activate_clauses([],List,List).
2372 generate_activate_clauses([C|Cs],List,Tail) :-
2373 generate_activate_clause(C,List,List1),
2374 generate_activate_clauses(Cs,List1,Tail).
2376 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2377 ( chr_pp_flag(inline_insertremove,off) ->
2378 use_auxiliary_predicate(activate_constraint,Constraint),
2379 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2380 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2381 ;
2382 delay_phase_end(validate_store_type_assumptions,
2383 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2384 )
2385 ).
2387 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2388 make_name('$activate_constraint_',Constraint,Name),
2389 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2390 Goal =.. [Name,Store, Susp]
2391 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2392 Goal =.. [Name,Store, Susp, Generation]
2393 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2394 Goal =.. [Name,Store, Vars, Susp, Generation]
2395 ;
2396 Goal =.. [Name,Store, Vars, Susp]
2397 ).
2399 generate_activate_clause(Constraint,List,Tail) :-
2400 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2401 List = [Clause|Tail],
2402 Clause = (Head :- Body),
2403 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2404 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2405 ;
2406 List = Tail
2407 ).
2409 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2410 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2411 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2412 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2413 ;
2414 GenerationHandling = true
2415 ),
2416 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2417 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2418 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2419 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2420 ;
2421 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2422 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2423 chr_none_locked(Vars,NoneLocked),
2424 if_used_state(Constraint,not_stored_yet,
2425 ( State == not_stored_yet ->
2426 ArgumentsGoal,
2427 IndexedVariablesBody,
2428 NoneLocked,
2429 StoreYes
2430 ;
2431 % Vars = [],
2432 StoreNo
2433 ),
2434 % (Vars = [],StoreNo),StoreVarsGoal)
2435 StoreNo,StoreVarsGoal)
2436 ),
2437 Body =
2438 (
2439 GetState,
2440 GetStateValue,
2441 UpdateState,
2442 GenerationHandling,
2443 StoreVarsGoal
2444 ).
2445 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2446 % allocate_constraint/4
2448 generate_allocate_clauses([],List,List).
2449 generate_allocate_clauses([C|Cs],List,Tail) :-
2450 generate_allocate_clause(C,List,List1),
2451 generate_allocate_clauses(Cs,List1,Tail).
2453 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2454 uses_state(Constraint,not_stored_yet),
2455 ( chr_pp_flag(inline_insertremove,off) ->
2456 use_auxiliary_predicate(allocate_constraint,Constraint),
2457 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2458 ;
2459 Goal = (Susp = Suspension, Goal0),
2460 delay_phase_end(validate_store_type_assumptions,
2461 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2462 )
2463 ).
2465 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2466 make_name('$allocate_constraint_',Constraint,Name),
2467 Goal =.. [Name,Susp|Args].
2469 generate_allocate_clause(Constraint,List,Tail) :-
2470 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2471 List = [Clause|Tail],
2472 Clause = (Head :- Body),
2473 Constraint = _/A,
2474 length(Args,A),
2475 allocate_constraint_atom(Constraint,Susp,Args,Head),
2476 allocate_constraint_body(Constraint,Susp,Args,Body)
2477 ;
2478 List = Tail
2479 ).
2481 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2482 static_suspension_term(Constraint,Suspension),
2483 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2484 ( chr_pp_flag(debugable,on) ->
2485 Constraint = Functor / _,
2486 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2487 ;
2488 true
2489 ),
2490 ( chr_pp_flag(debugable,on) ->
2491 ( may_trigger(Constraint) ->
2492 append(Args,[Susp],VarsSusp),
2493 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2494 get_target_module(Mod),
2495 Continuation = Mod : ContinuationGoal
2496 ;
2497 Continuation = true
2498 ),
2499 Init = (Susp = Suspension),
2500 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2501 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2502 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2503 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2504 Susp = Suspension, Init = true, CreateContinuation = true
2505 ;
2506 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2507 ),
2508 ( uses_history(Constraint) ->
2509 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2510 ;
2511 CreateHistory = true
2512 ),
2513 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2514 ( has_suspension_field(Constraint,id) ->
2515 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2516 gen_id(Id,GenID)
2517 ;
2518 GenID = true
2519 ),
2520 Body =
2521 (
2522 Init,
2523 CreateContinuation,
2524 CreateGeneration,
2525 CreateHistory,
2526 CreateState,
2527 GenID
2528 ).
2530 gen_id(Id,'chr gen_id'(Id)).
2531 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2532 % insert_constraint_internal
2534 generate_insert_constraint_internal_clauses([],List,List).
2535 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2536 generate_insert_constraint_internal_clause(C,List,List1),
2537 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2539 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2540 ( chr_pp_flag(inline_insertremove,off) ->
2541 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2542 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2543 ;
2544 delay_phase_end(validate_store_type_assumptions,
2545 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2546 )
2547 ).
2550 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2551 insert_constraint_internal_constraint_name(Constraint,Name),
2552 ( chr_pp_flag(debugable,on) ->
2553 Goal =.. [Name, Vars, Self, Closure | Args]
2554 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2555 Goal =.. [Name,Self | Args]
2556 ;
2557 Goal =.. [Name,Vars, Self | Args]
2558 ).
2560 insert_constraint_internal_constraint_name(Constraint,Name) :-
2561 make_name('$insert_constraint_internal_',Constraint,Name).
2563 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2564 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2565 List = [Clause|Tail],
2566 Clause = (Head :- Body),
2567 Constraint = _/A,
2568 length(Args,A),
2569 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2570 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2571 ;
2572 List = Tail
2573 ).
2576 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2577 static_suspension_term(Constraint,Suspension),
2578 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2579 ( chr_pp_flag(debugable,on) ->
2580 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2581 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2582 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2583 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2584 ;
2585 CreateGeneration = true
2586 ),
2587 ( chr_pp_flag(debugable,on) ->
2588 Constraint = Functor / _,
2589 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2590 ;
2591 true
2592 ),
2593 ( uses_history(Constraint) ->
2594 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2595 ;
2596 CreateHistory = true
2597 ),
2598 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2599 List = [Clause|Tail],
2600 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2601 suspension_term_base_fields(Constraint,BaseFields),
2602 ( has_suspension_field(Constraint,id) ->
2603 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2604 gen_id(Id,GenID)
2605 ;
2606 GenID = true
2607 ),
2608 Body =
2609 (
2610 Susp = Suspension,
2611 CreateState,
2612 CreateGeneration,
2613 CreateHistory,
2614 GenID
2615 )
2616 ;
2617 ( has_suspension_field(Constraint,id) ->
2618 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2619 gen_id(Id,GenID)
2620 ;
2621 GenID = true
2622 ),
2623 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2624 chr_none_locked(Vars,NoneLocked),
2625 Body =
2626 (
2627 Susp = Suspension,
2628 IndexedVariablesBody,
2629 NoneLocked,
2630 CreateState,
2631 CreateGeneration,
2632 CreateHistory,
2633 GenID
2634 )
2635 ).
2637 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2638 % novel_production/2
2640 generate_novel_production(List,Tail) :-
2641 ( is_used_auxiliary_predicate(novel_production) ->
2642 List = [Clause|Tail],
2643 Clause =
2644 (
2645 '$novel_production'( Self, Tuple) :-
2646 % arg( 3, Self, Ref), % ARGXXX
2647 % 'chr get_mutable'( History, Ref),
2648 arg( 3, Self, History), % ARGXXX
2649 ( hprolog:get_ds( Tuple, History, _) ->
2650 fail
2651 ;
2652 true
2653 )
2654 )
2655 ;
2656 List = Tail
2657 ).
2659 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2660 % extend_history/2
2662 generate_extend_history(List,Tail) :-
2663 ( is_used_auxiliary_predicate(extend_history) ->
2664 List = [Clause|Tail],
2665 Clause =
2666 (
2667 '$extend_history'( Self, Tuple) :-
2668 % arg( 3, Self, Ref), % ARGXXX
2669 % 'chr get_mutable'( History, Ref),
2670 arg( 3, Self, History), % ARGXXX
2671 hprolog:put_ds( Tuple, History, x, NewHistory),
2672 setarg( 3, Self, NewHistory) % ARGXXX
2673 )
2674 ;
2675 List = Tail
2676 ).
2678 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2679 %
2680 :- chr_constraint
2681 empty_named_history_initialisations/2,
2682 generate_empty_named_history_initialisation/1,
2683 find_empty_named_histories/0.
2685 generate_empty_named_history_initialisations(List, Tail) :-
2686 empty_named_history_initialisations(List, Tail),
2687 find_empty_named_histories.
2689 find_empty_named_histories, history(_, Name, []) ==>
2690 generate_empty_named_history_initialisation(Name).
2692 generate_empty_named_history_initialisation(Name) \
2693 generate_empty_named_history_initialisation(Name) <=> true.
2694 generate_empty_named_history_initialisation(Name) \
2695 empty_named_history_initialisations(List, Tail) # Passive
2696 <=>
2697 empty_named_history_global_variable(Name, GlobalVariable),
2698 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2699 empty_named_history_initialisations(Rest, Tail)
2700 pragma passive(Passive).
2702 find_empty_named_histories \
2703 generate_empty_named_history_initialisation(_) # Passive <=> true
2704 pragma passive(Passive).
2706 find_empty_named_histories,
2707 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2708 pragma passive(Passive).
2710 find_empty_named_histories <=>
2711 chr_error(internal, 'find_empty_named_histories was not removed', []).
2714 empty_named_history_global_variable(Name, GlobalVariable) :-
2715 atom_concat('chr empty named history ', Name, GlobalVariable).
2717 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2718 empty_named_history_global_variable(Name, GlobalVariable).
2720 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2721 empty_named_history_global_variable(Name, GlobalVariable).
2724 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2725 % run_suspensions/2
2727 generate_run_suspensions_clauses([],List,List).
2728 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2729 generate_run_suspensions_clause(C,List,List1),
2730 generate_run_suspensions_clauses(Cs,List1,Tail).
2732 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2733 make_name('$run_suspensions_',Constraint,Name),
2734 Goal =.. [Name,Suspensions].
2736 generate_run_suspensions_clause(Constraint,List,Tail) :-
2737 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2738 List = [Clause1,Clause2|Tail],
2739 run_suspensions_goal(Constraint,[],Clause1),
2740 ( chr_pp_flag(debugable,on) ->
2741 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2742 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2743 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2744 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2745 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2746 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2747 Clause2 =
2748 (
2749 Clause2Head :-
2750 GetState,
2751 GetStateValue,
2752 ( State==active ->
2753 UpdateState,
2754 GetGeneration,
2755 GetGenerationValue,
2756 Generation is Gen+1,
2757 UpdateGeneration,
2758 GetContinuation,
2759 (
2760 'chr debug_event'(wake(Suspension)),
2761 call(Continuation)
2762 ;
2763 'chr debug_event'(fail(Suspension)), !,
2764 fail
2765 ),
2766 (
2767 'chr debug_event'(exit(Suspension))
2768 ;
2769 'chr debug_event'(redo(Suspension)),
2770 fail
2771 ),
2772 GetPost,
2773 GetPostValue,
2774 ( Post==triggered ->
2775 UpdatePost % catching constraints that did not do anything
2776 ;
2777 true
2778 )
2779 ;
2780 true
2781 ),
2782 Clause2Recursion
2783 )
2784 ;
2785 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2786 static_suspension_term(Constraint,SuspensionTerm),
2787 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2788 append(Arguments,[Suspension],VarsSusp),
2789 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2790 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2791 ( uses_field(Constraint,generation) ->
2792 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2793 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2794 ;
2795 GenerationHandling = true
2796 ),
2797 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2798 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2799 if_used_state(Constraint,removed,
2800 ( GetState,
2801 ( State==active
2802 -> ReactivateConstraint
2803 ; true)
2804 ),ReactivateConstraint,CondReactivate),
2805 ReactivateConstraint =
2806 (
2807 UpdateState,
2808 GenerationHandling,
2809 Continuation,
2810 GetPostState,
2811 ( Post==triggered ->
2812 UpdatePostState % catching constraints that did not do anything
2813 ;
2814 true
2815 )
2816 ),
2817 Clause2 =
2818 (
2819 Clause2Head :-
2820 Suspension = SuspensionTerm,
2821 CondReactivate,
2822 Clause2Recursion
2823 )
2824 )
2825 ;
2826 List = Tail
2827 ).
2829 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2831 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2832 generate_attach_increment(Clauses) :-
2833 get_max_constraint_index(N),
2834 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2835 Clauses = [Clause1,Clause2],
2836 generate_attach_increment_empty(Clause1),
2837 ( N == 1 ->
2838 generate_attach_increment_one(Clause2)
2839 ;
2840 generate_attach_increment_many(N,Clause2)
2841 )
2842 ;
2843 Clauses = []
2844 ).
2846 generate_attach_increment_empty((attach_increment([],_) :- true)).
2848 generate_attach_increment_one(Clause) :-
2849 Head = attach_increment([Var|Vars],Susps),
2850 get_target_module(Mod),
2851 chr_not_locked(Var,NotLocked),
2852 Body =
2853 (
2854 NotLocked,
2855 ( get_attr(Var,Mod,VarSusps) ->
2856 sort(VarSusps,SortedVarSusps),
2857 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2858 put_attr(Var,Mod,MergedSusps)
2859 ;
2860 put_attr(Var,Mod,Susps)
2861 ),
2862 attach_increment(Vars,Susps)
2863 ),
2864 Clause = (Head :- Body).
2866 generate_attach_increment_many(N,Clause) :-
2867 Head = attach_increment([Var|Vars],TAttr1),
2868 % writeln(merge_attributes_1_before),
2869 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2870 % writeln(merge_attributes_1_after),
2871 get_target_module(Mod),
2872 chr_not_locked(Var,NotLocked),
2873 Body =
2874 (
2875 NotLocked,
2876 ( get_attr(Var,Mod,TAttr2) ->
2877 MergeGoal,
2878 put_attr(Var,Mod,Attr)
2879 ;
2880 put_attr(Var,Mod,TAttr1)
2881 ),
2882 attach_increment(Vars,TAttr1)
2883 ),
2884 Clause = (Head :- Body).
2886 %% attr_unify_hook
2887 generate_attr_unify_hook(Clauses) :-
2888 get_max_constraint_index(N),
2889 ( N == 0 ->
2890 Clauses = []
2891 ;
2892 Clauses = [GoalsClause|HookClauses],
2893 GoalsClause = attribute_goals(_,Goals,Goals),
2894 ( N == 1 ->
2895 generate_attr_unify_hook_one(HookClauses)
2896 ;
2897 generate_attr_unify_hook_many(N,HookClauses)
2898 )
2899 ).
2901 generate_attr_unify_hook_one([Clause]) :-
2902 Head = attr_unify_hook(Susps,Other),
2903 get_target_module(Mod),
2904 get_indexed_constraint(1,C),
2905 ( get_store_type(C,ST),
2906 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2907 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2908 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2909 ( atomic_types_suspended_constraint(C) ->
2910 SortGoal1 = true,
2911 SortedSusps = Susps,
2912 SortGoal2 = true,
2913 SortedOtherSusps = OtherSusps,
2914 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2915 NonvarBody = true
2916 ;
2917 SortGoal1 = sort(Susps, SortedSusps),
2918 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2919 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2920 use_auxiliary_predicate(attach_increment),
2921 NonvarBody =
2922 ( compound(Other) ->
2923 term_variables(Other,OtherVars),
2924 attach_increment(OtherVars, SortedSusps)
2925 ;
2926 true
2927 )
2928 ),
2929 Body =
2930 (
2931 SortGoal1,
2932 ( var(Other) ->
2933 ( get_attr(Other,Mod,OtherSusps) ->
2934 SortGoal2,
2935 MergeGoal,
2936 put_attr(Other,Mod,NewSusps),
2937 WakeNewSusps
2938 ;
2939 put_attr(Other,Mod,SortedSusps),
2940 WakeSusps
2941 )
2942 ;
2943 NonvarBody,
2944 WakeSusps
2945 )
2946 ),
2947 Clause = (Head :- Body)
2948 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2949 make_run_suspensions(List,List,WakeNewSusps),
2950 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2951 Body =
2952 ( get_attr(Other,Mod,OtherSusps) ->
2953 MergeGoal,
2954 WakeNewSusps
2955 ;
2956 put_attr(Other,Mod,Susps)
2957 ),
2958 Clause = (Head :- Body)
2959 ).
2962 generate_attr_unify_hook_many(N,[Clause]) :-
2963 chr_pp_flag(dynattr,off), !,
2964 Head = attr_unify_hook(Attr,Other),
2965 get_target_module(Mod),
2966 make_attr(N,Mask,SuspsList,Attr),
2967 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2968 list2conj(SortGoalList,SortGoals),
2969 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2970 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2971 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2972 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2973 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2974 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2975 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2976 NonvarBody = true
2977 ;
2978 use_auxiliary_predicate(attach_increment),
2979 NonvarBody =
2980 ( compound(Other) ->
2981 term_variables(Other,OtherVars),
2982 attach_increment(OtherVars,SortedAttr)
2983 ;
2984 true
2985 )
2986 ),
2987 Body =
2988 (
2989 SortGoals,
2990 ( var(Other) ->
2991 ( get_attr(Other,Mod,TOtherAttr) ->
2992 MergeGoal,
2993 put_attr(Other,Mod,MergedAttr),
2994 WakeMergedSusps
2995 ;
2996 put_attr(Other,Mod,SortedAttr),
2997 WakeSortedSusps
2998 )
2999 ;
3000 NonvarBody,
3001 WakeSortedSusps
3002 )
3003 ),
3004 Clause = (Head :- Body).
3006 % NEW
3007 generate_attr_unify_hook_many(N,Clauses) :-
3008 Head = attr_unify_hook(Attr,Other),
3009 get_target_module(Mod),
3010 normalize_attr(Attr,NormalGoal,NormalAttr),
3011 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
3012 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
3013 make_run_suspensions(N),
3014 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
3015 NonvarBody = true
3016 ;
3017 use_auxiliary_predicate(attach_increment),
3018 NonvarBody =
3019 ( compound(Other) ->
3020 term_variables(Other,OtherVars),
3021 attach_increment(OtherVars,NormalAttr)
3022 ;
3023 true
3024 )
3025 ),
3026 Body =
3027 (
3028 NormalGoal,
3029 ( var(Other) ->
3030 ( get_attr(Other,Mod,OtherAttr) ->
3031 NormalOtherGoal,
3032 MergeGoal,
3033 put_attr(Other,Mod,MergedAttr),
3034 '$dispatch_run_suspensions'(MergedAttr)
3035 ;
3036 put_attr(Other,Mod,NormalAttr),
3037 '$dispatch_run_suspensions'(NormalAttr)
3038 )
3039 ;
3040 NonvarBody,
3041 '$dispatch_run_suspensions'(NormalAttr)
3042 )
3043 ),
3044 Clause = (Head :- Body),
3045 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
3046 DispatchList1 = ('$dispatch_run_suspensions'([])),
3047 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
3048 run_suspensions_dispatchers(N,[],Dispatchers).
3050 % NEW
3051 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
3052 ( N > 0 ->
3053 get_indexed_constraint(N,C),
3054 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
3055 ( may_trigger(C) ->
3056 run_suspensions_goal(C,List,Body)
3057 ;
3058 Body = true
3059 ),
3060 M is N - 1,
3061 run_suspensions_dispatchers(M,NAcc,Dispatchers)
3062 ;
3063 Dispatchers = Acc
3064 ).
3066 % NEW
3067 make_run_suspensions(N) :-
3068 ( N > 0 ->
3069 ( get_indexed_constraint(N,C),
3070 may_trigger(C) ->
3071 use_auxiliary_predicate(run_suspensions,C)
3072 ;
3073 true
3074 ),
3075 M is N - 1,
3076 make_run_suspensions(M)
3077 ;
3078 true
3079 ).
3081 make_run_suspensions(AllSusps,OneSusps,Goal) :-
3082 make_run_suspensions(1,AllSusps,OneSusps,Goal).
3084 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
3085 ( get_indexed_constraint(Index,C), may_trigger(C) ->
3086 use_auxiliary_predicate(run_suspensions,C),
3087 ( wakes_partially(C) ->
3088 run_suspensions_goal(C,OneSusps,Goal)
3089 ;
3090 run_suspensions_goal(C,AllSusps,Goal)
3091 )
3092 ;
3093 Goal = true
3094 ).
3096 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
3097 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
3099 make_run_suspensions_loop([],[],_,true).
3100 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
3101 make_run_suspensions(I,AllSusps,OneSusps,Goal),
3102 J is I + 1,
3103 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
3105 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3106 % $insert_in_store_F/A
3107 % $delete_from_store_F/A
3109 generate_insert_delete_constraints([],[]).
3110 generate_insert_delete_constraints([FA|Rest],Clauses) :-
3111 ( is_stored(FA) ->
3112 generate_insert_delete_constraint(FA,Clauses,RestClauses)
3113 ;
3114 Clauses = RestClauses
3115 ),
3116 generate_insert_delete_constraints(Rest,RestClauses).
3118 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
3119 insert_constraint_clause(FA,Clauses,RestClauses1),
3120 delete_constraint_clause(FA,RestClauses1,RestClauses).
3122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3123 % insert_in_store
3125 insert_constraint_goal(FA,Susp,Vars,Goal) :-
3126 ( chr_pp_flag(inline_insertremove,off) ->
3127 use_auxiliary_predicate(insert_in_store,FA),
3128 insert_constraint_atom(FA,Susp,Goal)
3129 ;
3130 delay_phase_end(validate_store_type_assumptions,
3131 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
3132 insert_constraint_direct_used_vars(UsedVars,Vars)
3133 )
3134 )
3135 ).
3137 insert_constraint_direct_used_vars([],_).
3138 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
3139 nth1(Index,Vars,Var),
3140 insert_constraint_direct_used_vars(Rest,Vars).
3142 insert_constraint_atom(FA,Susp,Call) :-
3143 make_name('$insert_in_store_',FA,Functor),
3144 Call =.. [Functor,Susp].
3146 insert_constraint_clause(C,Clauses,RestClauses) :-
3147 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3148 Clauses = [Clause|RestClauses],
3149 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3150 insert_constraint_atom(C,Susp,Head),
3151 insert_constraint_body(C,Susp,UsedVars,Body),
3152 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3153 ( chr_pp_flag(store_counter,on) ->
3154 InsertCounterInc = '$insert_counter_inc'
3155 ;
3156 InsertCounterInc = true
3157 )
3158 ;
3159 Clauses = RestClauses
3160 ).
3162 insert_constraint_used_vars([],_,_,true).
3163 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3164 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3165 insert_constraint_used_vars(Rest,C,Susp,Goals).
3167 insert_constraint_body(C,Susp,UsedVars,Body) :-
3168 get_store_type(C,StoreType),
3169 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3171 insert_constraint_body(default,C,Susp,[],Body) :-
3172 global_list_store_name(C,StoreName),
3173 make_get_store_goal(StoreName,Store,GetStoreGoal),
3174 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3175 ( chr_pp_flag(debugable,on) ->
3176 Cell = [Susp|Store],
3177 Body =
3178 (
3179 GetStoreGoal,
3180 UpdateStoreGoal
3181 )
3182 ;
3183 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3184 Body =
3185 (
3186 GetStoreGoal,
3187 Cell = [Susp|Store],
3188 UpdateStoreGoal,
3189 ( Store = [NextSusp|_] ->
3190 SetGoal
3191 ;
3192 true
3193 )
3194 )
3195 ).
3196 % get_target_module(Mod),
3197 % get_max_constraint_index(Total),
3198 % ( Total == 1 ->
3199 % generate_attach_body_1(C,Store,Susp,AttachBody)
3200 % ;
3201 % generate_attach_body_n(C,Store,Susp,AttachBody)
3202 % ),
3203 % Body =
3204 % (
3205 % 'chr default_store'(Store),
3206 % AttachBody
3207 % ).
3208 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3209 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3210 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3211 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3212 sort_out_used_vars(MixedUsedVars,UsedVars).
3213 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3214 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3215 constants_store_index_name(C,Index,IndexName),
3216 IndexLookup =.. [IndexName,Key,StoreName],
3217 Body =
3218 ( IndexLookup ->
3219 nb_getval(StoreName,Store),
3220 b_setval(StoreName,[Susp|Store])
3221 ;
3222 true
3223 ).
3224 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3225 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3226 constants_store_index_name(C,Index,IndexName),
3227 IndexLookup =.. [IndexName,Key,StoreName],
3228 Body =
3229 ( IndexLookup ->
3230 nb_getval(StoreName,Store),
3231 b_setval(StoreName,[Susp|Store])
3232 ;
3233 true
3234 ).
3235 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3236 global_ground_store_name(C,StoreName),
3237 make_get_store_goal(StoreName,Store,GetStoreGoal),
3238 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3239 ( chr_pp_flag(debugable,on) ->
3240 Cell = [Susp|Store],
3241 Body =
3242 (
3243 GetStoreGoal,
3244 UpdateStoreGoal
3245 )
3246 ;
3247 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3248 Body =
3249 (
3250 GetStoreGoal,
3251 Cell = [Susp|Store],
3252 UpdateStoreGoal,
3253 ( Store = [NextSusp|_] ->
3254 SetGoal
3255 ;
3256 true
3257 )
3258 )
3259 ).
3260 % global_ground_store_name(C,StoreName),
3261 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3262 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3263 % Body =
3264 % (
3265 % GetStoreGoal, % nb_getval(StoreName,Store),
3266 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3267 % ).
3268 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3269 % TODO: generalize to more than one !!!
3270 get_target_module(Module),
3271 Body = ( get_attr(Variable,Module,AssocStore) ->
3272 insert_assoc_store(AssocStore,Key,Susp)
3273 ;
3274 new_assoc_store(AssocStore),
3275 put_attr(Variable,Module,AssocStore),
3276 insert_assoc_store(AssocStore,Key,Susp)
3277 ).
3279 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3280 global_singleton_store_name(C,StoreName),
3281 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3282 Body =
3283 (
3284 UpdateStoreGoal
3285 ).
3286 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3287 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3288 list2conj(Bodies,Body),
3289 sort_out_used_vars(NestedUsedVars,UsedVars).
3290 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3291 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3292 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3293 UsedVars = [Index-Var],
3294 get_identifier_size(ISize),
3295 functor(Struct,struct,ISize),
3296 get_identifier_index(C,Index,IIndex),
3297 arg(IIndex,Struct,Susps),
3298 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3299 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3300 UsedVars = [Index-Var],
3301 type_indexed_identifier_structure(IndexType,Struct),
3302 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3303 arg(IIndex,Struct,Susps),
3304 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3306 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3307 flatten(NestedUsedVars,FlatUsedVars),
3308 sort(FlatUsedVars,SortedFlatUsedVars),
3309 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3311 sort_out_used_vars1([],[]).
3312 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3313 sort_out_used_vars1([I-X,J-Y|R],L) :-
3314 ( I == J ->
3315 X = Y,
3316 sort_out_used_vars1([I-X|R],L)
3317 ;
3318 L = [I-X|T],
3319 sort_out_used_vars1([J-Y|R],T)
3320 ).
3322 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3323 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3324 multi_hash_store_name(FA,Index,StoreName),
3325 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3326 Body =
3327 (
3328 KeyBody,
3329 nb_getval(StoreName,Store),
3330 insert_iht(Store,Key,Susp)
3331 ),
3332 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3334 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3335 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3336 multi_hash_store_name(FA,Index,StoreName),
3337 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3338 make_get_store_goal(StoreName,Store,GetStoreGoal),
3339 ( chr_pp_flag(ht_removal,on)
3340 -> ht_prev_field(Index,PrevField),
3341 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3342 SetGoal),
3343 Body =
3344 (
3345 GetStoreGoal,
3346 insert_ht(Store,Key,Susp,Result),
3347 ( Result = [_,NextSusp|_]
3348 -> SetGoal
3349 ; true
3350 )
3351 )
3352 ; Body =
3353 (
3354 GetStoreGoal,
3355 insert_ht(Store,Key,Susp)
3356 )
3357 ),
3358 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3360 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3361 % Delete
3363 delete_constraint_clause(C,Clauses,RestClauses) :-
3364 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3365 Clauses = [Clause|RestClauses],
3366 Clause = (Head :- Body),
3367 delete_constraint_atom(C,Susp,Head),
3368 C = F/A,
3369 functor(Head,F,A),
3370 delete_constraint_body(C,Head,Susp,[],Body)
3371 ;
3372 Clauses = RestClauses
3373 ).
3375 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3376 functor(Head,F,A),
3377 C = F/A,
3378 ( chr_pp_flag(inline_insertremove,off) ->
3379 use_auxiliary_predicate(delete_from_store,C),
3380 delete_constraint_atom(C,Susp,Goal)
3381 ;
3382 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3383 ).
3385 delete_constraint_atom(C,Susp,Atom) :-
3386 make_name('$delete_from_store_',C,Functor),
3387 Atom =.. [Functor,Susp].
3390 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3391 Body = (CounterBody,DeleteBody),
3392 ( chr_pp_flag(store_counter,on) ->
3393 CounterBody = '$delete_counter_inc'
3394 ;
3395 CounterBody = true
3396 ),
3397 get_store_type(C,StoreType),
3398 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3400 delete_constraint_body(default,C,_,Susp,_,Body) :-
3401 ( chr_pp_flag(debugable,on) ->
3402 global_list_store_name(C,StoreName),
3403 make_get_store_goal(StoreName,Store,GetStoreGoal),
3404 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3405 Body =
3406 (
3407 GetStoreGoal, % nb_getval(StoreName,Store),
3408 'chr sbag_del_element'(Store,Susp,NStore),
3409 UpdateStoreGoal % b_setval(StoreName,NStore)
3410 )
3411 ;
3412 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3413 global_list_store_name(C,StoreName),
3414 make_get_store_goal(StoreName,Store,GetStoreGoal),
3415 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3416 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3417 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3418 Body =
3419 (
3420 GetGoal,
3421 ( var(PredCell) ->
3422 GetStoreGoal, % nb_getval(StoreName,Store),
3423 Store = [_|Tail],
3424 UpdateStoreGoal,
3425 ( Tail = [NextSusp|_] ->
3426 SetGoal1
3427 ;
3428 true
3429 )
3430 ;
3431 PredCell = [_,_|Tail],
3432 setarg(2,PredCell,Tail),
3433 ( Tail = [NextSusp|_] ->
3434 SetGoal2
3435 ;
3436 true
3437 )
3438 )
3439 )
3440 ).
3441 % get_target_module(Mod),
3442 % get_max_constraint_index(Total),
3443 % ( Total == 1 ->
3444 % generate_detach_body_1(C,Store,Susp,DetachBody),
3445 % Body =
3446 % (
3447 % 'chr default_store'(Store),
3448 % DetachBody
3449 % )
3450 % ;
3451 % generate_detach_body_n(C,Store,Susp,DetachBody),
3452 % Body =
3453 % (
3454 % 'chr default_store'(Store),
3455 % DetachBody
3456 % )
3457 % ).
3458 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3459 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3460 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3461 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3462 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3463 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3464 constants_store_index_name(C,Index,IndexName),
3465 IndexLookup =.. [IndexName,Key,StoreName],
3466 Body =
3467 ( KeyBody,
3468 ( IndexLookup ->
3469 nb_getval(StoreName,Store),
3470 'chr sbag_del_element'(Store,Susp,NStore),
3471 b_setval(StoreName,NStore)
3472 ;
3473 true
3474 )).
3475 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3476 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3477 constants_store_index_name(C,Index,IndexName),
3478 IndexLookup =.. [IndexName,Key,StoreName],
3479 Body =
3480 ( KeyBody,
3481 ( IndexLookup ->
3482 nb_getval(StoreName,Store),
3483 'chr sbag_del_element'(Store,Susp,NStore),
3484 b_setval(StoreName,NStore)
3485 ;
3486 true
3487 )).
3488 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3489 ( chr_pp_flag(debugable,on) ->
3490 global_ground_store_name(C,StoreName),
3491 make_get_store_goal(StoreName,Store,GetStoreGoal),
3492 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3493 Body =
3494 (
3495 GetStoreGoal, % nb_getval(StoreName,Store),
3496 'chr sbag_del_element'(Store,Susp,NStore),
3497 UpdateStoreGoal % b_setval(StoreName,NStore)
3498 )
3499 ;
3500 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3501 global_ground_store_name(C,StoreName),
3502 make_get_store_goal(StoreName,Store,GetStoreGoal),
3503 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3504 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3505 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3506 Body =
3507 (
3508 GetGoal,
3509 ( var(PredCell) ->
3510 GetStoreGoal, % nb_getval(StoreName,Store),
3511 Store = [_|Tail],
3512 UpdateStoreGoal,
3513 ( Tail = [NextSusp|_] ->
3514 SetGoal1
3515 ;
3516 true
3517 )
3518 ;
3519 PredCell = [_,_|Tail],
3520 setarg(2,PredCell,Tail),
3521 ( Tail = [NextSusp|_] ->
3522 SetGoal2
3523 ;
3524 true
3525 )
3526 )
3527 )
3528 ).
3529 % global_ground_store_name(C,StoreName),
3530 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3531 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3532 % Body =
3533 % (
3534 % GetStoreGoal, % nb_getval(StoreName,Store),
3535 % 'chr sbag_del_element'(Store,Susp,NStore),
3536 % UpdateStoreGoal % b_setval(StoreName,NStore)
3537 % ).
3538 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3539 get_target_module(Module),
3540 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3541 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3542 Body = (
3543 VariableGoal,
3544 get_attr(Variable,Module,AssocStore),
3545 KeyGoal,
3546 delete_assoc_store(AssocStore,Key,Susp)
3547 ).
3548 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3549 global_singleton_store_name(C,StoreName),
3550 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3551 Body =
3552 (
3553 UpdateStoreGoal % b_setval(StoreName,[])
3554 ).
3555 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3556 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3557 list2conj(Bodies,Body).
3558 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3559 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3560 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3561 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3562 get_identifier_size(ISize),
3563 functor(Struct,struct,ISize),
3564 get_identifier_index(C,Index,IIndex),
3565 arg(IIndex,Struct,Susps),
3566 Body = (
3567 VariableGoal,
3568 Variable = Struct,
3569 'chr sbag_del_element'(Susps,Susp,NSusps),
3570 setarg(IIndex,Variable,NSusps)
3571 ).
3572 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3573 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3574 type_indexed_identifier_structure(IndexType,Struct),
3575 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3576 arg(IIndex,Struct,Susps),
3577 Body = (
3578 VariableGoal,
3579 Variable = Struct,
3580 'chr sbag_del_element'(Susps,Susp,NSusps),
3581 setarg(IIndex,Variable,NSusps)
3582 ).
3584 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3585 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3586 multi_hash_store_name(FA,Index,StoreName),
3587 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3588 Body =
3589 (
3590 KeyBody,
3591 nb_getval(StoreName,Store),
3592 delete_iht(Store,Key,Susp)
3593 ),
3594 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3595 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3596 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3597 multi_hash_store_name(C,Index,StoreName),
3598 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3599 make_get_store_goal(StoreName,Store,GetStoreGoal),
3600 ( chr_pp_flag(ht_removal,on)
3601 -> ht_prev_field(Index,PrevField),
3602 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3603 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3604 SetGoal1),
3605 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3606 SetGoal2),
3607 Body =
3608 (
3609 GetGoal,
3610 ( var(Prev)
3611 -> GetStoreGoal,
3612 KeyBody,
3613 delete_first_ht(Store,Key,Values),
3614 ( Values = [NextSusp|_]
3615 -> SetGoal1
3616 ; true
3617 )
3618 ; Prev = [_,_|Values],
3619 setarg(2,Prev,Values),
3620 ( Values = [NextSusp|_]
3621 -> SetGoal2
3622 ; true
3623 )
3624 )
3625 )
3626 ; Body =
3627 (
3628 KeyBody,
3629 GetStoreGoal, % nb_getval(StoreName,Store),
3630 delete_ht(Store,Key,Susp)
3631 )
3632 ),
3633 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3635 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3637 :- chr_constraint
3638 module_initializer/1,
3639 module_initializers/1.
3641 module_initializers(G), module_initializer(Initializer) <=>
3642 G = (Initializer,Initializers),
3643 module_initializers(Initializers).
3645 module_initializers(G) <=>
3646 G = true.
3648 generate_attach_code(Constraints,Clauses) :-
3649 enumerate_stores_code(Constraints,Enumerate),
3650 append(Enumerate,L,Clauses),
3651 generate_attach_code(Constraints,L,T),
3652 module_initializers(Initializers),
3653 prolog_global_variables_code(PrologGlobalVariables),
3654 % Do not rename or the 'chr_initialization' predicate
3655 % without warning SSS
3656 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3658 generate_attach_code([],L,L).
3659 generate_attach_code([C|Cs],L,T) :-
3660 get_store_type(C,StoreType),
3661 generate_attach_code(StoreType,C,L,L1),
3662 generate_attach_code(Cs,L1,T).
3664 generate_attach_code(default,C,L,T) :-
3665 global_list_store_initialisation(C,L,T).
3666 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3667 multi_inthash_store_initialisations(Indexes,C,L,L1),
3668 multi_inthash_via_lookups(Indexes,C,L1,T).
3669 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3670 multi_hash_store_initialisations(Indexes,C,L,L1),
3671 multi_hash_lookups(Indexes,C,L1,T).
3672 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3673 constants_initializers(C,Index,Constants),
3674 atomic_constants_code(C,Index,Constants,L,T).
3675 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3676 constants_initializers(C,Index,Constants),
3677 ground_constants_code(C,Index,Constants,L,T).
3678 generate_attach_code(global_ground,C,L,T) :-
3679 global_ground_store_initialisation(C,L,T).
3680 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3681 use_auxiliary_module(chr_assoc_store).
3682 generate_attach_code(global_singleton,C,L,T) :-
3683 global_singleton_store_initialisation(C,L,T).
3684 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3685 multi_store_generate_attach_code(StoreTypes,C,L,T).
3686 generate_attach_code(identifier_store(Index),C,L,T) :-
3687 get_identifier_index(C,Index,IIndex),
3688 ( IIndex == 2 ->
3689 get_identifier_size(ISize),
3690 functor(Struct,struct,ISize),
3691 Struct =.. [_,Label|Stores],
3692 set_elems(Stores,[]),
3693 Clause1 = new_identifier(Label,Struct),
3694 functor(Struct2,struct,ISize),
3695 arg(1,Struct2,Label2),
3696 Clause2 =
3697 ( user:portray(Struct2) :-
3698 write('<id:'),
3699 print(Label2),
3700 write('>')
3701 ),
3702 functor(Struct3,struct,ISize),
3703 arg(1,Struct3,Label3),
3704 Clause3 = identifier_label(Struct3,Label3),
3705 L = [Clause1,Clause2,Clause3|T]
3706 ;
3707 L = T
3708 ).
3709 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3710 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3711 ( IIndex == 2 ->
3712 identifier_store_initialization(IndexType,L,L1),
3713 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3714 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3715 get_type_indexed_identifier_size(IndexType,ISize),
3716 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3717 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3718 type_indexed_identifier_structure(IndexType,Struct),
3719 Struct =.. [_,Label|Stores],
3720 set_elems(Stores,[]),
3721 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3722 Clause1 =.. [Name1,Label,Struct],
3723 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3724 Goal1 =.. [Name1,Label1b,S1b],
3725 type_indexed_identifier_structure(IndexType,Struct1b),
3726 Struct1b =.. [_,Label1b|Stores1b],
3727 set_elems(Stores1b,[]),
3728 Expansion1 = (S1b = Struct1b),
3729 Clause1b = user:goal_expansion(Goal1,Expansion1),
3730 % writeln(Clause1-Clause1b),
3731 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3732 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3733 type_indexed_identifier_structure(IndexType,Struct2),
3734 arg(1,Struct2,Label2),
3735 Clause2 =
3736 ( user:portray(Struct2) :-
3737 write('<id:'),
3738 print(Label2),
3739 write('>')
3740 ),
3741 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3742 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3743 type_indexed_identifier_structure(IndexType,Struct3),
3744 arg(1,Struct3,Label3),
3745 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3746 Clause3 =.. [Name3,Struct3,Label3],
3747 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3748 Goal3b =.. [Name3,S3b,L3b],
3749 type_indexed_identifier_structure(IndexType,Struct3b),
3750 arg(1,Struct3b,L3b),
3751 Expansion3b = (S3b = Struct3b),
3752 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3753 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3754 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3755 identifier_store_name(IndexType,GlobalVariable),
3756 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3757 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3758 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3759 Clause4 =
3760 ( LookupAtom :-
3761 nb_getval(GlobalVariable,HT),
3762 ( lookup_ht(HT,X,[IX]) ->
3763 true
3764 ;
3765 NewIdentifierGoal,
3766 insert_ht(HT,X,IX)
3767 )
3768 ),
3769 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3771 lookup_only_identifier_atom(IndexType,Y,IY,LookupOnlyAtom),
3772 Clause5 =
3773 ( LookupOnlyAtom :-
3774 nb_getval(GlobalVariable,HT0),
3775 lookup_ht(HT0,Y,[IY])
3776 ),
3777 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3778 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3779 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4,Clause5|T]
3780 ;
3781 L = T
3782 ).
3784 constants_initializers(C,Index,Constants) :-
3785 maplist(constant_initializer(C,Index),Constants).
3787 constant_initializer(C,Index,Constant) :-
3788 constants_store_name(C,Index,Constant,StoreName),
3789 prolog_global_variable(StoreName),
3790 module_initializer(nb_setval(StoreName,[])).
3792 lookup_identifier_atom(Key,X,IX,Atom) :-
3793 atom_concat('lookup_identifier_',Key,LookupFunctor),
3794 Atom =.. [LookupFunctor,X,IX].
3796 lookup_only_identifier_atom(Key,X,IX,Atom) :-
3797 atom_concat('lookup_only_identifier_',Key,LookupFunctor),
3798 Atom =.. [LookupFunctor,X,IX].
3800 identifier_label_atom(IndexType,IX,X,Atom) :-
3801 type_indexed_identifier_name(IndexType,identifier_label,Name),
3802 Atom =.. [Name,IX,X].
3804 multi_store_generate_attach_code([],_,L,L).
3805 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3806 generate_attach_code(ST,C,L,L1),
3807 multi_store_generate_attach_code(STs,C,L1,T).
3809 multi_inthash_store_initialisations([],_,L,L).
3810 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3811 use_auxiliary_module(chr_integertable_store),
3812 multi_hash_store_name(FA,Index,StoreName),
3813 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3814 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3815 L1 = L,
3816 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3817 multi_hash_store_initialisations([],_,L,L).
3818 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3819 use_auxiliary_module(chr_hashtable_store),
3820 multi_hash_store_name(FA,Index,StoreName),
3821 prolog_global_variable(StoreName),
3822 make_init_store_goal(StoreName,HT,InitStoreGoal),
3823 module_initializer((new_ht(HT),InitStoreGoal)),
3824 L1 = L,
3825 multi_hash_store_initialisations(Indexes,FA,L1,T).
3827 global_list_store_initialisation(C,L,T) :-
3828 ( is_stored(C) ->
3829 global_list_store_name(C,StoreName),
3830 prolog_global_variable(StoreName),
3831 make_init_store_goal(StoreName,[],InitStoreGoal),
3832 module_initializer(InitStoreGoal)
3833 ;
3834 true
3835 ),
3836 L = T.
3837 global_ground_store_initialisation(C,L,T) :-
3838 global_ground_store_name(C,StoreName),
3839 prolog_global_variable(StoreName),
3840 make_init_store_goal(StoreName,[],InitStoreGoal),
3841 module_initializer(InitStoreGoal),
3842 L = T.
3843 global_singleton_store_initialisation(C,L,T) :-
3844 global_singleton_store_name(C,StoreName),
3845 prolog_global_variable(StoreName),
3846 make_init_store_goal(StoreName,[],InitStoreGoal),
3847 module_initializer(InitStoreGoal),
3848 L = T.
3849 identifier_store_initialization(IndexType,L,T) :-
3850 use_auxiliary_module(chr_hashtable_store),
3851 identifier_store_name(IndexType,StoreName),
3852 prolog_global_variable(StoreName),
3853 make_init_store_goal(StoreName,HT,InitStoreGoal),
3854 module_initializer((new_ht(HT),InitStoreGoal)),
3855 L = T.
3858 multi_inthash_via_lookups([],_,L,L).
3859 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3860 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3861 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3862 L = [(Head :- Body)|L1],
3863 multi_inthash_via_lookups(Indexes,C,L1,T).
3864 multi_hash_lookups([],_,L,L).
3865 multi_hash_lookups([Index|Indexes],C,L,T) :-
3866 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3867 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3868 L = [(Head :- Body)|L1],
3869 multi_hash_lookups(Indexes,C,L1,T).
3871 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3872 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3873 Head =.. [Name,Key,SuspsList].
3875 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3876 %
3877 % Returns goal that performs hash table lookup.
3878 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3879 % INLINED:
3880 get_store_type(ConstraintSymbol,multi_store(Stores)),
3881 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3882 ( ground(Key) ->
3883 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3884 Goal = nb_getval(StoreName,SuspsList)
3885 ;
3886 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3887 Lookup =.. [IndexName,Key,StoreName],
3888 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3889 )
3890 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3891 ( ground(Key) ->
3892 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3893 Goal = nb_getval(StoreName,SuspsList)
3894 ;
3895 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3896 Lookup =.. [IndexName,Key,StoreName],
3897 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3898 )
3899 ; memberchk(multi_hash([Index]),Stores) ->
3900 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3901 make_get_store_goal(StoreName,HT,GetStoreGoal),
3902 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3903 Goal =
3904 (
3905 GetStoreGoal, % nb_getval(StoreName,HT),
3906 HashCall, % hash_term(Key,Hash),
3907 lookup_ht1(HT,Hash,Key,SuspsList)
3908 )
3909 ;
3910 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3911 Goal =
3912 (
3913 GetStoreGoal, % nb_getval(StoreName,HT),
3914 Lookup
3915 )
3916 )
3917 ; HashType == inthash ->
3918 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3919 make_get_store_goal(StoreName,HT,GetStoreGoal),
3920 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3921 Goal =
3922 (
3923 GetStoreGoal, % nb_getval(StoreName,HT),
3924 Lookup
3925 )
3926 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3927 % find alternative index
3928 % -> SubIndex + RestIndex
3929 % -> SubKey + RestKeys
3930 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3931 % instantiate rest goal?
3932 % Goal = (SubGoal,RestGoal)
3933 ).
3936 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3937 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3939 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3940 ( ground(Key) ->
3941 % This is based on a property of SWI-Prolog's
3942 % hash_term/2 predicate:
3943 % the hash value is stable over repeated invocations
3944 % of SWI-Prolog
3945 hash_term(Key,Hash),
3946 Call = true
3947 % ; Index = [IndexPos],
3948 % get_constraint_type(Constraint,ArgTypes),
3949 % nth1(IndexPos,ArgTypes,Type),
3950 % unalias_type(Type,NormalType),
3951 % memberchk_eq(NormalType,[int,natural]) ->
3952 % ( NormalType == int ->
3953 % Call = (Hash is abs(Key))
3954 % ;
3955 % Hash = Key,
3956 % Call = true
3957 % )
3958 % ;
3959 % nonvar(Key),
3960 % specialize_hash_term(Key,NewKey),
3961 % NewKey \== Key,
3962 % Call = hash_term(NewKey,Hash)
3963 ).
3965 % specialize_hash_term(Term,NewTerm) :-
3966 % ( ground(Term) ->
3967 % hash_term(Term,NewTerm)
3968 % ; var(Term) ->
3969 % NewTerm = Term
3970 % ;
3971 % Term =.. [F|Args],
3972 % maplist(specialize_hash_term,Args,NewArgs),
3973 % NewTerm =.. [F|NewArgs]
3974 % ).
3976 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3977 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3978 ( /* chr_pp_flag(experiment,off) ->
3979 true
3980 ; */ atomic(Key) ->
3981 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3982 ; ground(Key) ->
3983 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3984 ;
3985 ( Index = [Pos],
3986 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3987 is_chr_constants_type(Type,_,_)
3988 ->
3989 true
3990 ;
3991 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3992 )
3993 ),
3994 delay_phase_end(validate_store_type_assumptions,
3995 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3997 :- chr_constraint actual_atomic_multi_hash_keys/3.
3998 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
4000 :- chr_constraint actual_ground_multi_hash_keys/3.
4001 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
4003 :- chr_constraint actual_non_ground_multi_hash_key/2.
4004 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
4006 /*
4007 actual_atomic_multi_hash_keys(C,Index,Keys)
4008 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
4010 actual_ground_multi_hash_keys(C,Index,Keys)
4011 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
4013 actual_non_ground_multi_hash_key(C,Index)
4014 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
4015 */
4016 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4017 <=> append(Keys1,Keys2,Keys0),
4018 sort(Keys0,Keys),
4019 actual_atomic_multi_hash_keys(C,Index,Keys).
4021 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4022 <=> append(Keys1,Keys2,Keys0),
4023 sort(Keys0,Keys),
4024 actual_ground_multi_hash_keys(C,Index,Keys).
4026 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
4027 <=> append(Keys1,Keys2,Keys0),
4028 sort(Keys0,Keys),
4029 actual_ground_multi_hash_keys(C,Index,Keys).
4031 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
4032 <=> true.
4034 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
4035 <=> true.
4037 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
4038 <=> true.
4040 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
4041 %
4042 % Returns predicate name of hash table lookup predicate.
4043 multi_hash_lookup_name(F/A,Index,Name) :-
4044 atom_concat_list(Index,IndexName),
4045 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
4047 multi_hash_store_name(F/A,Index,Name) :-
4048 get_target_module(Mod),
4049 atom_concat_list(Index,IndexName),
4050 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
4052 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
4053 ( Index = [I] ->
4054 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
4055 ;
4056 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
4057 Key =.. [k|Keys],
4058 list2conj(Bodies,KeyBody)
4059 ).
4061 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
4062 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
4064 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
4065 ( Index = [I] ->
4066 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
4067 ;
4068 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
4069 Key =.. [k|Keys],
4070 list2conj(Bodies,KeyBody)
4071 ).
4073 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
4074 arg(Index,Head,OriginalArg),
4075 ( ground(OriginalArg), OriginalArg = '$chr_identifier_match'(Value,KeyType) ->
4076 functor(Head,F,A),
4077 lookup_identifier_atom(KeyType,Value,Arg,Goal)
4078 ; term_variables(OriginalArg,OriginalVars),
4079 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
4080 translate(OriginalVars,VarDict,Vars) ->
4081 Goal = true
4082 ;
4083 functor(Head,F,A),
4084 C = F/A,
4085 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
4086 ).
4088 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
4089 ( Index = [I] ->
4090 UsedVars = [I-Key]
4091 ;
4092 pairup(Index,Keys,UsedVars),
4093 Key =.. [k|Keys]
4094 ).
4096 args(Index,Head,KeyArgs) :-
4097 maplist(arg1(Head),Index,KeyArgs).
4099 split_args(Indexes,Args,IArgs,NIArgs) :-
4100 split_args(Indexes,Args,1,IArgs,NIArgs).
4102 split_args([],Args,_,[],Args).
4103 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
4104 NJ is J + 1,
4105 ( I == J ->
4106 IArgs = [Arg|Rest],
4107 split_args(Is,Args,NJ,Rest,NIArgs)
4108 ;
4109 NIArgs = [Arg|Rest],
4110 split_args([I|Is],Args,NJ,IArgs,Rest)
4111 ).
4114 %-------------------------------------------------------------------------------
4115 atomic_constants_code(C,Index,Constants,L,T) :-
4116 constants_store_index_name(C,Index,IndexName),
4117 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
4118 append(Clauses,T,L).
4120 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
4121 constants_store_name(C,Index,Constant,StoreName),
4122 Clause =.. [IndexName,Constant,StoreName].
4124 %-------------------------------------------------------------------------------
4125 ground_constants_code(C,Index,Terms,L,T) :-
4126 constants_store_index_name(C,Index,IndexName),
4127 maplist(constants_store_name(C,Index),Terms,StoreNames),
4128 length(Terms,N),
4129 replicate(N,[],More),
4130 trie_index([Terms|More],StoreNames,IndexName,L,T).
4132 constants_store_name(F/A,Index,Term,Name) :-
4133 get_target_module(Mod),
4134 term_to_atom(Term,Constant),
4135 term_to_atom(Index,IndexAtom),
4136 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
4138 constants_store_index_name(F/A,Index,Name) :-
4139 get_target_module(Mod),
4140 term_to_atom(Index,IndexAtom),
4141 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
4143 % trie index code {{{
4144 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
4145 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
4147 trie_step([],_,_,[],[],L,L) :- !.
4148 % length MorePatterns == length Patterns == length Results
4149 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
4150 MorePatterns = [List|_],
4151 length(List,N),
4152 aggregate_all(set(F/A),
4153 ( member(Pattern,Patterns),
4154 functor(Pattern,F,A)
4155 ),
4156 FAs),
4157 N1 is N + 1,
4158 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4160 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4161 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4162 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4163 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4165 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4166 Clause = (Head :- Body),
4167 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4168 N1 is N + 1,
4169 functor(Head,Symbol,N1),
4170 arg(1,Head,IndexPattern),
4171 Head =.. [_,_|RestArgs],
4172 once(append(Vs,[Result],RestArgs)),
4173 /* IndexPattern = F() */
4174 functor(IndexPattern,F,A),
4175 IndexPattern =.. [_|Args],
4176 append(Args,RestArgs,RecArgs),
4177 ( RecArgs == [Result] ->
4178 /* nothing more to match on */
4179 List = Tail,
4180 Body = true,
4181 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4182 MoreResults = [Result]
4183 ; /* more things to match on */
4184 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4185 ( MoreCases = [OneMoreCase] ->
4186 /* only one more thing to match on */
4187 List = Tail,
4188 Body = true,
4189 append([Cases,OneMoreCase,MoreResults],RecArgs)
4190 ;
4191 /* more than one thing to match on */
4192 /* [ x1,..., xn]
4193 [xs1,...,xsn]
4194 */
4195 pairup(Cases,MoreCases,CasePairs),
4196 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4197 append(Args,Vs,[First|Rest]),
4198 First-Rest = CommonPatternPair,
4199 % Body = RSymbol(DiffVars,Result)
4200 gensym(Prefix,RSymbol),
4201 append(DiffVars,[Result],RecCallVars),
4202 Body =.. [RSymbol|RecCallVars],
4203 maplist(head_tail,Differences,CHs,CTs),
4204 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4205 )
4206 ).
4208 head_tail([H|T],H,T).
4210 rec_cases([],[],[],_,[],[],[]).
4211 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4212 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4213 Cases = [Case|NCases],
4214 MoreCases = [MoreCase|NMoreCases],
4215 MoreResults = [Result|NMoreResults],
4216 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4217 ;
4218 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4219 ).
4220 % }}}
4222 %% common_pattern(+terms,-term,-vars,-differences) is det.
4223 common_pattern(Ts,T,Vars,Differences) :-
4224 fold1(chr_translate:gct,Ts,T),
4225 term_variables(T,Vars),
4226 findall(Vars,member(T,Ts),Differences).
4228 gct(T1,T2,T) :-
4229 gct_(T1,T2,T,[],_).
4231 gct_(T1,T2,T,Dict0,Dict) :-
4232 ( nonvar(T1),
4233 nonvar(T2),
4234 functor(T1,F1,A1),
4235 functor(T2,F2,A2),
4236 F1 == F2,
4237 A1 == A2 ->
4238 functor(T,F1,A1),
4239 T1 =.. [_|Args1],
4240 T2 =.. [_|Args2],
4241 T =.. [_|Args],
4242 maplist_dcg(chr_translate:gct_,Args1,Args2,Args,Dict0,Dict)
4243 ;
4244 /* T is a variable */
4245 ( lookup_eq(Dict0,T1+T2,T) ->
4246 /* we already have a variable for this difference */
4247 Dict = Dict0
4248 ;
4249 /* T is a fresh variable */
4250 Dict = [(T1+T2)-T|Dict0]
4251 )
4252 ).
4255 %-------------------------------------------------------------------------------
4256 global_list_store_name(F/A,Name) :-
4257 get_target_module(Mod),
4258 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4259 global_ground_store_name(F/A,Name) :-
4260 get_target_module(Mod),
4261 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4262 global_singleton_store_name(F/A,Name) :-
4263 get_target_module(Mod),
4264 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4266 identifier_store_name(TypeName,Name) :-
4267 get_target_module(Mod),
4268 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4270 :- chr_constraint prolog_global_variable/1.
4271 :- chr_option(mode,prolog_global_variable(+)).
4273 :- chr_constraint prolog_global_variables/1.
4274 :- chr_option(mode,prolog_global_variables(-)).
4276 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4278 prolog_global_variables(List), prolog_global_variable(Name) <=>
4279 List = [Name|Tail],
4280 prolog_global_variables(Tail).
4281 prolog_global_variables(List) <=> List = [].
4283 %% SWI begin
4284 prolog_global_variables_code(Code) :-
4285 prolog_global_variables(Names),
4286 ( Names == [] ->
4287 Code = []
4288 ;
4289 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4290 Code = [(:- dynamic user:exception/3),
4291 (:- multifile user:exception/3),
4292 (user:exception(undefined_global_variable,Name,retry) :-
4293 (
4294 '$chr_prolog_global_variable'(Name),
4295 '$chr_initialization'
4296 )
4297 )
4298 |
4299 NameDeclarations
4300 ]
4301 ).
4302 %% SWI end
4303 %% SICStus begin
4304 % prolog_global_variables_code([]).
4305 %% SICStus end
4306 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4307 %sbag_member_call(S,L,sysh:mem(S,L)).
4308 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4309 %sbag_member_call(S,L,member(S,L)).
4310 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4311 %update_mutable_call(A,B,setarg(1, B, A)).
4312 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4313 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4315 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4316 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4317 % create_get_mutable(Value,Field,Get1).
4318 %
4319 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4320 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4321 % update_mutable_call(NewValue,Field,Set).
4322 %
4323 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4324 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4325 % create_get_mutable_ref(Value,Field,Get1),
4326 % update_mutable_call(NewValue,Field,Set).
4327 %
4328 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4329 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4330 % create_mutable_call(Value,Field,Create).
4331 %
4332 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4333 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4334 % create_get_mutable(Value,Field,Get).
4335 %
4336 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4337 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4338 % create_get_mutable_ref(Value,Field,Get),
4339 % update_mutable_call(NewValue,Field,Set).
4341 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4342 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4344 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4345 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4347 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4348 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4349 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4351 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4352 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4354 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4355 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4357 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4358 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4359 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4361 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4363 enumerate_stores_code(Constraints,[Clause|List]) :-
4364 Head = '$enumerate_constraints'(Constraint),
4365 Clause = ( Head :- Body),
4366 enumerate_store_bodies(Constraints,Constraint,List),
4367 ( List = [] ->
4368 Body = fail
4369 ;
4370 Body = ( nonvar(Constraint) ->
4371 functor(Constraint,Functor,_),
4372 '$enumerate_constraints'(Functor,Constraint)
4373 ;
4374 '$enumerate_constraints'(_,Constraint)
4375 )
4376 ).
4378 enumerate_store_bodies([],_,[]).
4379 enumerate_store_bodies([C|Cs],Constraint,L) :-
4380 ( is_stored(C) ->
4381 get_store_type(C,StoreType),
4382 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4383 true
4384 ;
4385 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4386 ),
4387 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4388 C = F/_,
4389 Constraint0 =.. [F|Arguments],
4390 Head = '$enumerate_constraints'(F,Constraint),
4391 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4392 L = [(Head :- Body)|T]
4393 ;
4394 L = T
4395 ),
4396 enumerate_store_bodies(Cs,Constraint,T).
4398 enumerate_store_body(default,C,Susp,Body) :-
4399 global_list_store_name(C,StoreName),
4400 sbag_member_call(Susp,List,Sbag),
4401 make_get_store_goal(StoreName,List,GetStoreGoal),
4402 Body =
4403 (
4404 GetStoreGoal, % nb_getval(StoreName,List),
4405 Sbag
4406 ).
4407 % get_constraint_index(C,Index),
4408 % get_target_module(Mod),
4409 % get_max_constraint_index(MaxIndex),
4410 % Body1 =
4411 % (
4412 % 'chr default_store'(GlobalStore),
4413 % get_attr(GlobalStore,Mod,Attr)
4414 % ),
4415 % ( MaxIndex > 1 ->
4416 % NIndex is Index + 1,
4417 % sbag_member_call(Susp,List,Sbag),
4418 % Body2 =
4419 % (
4420 % arg(NIndex,Attr,List),
4421 % Sbag
4422 % )
4423 % ;
4424 % sbag_member_call(Susp,Attr,Sbag),
4425 % Body2 = Sbag
4426 % ),
4427 % Body = (Body1,Body2).
4428 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4429 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4430 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4431 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4432 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4433 Completeness == complete, % fail if incomplete
4434 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4435 list2disj(Disjuncts, Disjunction),
4436 Body = ( Disjunction, member(Susp,Susps) ).
4437 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4438 constants_store_name(C,Index,Constant,StoreName).
4440 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4441 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4442 enumerate_store_body(global_ground,C,Susp,Body) :-
4443 global_ground_store_name(C,StoreName),
4444 sbag_member_call(Susp,List,Sbag),
4445 make_get_store_goal(StoreName,List,GetStoreGoal),
4446 Body =
4447 (
4448 GetStoreGoal, % nb_getval(StoreName,List),
4449 Sbag
4450 ).
4451 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4452 Body = fail.
4453 enumerate_store_body(global_singleton,C,Susp,Body) :-
4454 global_singleton_store_name(C,StoreName),
4455 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4456 Body =
4457 (
4458 GetStoreGoal, % nb_getval(StoreName,Susp),
4459 Susp \== []
4460 ).
4461 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4462 ( memberchk(global_ground,STs) ->
4463 enumerate_store_body(global_ground,C,Susp,Body)
4464 ;
4465 once((
4466 member(ST,STs),
4467 enumerate_store_body(ST,C,Susp,Body)
4468 ))
4469 ).
4470 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4471 Body = fail.
4472 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4473 Body = fail.
4475 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4476 multi_hash_store_name(C,I,StoreName),
4477 B =
4478 (
4479 nb_getval(StoreName,HT),
4480 value_iht(HT,Susp)
4481 ).
4482 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4483 multi_hash_store_name(C,I,StoreName),
4484 make_get_store_goal(StoreName,HT,GetStoreGoal),
4485 B =
4486 (
4487 GetStoreGoal, % nb_getval(StoreName,HT),
4488 value_ht(HT,Susp)
4489 ).
4491 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4492 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4493 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4495 :- chr_constraint
4496 background_info/1,
4497 background_info/2,
4498 get_bg_info/1,
4499 get_bg_info/2,
4500 get_bg_info_answer/1.
4502 background_info(X), background_info(Y) <=>
4503 append(X,Y,XY), background_info(XY).
4504 background_info(X) \ get_bg_info(Q) <=> Q=X.
4505 get_bg_info(Q) <=> Q = [].
4507 background_info(T,I), get_bg_info(A,Q) ==>
4508 copy_term_nat(T,T1),
4509 subsumes_chk(T1,A)
4510 |
4511 copy_term_nat(T-I,A-X),
4512 get_bg_info_answer([X]).
4513 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4514 append(X,Y,XY), get_bg_info_answer(XY).
4516 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4517 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4519 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4522 :- chr_constraint
4523 prev_guard_list/8,
4524 prev_guard_list/6,
4525 simplify_guards/1,
4526 set_all_passive/1.
4528 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4529 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4530 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4531 :- chr_option(mode,simplify_guards(+)).
4532 :- chr_option(mode,set_all_passive(+)).
4534 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4535 % GUARD SIMPLIFICATION
4536 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4537 % If the negation of the guards of earlier rules entails (part of)
4538 % the current guard, the current guard can be simplified. We can only
4539 % use earlier rules with a head that matches if the head of the current
4540 % rule does, and which make it impossible for the current rule to match
4541 % if they fire (i.e. they shouldn't be propagation rules and their
4542 % head constraints must be subsets of those of the current rule).
4543 % At this point, we know for sure that the negation of the guard
4544 % of such a rule has to be true (otherwise the earlier rule would have
4545 % fired, because of the refined operational semantics), so we can use
4546 % that information to simplify the guard by replacing all entailed
4547 % conditions by true/0. As a consequence, the never-stored analysis
4548 % (in a further phase) will detect more cases of never-stored constraints.
4549 %
4550 % e.g. c(X),d(Y) <=> X > 0 | ...
4551 % e(X) <=> X < 0 | ...
4552 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4553 % \____________/
4554 % true
4556 guard_simplification :-
4557 ( chr_pp_flag(guard_simplification,on) ->
4558 precompute_head_matchings,
4559 simplify_guards(1)
4560 ;
4561 true
4562 ).
4564 % for every rule, we create a prev_guard_list where the last argument
4565 % eventually is a list of the negations of earlier guards
4566 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4567 <=>
4568 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4569 append(Head1,Head2,Heads),
4570 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4571 tree_set_empty(Done),
4572 multiple_occ_constraints_checked(Done),
4573 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4575 append(IDs1,IDs2,IDs),
4576 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4577 empty_q(EmptyHeap),
4578 insert_list_q(HeapData,EmptyHeap,Heap),
4579 next_prev_rule(Heap,_,Heap1),
4580 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4581 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4582 NextRule is RuleNb+1,
4583 simplify_guards(NextRule).
4585 next_prev_rule(Heap,RuleNb,NHeap) :-
4586 ( find_min_q(Heap,_-Priority) ->
4587 Priority = (-RuleNb),
4588 normalize_heap(Heap,Priority,NHeap)
4589 ;
4590 RuleNb = 0,
4591 NHeap = Heap
4592 ).
4594 normalize_heap(Heap,Priority,NHeap) :-
4595 ( find_min_q(Heap,_-Priority) ->
4596 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4597 ( O > 1 ->
4598 NO is O -1,
4599 get_occurrence(C,NO,RuleNb,_),
4600 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4601 ;
4602 Heap2 = Heap1
4603 ),
4604 normalize_heap(Heap2,Priority,NHeap)
4605 ;
4606 NHeap = Heap
4607 ).
4609 % no more rule
4610 simplify_guards(_)
4611 <=>
4612 true.
4614 % The negation of the guard of a non-propagation rule is added
4615 % if its kept head constraints are a subset of the kept constraints of
4616 % the rule we're working on, and its removed head constraints (at least one)
4617 % are a subset of the removed constraints.
4619 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4620 <=>
4621 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4622 H1 \== [],
4623 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4624 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4625 |
4626 append(H1,H2,Heads),
4627 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4628 append(GuardList,DerivedInfo,GL1),
4629 normalize_conj_list(GL1,GL),
4630 append(GH_New1,GH,GH1),
4631 normalize_conj_list(GH1,GH_New),
4632 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4633 % PrevPrevRuleNb is PrevRuleNb-1,
4634 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4636 % if this isn't the case, we skip this one and try the next rule
4637 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4638 <=>
4639 ( N > 0 ->
4640 next_prev_rule(Heap,N1,NHeap),
4641 % N1 is N-1,
4642 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4643 ;
4644 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4645 ).
4647 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4648 <=>
4649 GH \== []
4650 |
4651 head_types_modes_condition(GH,H,TypeInfo),
4652 conj2list(TypeInfo,TI),
4653 term_variables(H,HeadVars),
4654 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4655 normalize_conj_list(Info,InfoL),
4656 append(H,InfoL,RelevantTerms),
4657 add_background_info([G|RelevantTerms],BGInfo),
4658 append(InfoL,BGInfo,AllInfo_),
4659 normalize_conj_list(AllInfo_,AllInfo),
4660 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4662 head_types_modes_condition([],H,true).
4663 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4664 types_modes_condition(H,GH,TI1),
4665 head_types_modes_condition(GHs,H,TI2).
4667 add_background_info(Term,Info) :-
4668 get_bg_info(GeneralInfo),
4669 add_background_info2(Term,TermInfo),
4670 append(GeneralInfo,TermInfo,Info).
4672 add_background_info2(X,[]) :- var(X), !.
4673 add_background_info2([],[]) :- !.
4674 add_background_info2([X|Xs],Info) :- !,
4675 add_background_info2(X,Info1),
4676 add_background_info2(Xs,Infos),
4677 append(Info1,Infos,Info).
4679 add_background_info2(X,Info) :-
4680 (functor(X,_,A), A>0 ->
4681 X =.. [_|XArgs],
4682 add_background_info2(XArgs,XArgInfo)
4683 ;
4684 XArgInfo = []
4685 ),
4686 get_bg_info(X,XInfo),
4687 append(XInfo,XArgInfo,Info).
4689 %%
4690 % when all earlier guards are added or skipped, we simplify the guard.
4691 % if it's different from the original one, we change the rule
4693 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4694 <=>
4695 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4696 G \== true, % let's not try to simplify this ;)
4697 append(M,GuardList,Info),
4698 (% if guard + context is a contradiction, it should be simplified to "fail"
4699 conj2list(G,GL), append(Info,GL,GuardWithContext),
4700 guard_entailment:entails_guard(GuardWithContext,fail) ->
4701 SimpleGuard = fail
4702 ;
4703 % otherwise we try to remove redundant conjuncts
4704 simplify_guard(G,B,Info,SimpleGuard,NB)
4705 ),
4706 G \== SimpleGuard % only do this if we can change the guard
4707 |
4708 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4709 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4711 %% normalize_conj_list(+List,-NormalList) is det.
4712 %
4713 % Removes =true= elements and flattens out conjunctions.
4715 normalize_conj_list(List,NormalList) :-
4716 list2conj(List,Conj),
4717 conj2list(Conj,NormalList).
4719 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4720 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4721 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4723 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4724 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4725 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4726 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4727 append(Renaming1,ExtraRenaming,Renaming2),
4728 list2conj(PrevMatchings,Match),
4729 negate_b(Match,HeadsDontMatch),
4730 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4731 list2conj(HeadsMatch,HeadsMatchBut),
4732 term_variables(Renaming2,RenVars),
4733 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4734 new_vars(MGVars,RenVars,ExtraRenaming2),
4735 append(Renaming2,ExtraRenaming2,Renaming),
4736 ( PrevGuard == true -> % true can't fail
4737 Info_ = HeadsDontMatch
4738 ;
4739 negate_b(PrevGuard,TheGuardFailed),
4740 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4741 ),
4742 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4743 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4744 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4745 list2conj(RenamedMatchings_,RenamedMatchings),
4746 apply_guard_wrt_term(H,RenamedG2,GH2),
4747 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4748 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4750 simplify_guard(G,B,Info,SG,NB) :-
4751 conj2list(G,LG),
4752 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4753 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4754 list2conj(SGL,SG).
4757 new_vars([],_,[]).
4758 new_vars([A|As],RV,ER) :-
4759 ( memberchk_eq(A,RV) ->
4760 new_vars(As,RV,ER)
4761 ;
4762 ER = [A-NewA,NewA-A|ER2],
4763 new_vars(As,RV,ER2)
4764 ).
4766 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4767 %
4768 % check if a list of constraints is a subset of another list of constraints
4769 % (multiset-subset), meanwhile computing a variable renaming to convert
4770 % one into the other.
4771 head_subset(H,Head,Renaming) :-
4772 head_subset(H,Head,Renaming,[],_).
4774 head_subset([],Remainder,Renaming,Renaming,Remainder).
4775 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4776 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4777 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4779 % check if A is in the list, remove it from Headleft
4780 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4781 ( variable_replacement(A,X,Acc,Renaming),
4782 Remainder = Xs
4783 ;
4784 Remainder = [X|RRemainder],
4785 head_member(Xs,A,Renaming,Acc,RRemainder)
4786 ).
4787 %-------------------------------------------------------------------------------%
4788 % memoing code to speed up repeated computation
4790 :- chr_constraint precompute_head_matchings/0.
4792 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4793 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4794 append(H1,H2,Heads),
4795 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4796 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4797 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4799 precompute_head_matchings <=> true.
4801 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4802 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4804 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4805 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4807 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4808 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4809 <=>
4810 Q1 = NHeads,
4811 Q2 = Matchings.
4812 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4814 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4815 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4816 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4817 %-------------------------------------------------------------------------------%
4819 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4820 extract_arguments(Heads,Arguments),
4821 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4822 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4824 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4825 extract_arguments(Heads,Arguments),
4826 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4827 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4829 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4830 extract_arguments(Heads,Arguments1),
4831 extract_arguments(MatchingFreeHeads,Arguments2),
4832 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4834 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4835 %
4836 % Returns list of arguments of given list of constraints.
4837 extract_arguments([],[]).
4838 extract_arguments([Constraint|Constraints],AllArguments) :-
4839 Constraint =.. [_|Arguments],
4840 append(Arguments,RestArguments,AllArguments),
4841 extract_arguments(Constraints,RestArguments).
4843 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4844 %
4845 % Substitutes arguments of constraints with those in the given list.
4847 substitute_arguments([],[],[]).
4848 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4849 functor(Constraint,F,N),
4850 split_at(N,Variables,Arguments,RestVariables),
4851 NConstraint =.. [F|Arguments],
4852 substitute_arguments(Constraints,RestVariables,NConstraints).
4854 make_matchings_explicit([],[],_,MC,MC,[]).
4855 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4856 ( var(Arg) ->
4857 ( memberchk_eq(Arg,VarAcc) ->
4858 list2disj(MatchingCondition,MatchingCondition_disj),
4859 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4860 NVarAcc = VarAcc
4861 ;
4862 Matchings = RestMatchings,
4863 NewVar = Arg,
4864 NVarAcc = [Arg|VarAcc]
4865 ),
4866 MatchingCondition2 = MatchingCondition
4867 ;
4868 functor(Arg,F,A),
4869 Arg =.. [F|RecArgs],
4870 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4871 FlatArg =.. [F|RecVars],
4872 ( RecMatchings == [] ->
4873 Matchings = [functor(NewVar,F,A)|RestMatchings]
4874 ;
4875 list2conj(RecMatchings,ArgM_conj),
4876 list2disj(MatchingCondition,MatchingCondition_disj),
4877 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4878 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4879 ),
4880 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4881 term_variables(Args,ArgVars),
4882 append(ArgVars,VarAcc,NVarAcc)
4883 ),
4884 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4887 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4888 %
4889 % Returns list of new variables and list of pairwise unifications between given list and variables.
4891 make_matchings_explicit_not_negated([],[],[]).
4892 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4893 Matchings = [Var = X|RMatchings],
4894 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4896 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4897 %
4898 % (Partially) applies substitutions of =Goal= to given list.
4900 apply_guard_wrt_term([],_Guard,[]).
4901 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4902 ( var(Term) ->
4903 apply_guard_wrt_variable(Guard,Term,NTerm)
4904 ;
4905 Term =.. [F|HArgs],
4906 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4907 NTerm =.. [F|NewHArgs]
4908 ),
4909 apply_guard_wrt_term(RH,Guard,RGH).
4911 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4912 %
4913 % (Partially) applies goal =Guard= wrt variable.
4915 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4916 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4917 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4918 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4919 ( Guard = (X = Y), Variable == X ->
4920 NVariable = Y
4921 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4922 functor(NVariable,Functor,Arity)
4923 ;
4924 NVariable = Variable
4925 ).
4928 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4929 % ALWAYS FAILING GUARDS
4930 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4932 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4933 ==>
4934 chr_pp_flag(check_impossible_rules,on),
4935 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4936 conj2list(G,GL),
4937 append(M,GuardList,Info),
4938 append(Info,GL,GuardWithContext),
4939 guard_entailment:entails_guard(GuardWithContext,fail)
4940 |
4941 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4942 set_all_passive(RuleNb).
4944 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4945 % HEAD SIMPLIFICATION
4946 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4948 % now we check the head matchings (guard may have been simplified meanwhile)
4949 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4950 <=>
4951 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4952 simplify_heads(M,GuardList,G,B,NewM,NewB),
4953 NewM \== [],
4954 extract_arguments(Head1,VH1),
4955 extract_arguments(Head2,VH2),
4956 extract_arguments(H,VH),
4957 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4958 substitute_arguments(Head1,H1,NewH1),
4959 substitute_arguments(Head2,H2,NewH2),
4960 append(NewB,NewB_,NewBody),
4961 list2conj(NewBody,BodyMatchings),
4962 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4963 (Head1 \== NewH1 ; Head2 \== NewH2 )
4964 |
4965 rule(RuleNb,NewRule).
4967 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4968 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4971 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4972 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4973 ( NH == M ->
4974 H2_ = M,
4975 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4976 ;
4977 (M = functor(X,F,A), NH == X ->
4978 length(A_args,A),
4979 (var(H2) ->
4980 NewB1 = [],
4981 H2_ =.. [F|A_args]
4982 ;
4983 H2 =.. [F|OrigArgs],
4984 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4985 H2_ =.. [F|A_args_]
4986 ),
4987 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4988 append(NewB1,NewB2,NewB)
4989 ;
4990 H2_ = H2,
4991 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4992 )
4993 ).
4995 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4996 ( NH == M ->
4997 H1_ = M,
4998 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4999 ;
5000 (M = functor(X,F,A), NH == X ->
5001 length(A_args,A),
5002 (var(H1) ->
5003 NewB1 = [],
5004 H1_ =.. [F|A_args]
5005 ;
5006 H1 =.. [F|OrigArgs],
5007 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
5008 H1_ =.. [F|A_args_]
5009 ),
5010 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
5011 append(NewB1,NewB2,NewB)
5012 ;
5013 H1_ = H1,
5014 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
5015 )
5016 ).
5018 use_same_args([],[],[],_,_,[]).
5019 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5020 var(OA),!,
5021 Out = OA,
5022 use_same_args(ROA,RNA,ROut,G,Body,NewB).
5023 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5024 nonvar(OA),!,
5025 ( common_variables(OA,Body) ->
5026 NewB = [NA = OA|NextB]
5027 ;
5028 NewB = NextB
5029 ),
5030 Out = NA,
5031 use_same_args(ROA,RNA,ROut,G,Body,NextB).
5034 simplify_heads([],_GuardList,_G,_Body,[],[]).
5035 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
5036 M = (A = B),
5037 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
5038 guard_entailment:entails_guard(GuardList,(A=B)) ->
5039 ( common_variables(B,G-RM-GuardList) ->
5040 NewB = NextB,
5041 NewM = NextM
5042 ;
5043 ( common_variables(B,Body) ->
5044 NewB = [A = B|NextB]
5045 ;
5046 NewB = NextB
5047 ),
5048 NewM = [A|NextM]
5049 )
5050 ;
5051 ( nonvar(B), functor(B,BFu,BAr),
5052 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
5053 NewB = NextB,
5054 ( common_variables(B,G-RM-GuardList) ->
5055 NewM = NextM
5056 ;
5057 NewM = [functor(A,BFu,BAr)|NextM]
5058 )
5059 ;
5060 NewM = NextM,
5061 NewB = NextB
5062 )
5063 ),
5064 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
5066 common_variables(B,G) :-
5067 term_variables(B,BVars),
5068 term_variables(G,GVars),
5069 intersect_eq(BVars,GVars,L),
5070 L \== [].
5073 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
5074 set_all_passive(_) <=> true.
5078 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5079 % OCCURRENCE SUBSUMPTION
5080 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5082 :- chr_constraint
5083 first_occ_in_rule/4,
5084 next_occ_in_rule/6.
5086 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
5087 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
5089 :- chr_constraint multiple_occ_constraints_checked/1.
5090 :- chr_option(mode,multiple_occ_constraints_checked(+)).
5092 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
5093 occurrence(C,O,RuleNb,ID,_),
5094 occurrence(C,O2,RuleNb,ID2,_),
5095 rule(RuleNb,Rule)
5096 \
5097 multiple_occ_constraints_checked(Done)
5098 <=>
5099 O < O2,
5100 chr_pp_flag(occurrence_subsumption,on),
5101 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
5102 H1 \== [],
5103 \+ tree_set_memberchk(C,Done)
5104 |
5105 first_occ_in_rule(RuleNb,C,O,ID),
5106 tree_set_add(Done,C,NDone),
5107 multiple_occ_constraints_checked(NDone).
5109 % Find first occurrence of constraint =C= in rule =RuleNb=
5110 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
5111 <=>
5112 O < O2
5113 |
5114 first_occ_in_rule(RuleNb,C,O,ID).
5116 first_occ_in_rule(RuleNb,C,O,ID_o1)
5117 <=>
5118 C = F/A,
5119 functor(FreshHead,F,A),
5120 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
5122 % Skip passive occurrences.
5123 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
5124 <=>
5125 O2 is O+1
5126 |
5127 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
5129 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)
5130 <=>
5131 O2 is O+1,
5132 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
5133 |
5134 append(H1,H2,Heads),
5135 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5136 ( ExtraCond == [chr_pp_void_info] ->
5137 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5138 ;
5139 append(ExtraCond,Cond,NewCond),
5140 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5141 copy_term(GuardList,FGuardList),
5142 variable_replacement(GuardList,FGuardList,GLRepl),
5143 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5144 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5145 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5146 append(NewCond,GuardList2,BigCond),
5147 append(BigCond,GuardList3,BigCond2),
5148 copy_with_variable_replacement(M,M2,Repl),
5149 copy_with_variable_replacement(M,M3,Repl2),
5150 append(M3,BigCond2,BigCond3),
5151 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5152 list2conj(CheckCond,OccSubsum),
5153 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5154 ( OccSubsum \= chr_pp_void_info ->
5155 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5156 passive(RuleNb,ID_o2)
5157 ;
5158 true
5159 )
5160 ;
5161 true
5162 ),!,
5163 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5164 ).
5167 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5168 <=>
5169 true.
5171 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5172 <=>
5173 true.
5175 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5176 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5177 append(ID2,ID1,IDs),
5178 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5179 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5180 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5181 copy_with_variable_replacement(G,FG,Repl),
5182 extract_explicit_matchings(FG,FG2),
5183 negate_b(FG2,NotFG),
5184 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5185 ( subsumes(FH,FH2) ->
5186 FailCond = [(NotFG;FMPCond)]
5187 ;
5188 % in this case, not much can be done
5189 % e.g. c(f(...)), c(g(...)) <=> ...
5190 FailCond = [chr_pp_void_info]
5191 ).
5193 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5194 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5195 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5196 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5197 Cond = (chr_pp_not_in_store(H);Cond1),
5198 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5200 extract_explicit_matchings((A,B),D) :- !,
5201 ( extract_explicit_matchings(A) ->
5202 extract_explicit_matchings(B,D)
5203 ;
5204 D = (A,E),
5205 extract_explicit_matchings(B,E)
5206 ).
5207 extract_explicit_matchings(A,D) :- !,
5208 ( extract_explicit_matchings(A) ->
5209 D = true
5210 ;
5211 D = A
5212 ).
5214 extract_explicit_matchings(A=B) :-
5215 var(A), var(B), !, A=B.
5216 extract_explicit_matchings(A==B) :-
5217 var(A), var(B), !, A=B.
5219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5220 % TYPE INFORMATION
5221 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5223 :- chr_constraint
5224 type_definition/2,
5225 type_alias/2,
5226 constraint_type/2,
5227 get_type_definition/2,
5228 get_constraint_type/2.
5231 :- chr_option(mode,type_definition(?,?)).
5232 :- chr_option(mode,get_type_definition(?,?)).
5233 :- chr_option(mode,type_alias(?,?)).
5234 :- chr_option(mode,constraint_type(+,+)).
5235 :- chr_option(mode,get_constraint_type(+,-)).
5237 assert_constraint_type(Constraint,ArgTypes) :-
5238 ( ground(ArgTypes) ->
5239 constraint_type(Constraint,ArgTypes)
5240 ;
5241 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5242 ).
5244 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5245 % Consistency checks of type aliases
5247 type_alias(T1,T2) <=>
5248 var(T1)
5249 |
5250 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5252 type_alias(T1,T2) <=>
5253 var(T2)
5254 |
5255 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5257 type_alias(T,T2) <=>
5258 functor(T,F,A),
5259 functor(T2,F,A),
5260 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5261 |
5262 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5264 type_alias(T1,A1), type_alias(T2,A2) <=>
5265 functor(T1,F,A),
5266 functor(T2,F,A),
5267 \+ (T1\=T2)
5268 |
5269 copy_term_nat(T1,T1_),
5270 copy_term_nat(T2,T2_),
5271 T1_ = T2_,
5272 chr_error(type_error,
5273 '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_]).
5275 type_alias(T,B) \ type_alias(X,T2) <=>
5276 functor(T,F,A),
5277 functor(T2,F,A),
5278 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5279 subsumes(T1,T3)
5280 |
5281 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5282 type_alias(X2,D1).
5284 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5285 % Consistency checks of type definitions
5287 type_definition(T1,_), type_definition(T2,_)
5288 <=>
5289 functor(T1,F,A), functor(T2,F,A)
5290 |
5291 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5293 type_definition(T1,_), type_alias(T2,_)
5294 <=>
5295 functor(T1,F,A), functor(T2,F,A)
5296 |
5297 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5299 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5300 %% get_type_definition(+Type,-Definition) is semidet.
5301 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5303 get_type_definition(T,Def)
5304 <=>
5305 \+ ground(T)
5306 |
5307 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5309 type_alias(T,D) \ get_type_definition(T2,Def)
5310 <=>
5311 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5312 copy_term_nat((T,D),(T1,D1)),T1=T2
5313 |
5314 ( get_type_definition(D1,Def) ->
5315 true
5316 ;
5317 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5318 ).
5320 type_definition(T,D) \ get_type_definition(T2,Def)
5321 <=>
5322 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5323 copy_term_nat((T,D),(T1,D1)),T1=T2
5324 |
5325 Def = D1.
5327 get_type_definition(Type,Def)
5328 <=>
5329 atomic_builtin_type(Type,_,_)
5330 |
5331 Def = [Type].
5333 get_type_definition(Type,Def)
5334 <=>
5335 compound_builtin_type(Type,_,_,_)
5336 |
5337 Def = [Type].
5339 get_type_definition(X,Y) <=> fail.
5341 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5342 %% get_type_definition_det(+Type,-Definition) is det.
5343 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5344 get_type_definition_det(Type,Definition) :-
5345 ( get_type_definition(Type,Definition) ->
5346 true
5347 ;
5348 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5349 ).
5351 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5352 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5353 %
5354 % Return argument types of =ConstraintSymbol=, but fails if none where
5355 % declared.
5356 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5357 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5358 get_constraint_type(_,_) <=> fail.
5360 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5361 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5362 %
5363 % Like =get_constraint_type/2=, but returns list of =any= types when
5364 % no types are declared.
5365 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5366 get_constraint_type_det(ConstraintSymbol,Types) :-
5367 ( get_constraint_type(ConstraintSymbol,Types) ->
5368 true
5369 ;
5370 ConstraintSymbol = _ / N,
5371 replicate(N,any,Types)
5372 ).
5373 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5374 %% unalias_type(+Alias,-Type) is det.
5375 %
5376 % Follows alias chain until base type is reached.
5377 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5378 :- chr_constraint unalias_type/2.
5380 unalias_var @
5381 unalias_type(Alias,BaseType)
5382 <=>
5383 var(Alias)
5384 |
5385 BaseType = Alias.
5387 unalias_alias @
5388 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5389 <=>
5390 nonvar(AliasProtoType),
5391 nonvar(Alias),
5392 functor(AliasProtoType,F,A),
5393 functor(Alias,F,A),
5394 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5395 Alias = AliasInstance
5396 |
5397 unalias_type(Type,BaseType).
5399 unalias_type_definition @
5400 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5401 <=>
5402 nonvar(ProtoType),
5403 nonvar(Alias),
5404 functor(ProtoType,F,A),
5405 functor(Alias,F,A)
5406 |
5407 BaseType = Alias.
5409 unalias_atomic_builtin @
5410 unalias_type(Alias,BaseType)
5411 <=>
5412 atomic_builtin_type(Alias,_,_)
5413 |
5414 BaseType = Alias.
5416 unalias_compound_builtin @
5417 unalias_type(Alias,BaseType)
5418 <=>
5419 compound_builtin_type(Alias,_,_,_)
5420 |
5421 BaseType = Alias.
5423 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5424 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5425 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5426 :- chr_constraint types_modes_condition/3.
5427 :- chr_option(mode,types_modes_condition(+,+,?)).
5428 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5430 types_modes_condition([],[],T) <=> T=true.
5432 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5433 <=>
5434 functor(Head,F,A)
5435 |
5436 Head =.. [_|Args],
5437 Condition = (ModesCondition, TypesCondition, RestCondition),
5438 modes_condition(Modes,Args,ModesCondition),
5439 get_constraint_type_det(F/A,Types),
5440 UnrollHead =.. [_|RealArgs],
5441 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5442 types_modes_condition(Heads,UnrollHeads,RestCondition).
5444 types_modes_condition([Head|_],_,_)
5445 <=>
5446 functor(Head,F,A),
5447 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5450 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5451 %% modes_condition(+Modes,+Args,-Condition) is det.
5452 %
5453 % Return =Condition= on =Args= that checks =Modes=.
5454 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5455 modes_condition([],[],true).
5456 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5457 ( Mode == (+) ->
5458 Condition = ( ground(Arg) , RCondition )
5459 ; Mode == (-) ->
5460 Condition = ( var(Arg) , RCondition )
5461 ;
5462 Condition = RCondition
5463 ),
5464 modes_condition(Modes,Args,RCondition).
5466 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5467 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5468 %
5469 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5470 % =UnrollArgs= controls the depth of type definition unrolling.
5471 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5472 types_condition([],[],[],[],true).
5473 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5474 ( Mode == (-) ->
5475 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5476 ;
5477 get_type_definition_det(Type,Def),
5478 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5479 ( Mode == (+) ->
5480 TypeConditionList = TypeConditionList1
5481 ;
5482 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5483 )
5484 ),
5485 list2disj(TypeConditionList,DisjTypeConditionList),
5486 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5488 type_condition([],_,_,_,[]).
5489 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5490 ( var(DefCase) ->
5491 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5492 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5493 true
5494 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5495 true
5496 ;
5497 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5498 ),
5499 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5501 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5502 :- chr_type atomic_builtin_type ---> any
5503 ; number
5504 ; float
5505 ; int
5506 ; natural
5507 ; dense_int
5508 ; chr_identifier
5509 ; chr_identifier(any)
5510 ; /* all possible values are given
5511 */
5512 chr_enum(list(any))
5513 ; /* all values of interest are given
5514 for the other values a handler is provided */
5515 chr_enum(list(any),any)
5516 ; /* all possible values appear in rule heads;
5517 to distinguish between multiple chr_constants
5518 we have a key*/
5519 chr_constants(any)
5520 ; /* all relevant values appear in rule heads;
5521 for other values a handler is provided */
5522 chr_constants(any,any).
5523 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5525 ast_atomic_builtin_type(Type,AstTerm,Goal) :-
5526 ast_term_to_term(AstTerm,Term),
5527 atomic_builtin_type(Type,Term,Goal).
5529 ast_compound_builtin_type(Type,AstTerm,Goal) :-
5530 ast_term_to_term(AstTerm,Term),
5531 compound_builtin_type(Type,Term,_,Goal).
5533 atomic_builtin_type(any,_Arg,true).
5534 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5535 atomic_builtin_type(int,Arg,integer(Arg)).
5536 atomic_builtin_type(number,Arg,number(Arg)).
5537 atomic_builtin_type(float,Arg,float(Arg)).
5538 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5539 atomic_builtin_type(chr_identifier,_Arg,true).
5541 compound_builtin_type(chr_constants(_),_Arg,true,true).
5542 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5543 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5544 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5545 once(( member(Constant,Constants),
5546 unifiable(Arg,Constant,_)
5547 )
5548 )
5549 ).
5550 compound_builtin_type(chr_enum(_,_),Arg,true,true).
5552 is_chr_constants_type(chr_constants(Key),Key,no).
5553 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5555 is_chr_enum_type(chr_enum(Constants), Constants, no).
5556 is_chr_enum_type(chr_enum(Constants,Handler), Constants, yes(Handler)).
5558 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5559 ( nonvar(DefCase) ->
5560 functor(DefCase,F,A),
5561 ( A == 0 ->
5562 Condition = (Arg = DefCase)
5563 ; var(UnrollArg) ->
5564 Condition = functor(Arg,F,A)
5565 ; functor(UnrollArg,F,A) ->
5566 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5567 DefCase =.. [_|ArgTypes],
5568 UnrollArg =.. [_|UnrollArgs],
5569 functor(Template,F,A),
5570 Template =.. [_|TemplateArgs],
5571 replicate(A,Mode,ArgModes),
5572 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5573 ;
5574 Condition = functor(Arg,F,A)
5575 )
5576 ;
5577 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5578 ).
5581 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5582 % STATIC TYPE CHECKING
5583 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5584 % Checks head constraints and CHR constraint calls in bodies.
5585 %
5586 % TODO:
5587 % - type clashes involving built-in types
5588 % - Prolog built-ins in guard and body
5589 % - indicate position in terms in error messages
5590 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5591 :- chr_constraint
5592 static_type_check/2.
5594 % 1. Check the declared types
5596 constraint_type(Constraint,ArgTypes), static_type_check(_,_)
5597 ==>
5598 forall(
5599 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5600 ( get_type_definition(Type,_) ->
5601 true
5602 ;
5603 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5604 )
5605 ).
5607 % 2. Check the rules
5609 :- chr_type type_error_src ---> head(any) ; body(any).
5611 static_type_check(PragmaRules,AstRules)
5612 <=>
5613 maplist(static_type_check_rule,PragmaRules,AstRules).
5615 static_type_check_rule(PragmaRule,AstRule) :-
5616 AstRule = ast_rule(AstHead,_AstGuard,_Guard,AstBody,_Body),
5617 (
5618 catch(
5619 ( ast_static_type_check_head(AstHead),
5620 ast_static_type_check_body(AstBody)
5621 ),
5622 type_error(Error),
5623 ( Error = invalid_functor(Src,Term,Type) ->
5624 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5625 [chr_translate:format_src(Src),format_rule(PragmaRule),Term,Type])
5626 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5627 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5628 [Var,format_rule(PragmaRule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5629 )
5630 ),
5631 fail % cleanup constraints
5632 ;
5633 true
5634 ).
5636 %------------------------------------------------------------------------------%
5637 % Static Type Checking: Head Constraints {{{
5638 ast_static_type_check_head(simplification(AstConstraints)) :-
5639 maplist(ast_static_type_check_head_constraint,AstConstraints).
5640 ast_static_type_check_head(propagation(AstConstraints)) :-
5641 maplist(ast_static_type_check_head_constraint,AstConstraints).
5642 ast_static_type_check_head(simpagation(AstConstraints1,AstConstraints2)) :-
5643 maplist(ast_static_type_check_head_constraint,AstConstraints1),
5644 maplist(ast_static_type_check_head_constraint,AstConstraints2).
5646 ast_static_type_check_head_constraint(AstConstraint) :-
5647 AstConstraint = chr_constraint(Symbol,Arguments,_),
5648 get_constraint_type_det(Symbol,Types),
5649 maplist(ast_static_type_check_term(head(Head)),Arguments,Types).
5650 % }}}
5651 %------------------------------------------------------------------------------%
5652 % Static Type Checking: Terms {{{
5653 :- chr_constraint ast_static_type_check_term/3.
5654 :- chr_option(mode,ast_static_type_check_term(?,?,?)).
5655 :- chr_option(type_declaration,ast_static_type_check_term(type_error_src,any,any)).
5657 ast_static_type_check_term(_,_,any)
5658 <=>
5659 true.
5661 ast_static_type_check_term(Src,var(Id,Var),Type)
5662 <=>
5663 ast_static_type_check_var(Id,var(Id,Var),Type,Src).
5665 ast_static_type_check_term(Src,Term,Type)
5666 <=>
5667 ast_atomic_builtin_type(Type,Term,Goal)
5668 |
5669 ( call(Goal) ->
5670 true
5671 ;
5672 throw(type_error(invalid_functor(Src,Term,Type)))
5673 ).
5674 ast_static_type_check_term(Src,Term,Type)
5675 <=>
5676 ast_compound_builtin_type(Type,Term,Goal)
5677 |
5678 ( call(Goal) ->
5679 true
5680 ;
5681 throw(type_error(invalid_functor(Src,Term,Type)))
5682 ).
5683 type_alias(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5684 <=>
5685 functor(Type,F,A),
5686 functor(AType,F,A)
5687 |
5688 copy_term_nat(AType-ADef,Type-Def),
5689 ast_static_type_check_term(Src,Term,Def).
5691 type_definition(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5692 <=>
5693 functor(Type,F,A),
5694 functor(AType,F,A)
5695 |
5696 copy_term_nat(AType-ADef,Type-Variants),
5697 ast_functor(Term,TF,TA),
5698 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5699 ast_args(Term,Args),
5700 Variant =.. [_|Types],
5701 maplist(ast_static_type_check_term(Src),Args,Types)
5702 ;
5703 throw(type_error(invalid_functor(Src,Term,Type)))
5704 ).
5706 ast_static_type_check_term(Src,Term,Type)
5707 <=>
5708 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5709 % }}}
5710 %------------------------------------------------------------------------------%
5711 % Static Type Checking: Variables {{{
5713 :- chr_constraint ast_static_type_check_var/4.
5714 :- chr_option(mode,ast_static_type_check_var(+,?,?,?)).
5715 :- chr_option(type_declaration,ast_static_type_check_var(var_id,any,any,type_error_src)).
5717 type_alias(AType,ADef) \ ast_static_type_check_var(VarId,Var,Type,Src)
5718 <=>
5719 functor(AType,F,A),
5720 functor(Type,F,A)
5721 |
5722 copy_term_nat(AType-ADef,Type-Def),
5723 ast_static_type_check_var(VarId,Var,Def,Src).
5725 ast_static_type_check_var(VarId,Var,Type,Src)
5726 <=>
5727 atomic_builtin_type(Type,_,_)
5728 |
5729 ast_static_atomic_builtin_type_check_var(VarId,Var,Type,Src).
5731 ast_static_type_check_var(VarId,Var,Type,Src)
5732 <=>
5733 compound_builtin_type(Type,_,_,_)
5734 |
5735 true.
5738 ast_static_type_check_var(VarId,Var,Type1,Src1), ast_static_type_check_var(VarId,_Var,Type2,Src2)
5739 <=>
5740 Type1 \== Type2
5741 |
5742 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5744 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5745 :- chr_constraint ast_static_atomic_builtin_type_check_var/4.
5746 :- chr_option(mode,ast_static_atomic_builtin_type_check_var(+,?,+,?)).
5747 :- chr_option(type_declaration,ast_static_atomic_builtin_type_check_var(var_id,any,atomic_builtin_type,type_error_src)).
5749 ast_static_atomic_builtin_type_check_var(_,_,any,_) <=> true.
5750 ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_)
5751 <=>
5752 true.
5753 ast_static_atomic_builtin_type_check_var(VarId,_,float,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5754 <=>
5755 true.
5756 ast_static_atomic_builtin_type_check_var(VarId,_,int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5757 <=>
5758 true.
5759 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5760 <=>
5761 true.
5762 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5763 <=>
5764 true.
5765 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5766 <=>
5767 true.
5768 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5769 <=>
5770 true.
5771 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,natural,_)
5772 <=>
5773 true.
5774 ast_static_atomic_builtin_type_check_var(VarId,Var,Type1,Src1), ast_static_atomic_builtin_type_check_var(VarId,_Var,Type2,Src2)
5775 <=>
5776 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5777 % }}}
5778 %------------------------------------------------------------------------------%
5779 % Static Type Checking: Bodies {{{
5780 ast_static_type_check_body([]).
5781 ast_static_type_check_body([Goal|Goals]) :-
5782 ast_symbol(Goal,Symbol),
5783 get_constraint_type_det(Symbol,Types),
5784 ast_args(Goal,Args),
5785 maplist(ast_static_type_check_term(body(Goal)),Args,Types),
5786 ast_static_type_check_body(Goals).
5788 % }}}
5789 %------------------------------------------------------------------------------%
5791 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5792 %% format_src(+type_error_src) is det.
5793 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5794 format_src(head(Head)) :- format('head ~w',[Head]).
5795 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5797 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5798 % Dynamic type checking
5799 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5801 :- chr_constraint
5802 dynamic_type_check/0,
5803 dynamic_type_check_clauses/1,
5804 get_dynamic_type_check_clauses/1.
5806 generate_dynamic_type_check_clauses(Clauses) :-
5807 ( chr_pp_flag(debugable,on) ->
5808 dynamic_type_check,
5809 get_dynamic_type_check_clauses(Clauses0),
5810 append(Clauses0,
5811 [('$dynamic_type_check'(Type,Term) :-
5812 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5813 )],
5814 Clauses)
5815 ;
5816 Clauses = []
5817 ).
5819 type_definition(T,D), dynamic_type_check
5820 ==>
5821 copy_term_nat(T-D,Type-Definition),
5822 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5823 dynamic_type_check_clauses(DynamicChecks).
5824 type_alias(A,B), dynamic_type_check
5825 ==>
5826 copy_term_nat(A-B,Alias-Body),
5827 dynamic_type_check_alias_clause(Alias,Body,Clause),
5828 dynamic_type_check_clauses([Clause]).
5830 dynamic_type_check <=>
5831 findall(
5832 ('$dynamic_type_check'(Type,Term) :- Goal),
5833 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5834 BuiltinChecks
5835 ),
5836 dynamic_type_check_clauses(BuiltinChecks).
5838 dynamic_type_check_clause(T,DC,Clause) :-
5839 copy_term(T-DC,Type-DefinitionClause),
5840 functor(DefinitionClause,F,A),
5841 functor(Term,F,A),
5842 DefinitionClause =.. [_|DCArgs],
5843 Term =.. [_|TermArgs],
5844 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5845 list2conj(RecursiveCallList,RecursiveCalls),
5846 Clause = (
5847 '$dynamic_type_check'(Type,Term) :-
5848 RecursiveCalls
5849 ).
5851 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5852 Clause = (
5853 '$dynamic_type_check'(Alias,Term) :-
5854 '$dynamic_type_check'(Body,Term)
5855 ).
5857 dynamic_type_check_call(Type,Term,Call) :-
5858 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5859 % Call = when(nonvar(Term),Goal)
5860 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5861 % Call = when(nonvar(Term),Goal)
5862 % ;
5863 ( Type == any ->
5864 Call = true
5865 ;
5866 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5867 )
5868 % )
5869 .
5871 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5872 <=>
5873 append(C1,C2,C),
5874 dynamic_type_check_clauses(C).
5876 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5877 <=>
5878 Q = C.
5879 get_dynamic_type_check_clauses(Q)
5880 <=>
5881 Q = [].
5883 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5884 % Atomic Types
5885 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5886 % Some optimizations can be applied for atomic types...
5887 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5889 atomic_types_suspended_constraint(C) :-
5890 C = _/N,
5891 get_constraint_type(C,ArgTypes),
5892 get_constraint_mode(C,ArgModes),
5893 numlist(1,N,Indexes),
5894 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5896 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5897 ( is_indexed_argument(C,Index) ->
5898 ( Mode == (?) ->
5899 atomic_type(Type)
5900 ;
5901 true
5902 )
5903 ;
5904 true
5905 ).
5907 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5908 %% atomic_type(+Type) is semidet.
5909 %
5910 % Succeeds when all values of =Type= are atomic.
5911 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5912 :- chr_constraint atomic_type/1.
5914 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5916 type_definition(TypePat,Def) \ atomic_type(Type)
5917 <=>
5918 functor(Type,F,A), functor(TypePat,F,A)
5919 |
5920 maplist(atomic,Def).
5922 type_alias(TypePat,Alias) \ atomic_type(Type)
5923 <=>
5924 functor(Type,F,A), functor(TypePat,F,A)
5925 |
5926 atomic(Alias),
5927 copy_term_nat(TypePat-Alias,Type-NType),
5928 atomic_type(NType).
5930 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5931 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5932 %
5933 % Succeeds when all values of =Type= are atomic
5934 % and the atom values are finitely enumerable.
5935 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5936 :- chr_constraint enumerated_atomic_type/2.
5938 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5940 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5941 <=>
5942 functor(Type,F,A), functor(TypePat,F,A)
5943 |
5944 maplist(atomic,Def),
5945 Atoms = Def.
5947 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5948 <=>
5949 functor(Type,F,A), functor(TypePat,F,A)
5950 |
5951 atomic(Alias),
5952 copy_term_nat(TypePat-Alias,Type-NType),
5953 enumerated_atomic_type(NType,Atoms).
5955 enumerated_atomic_type(_,_)
5956 <=>
5957 fail.
5958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5960 :- chr_constraint
5961 stored/3, % constraint,occurrence,(yes/no/maybe)
5962 stored_completing/3,
5963 stored_complete/3,
5964 is_stored/1,
5965 is_finally_stored/1,
5966 check_all_passive/2.
5968 :- chr_option(mode,stored(+,+,+)).
5969 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5970 :- chr_type storedinfo ---> yes ; no ; maybe.
5971 :- chr_option(mode,stored_complete(+,+,+)).
5972 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5973 :- chr_option(mode,guard_list(+,+,+,+)).
5974 :- chr_option(mode,check_all_passive(+,+)).
5975 :- chr_option(type_declaration,check_all_passive(any,list)).
5977 % change yes in maybe when yes becomes passive
5978 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5979 stored(C,O,yes), stored_complete(C,RO,Yesses)
5980 <=> O < RO | NYesses is Yesses - 1,
5981 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5982 % change yes in maybe when not observed
5983 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5984 <=> O < RO |
5985 NYesses is Yesses - 1,
5986 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5988 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5989 ==> RO =< MO2 | % C2 is never stored
5990 passive(RuleNb,ID).
5995 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5997 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5998 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5999 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
6001 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
6002 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
6003 check_all_passive(RuleNb,IDs2).
6005 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
6006 check_all_passive(RuleNb,IDs).
6008 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
6009 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
6011 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6013 % collect the storage information
6014 stored(C,O,yes) \ stored_completing(C,O,Yesses)
6015 <=> NO is O + 1, NYesses is Yesses + 1,
6016 stored_completing(C,NO,NYesses).
6017 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
6018 <=> NO is O + 1,
6019 stored_completing(C,NO,Yesses).
6021 stored(C,O,no) \ stored_completing(C,O,Yesses)
6022 <=> stored_complete(C,O,Yesses).
6023 stored_completing(C,O,Yesses)
6024 <=> stored_complete(C,O,Yesses).
6026 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
6027 O2 > O | passive(RuleNb,Id).
6029 % decide whether a constraint is stored
6030 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
6031 <=> RO =< MO | fail.
6032 is_stored(C) <=> true.
6034 % decide whether a constraint is suspends after occurrences
6035 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
6036 <=> RO =< MO | fail.
6037 is_finally_stored(C) <=> true.
6039 storage_analysis(Constraints) :-
6040 ( chr_pp_flag(storage_analysis,on) ->
6041 check_constraint_storages(Constraints)
6042 ;
6043 true
6044 ).
6046 check_constraint_storages(Symbols) :- maplist(check_constraint_storage,Symbols).
6048 check_constraint_storage(C) :-
6049 get_max_occurrence(C,MO),
6050 check_occurrences_storage(C,1,MO).
6052 check_occurrences_storage(C,O,MO) :-
6053 ( O > MO ->
6054 stored_completing(C,1,0)
6055 ;
6056 check_occurrence_storage(C,O),
6057 NO is O + 1,
6058 check_occurrences_storage(C,NO,MO)
6059 ).
6061 check_occurrence_storage(C,O) :-
6062 get_occurrence(C,O,RuleNb,ID,OccType),
6063 ( is_passive(RuleNb,ID) ->
6064 stored(C,O,maybe)
6065 ;
6066 get_rule(RuleNb,PragmaRule),
6067 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
6068 ( OccType == simplification, select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6069 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
6070 ; OccType == propagation, select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6071 check_storage_head2(Head2,O,Heads1,Body)
6072 )
6073 ).
6075 check_storage_head1(Head,O,H1,H2,G) :-
6076 functor(Head,F,A),
6077 C = F/A,
6078 ( H1 == [Head],
6079 H2 == [],
6080 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
6081 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
6082 Head =.. [_|L],
6083 no_matching(L,[]) ->
6084 stored(C,O,no)
6085 ;
6086 stored(C,O,maybe)
6087 ).
6089 no_matching([],_).
6090 no_matching([X|Xs],Prev) :-
6091 var(X),
6092 \+ memberchk_eq(X,Prev),
6093 no_matching(Xs,[X|Prev]).
6095 check_storage_head2(Head,O,H1,B) :-
6096 functor(Head,F,A),
6097 C = F/A,
6098 ( %(
6099 ( H1 \== [], B == true )
6100 %;
6101 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
6102 %)
6103 ->
6104 stored(C,O,maybe)
6105 ;
6106 stored(C,O,yes)
6107 ).
6109 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6111 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6112 %% ____ _ ____ _ _ _ _
6113 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
6114 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
6115 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
6116 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
6117 %% |_|
6119 constraints_code(Constraints,Clauses) :-
6120 (chr_pp_flag(reduced_indexing,on),
6121 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
6122 none_suspended_on_variables
6123 ;
6124 true
6125 ),
6126 constraints_code1(Constraints,Clauses,[]).
6128 %===============================================================================
6129 :- chr_constraint constraints_code1/3.
6130 :- chr_option(mode,constraints_code1(+,+,+)).
6131 :- chr_option(type_declaration,constraints_code1(list,any,any)).
6132 %-------------------------------------------------------------------------------
6133 constraints_code1([],L,T) <=> L = T.
6134 constraints_code1([C|RCs],L,T)
6135 <=>
6136 constraint_code(C,L,T1),
6137 constraints_code1(RCs,T1,T).
6138 %===============================================================================
6139 :- chr_constraint constraint_code/3.
6140 :- chr_option(mode,constraint_code(+,+,+)).
6141 %-------------------------------------------------------------------------------
6142 %% Generate code for a single CHR constraint
6143 constraint_code(Constraint, L, T)
6144 <=> true
6145 | ( (chr_pp_flag(debugable,on) ;
6146 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
6147 ( may_trigger(Constraint) ;
6148 get_allocation_occurrence(Constraint,AO),
6149 get_max_occurrence(Constraint,MO), MO >= AO ) )
6150 ->
6151 constraint_prelude(Constraint,Clause),
6152 add_dummy_location(Clause,LocatedClause),
6153 L = [LocatedClause | L1]
6154 ;
6155 L = L1
6156 ),
6157 Id = [0],
6158 occurrences_code(Constraint,1,Id,NId,L1,L2),
6159 gen_cond_attach_clause(Constraint,NId,L2,T).
6161 %===============================================================================
6162 %% Generate prelude predicate for a constraint.
6163 %% f(...) :- f/a_0(...,Susp).
6164 constraint_prelude(F/A, Clause) :-
6165 vars_susp(A,Vars,Susp,VarsSusp),
6166 Head =.. [ F | Vars],
6167 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6168 build_head(F,A,[0],VarsSusp,Delegate),
6169 ( chr_pp_flag(debugable,on) ->
6170 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6171 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6172 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6173 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6175 ( get_constraint_type(F/A,ArgTypeList) ->
6176 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6177 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6178 ;
6179 DynamicTypeChecks = true
6180 ),
6182 Clause =
6183 ( Head :-
6184 DynamicTypeChecks,
6185 InsertGoal,
6186 InsertCall,
6187 AttachCall,
6188 Inactive,
6189 'chr debug_event'(insert(Head#Susp)),
6190 (
6191 'chr debug_event'(call(Susp)),
6192 Delegate
6193 ;
6194 'chr debug_event'(fail(Susp)), !,
6195 fail
6196 ),
6197 (
6198 'chr debug_event'(exit(Susp))
6199 ;
6200 'chr debug_event'(redo(Susp)),
6201 fail
6202 )
6203 )
6204 ; get_allocation_occurrence(F/A,0) ->
6205 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6206 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6207 Clause = ( Head :- Goal, Inactive, Delegate )
6208 ;
6209 Clause = ( Head :- Delegate )
6210 ).
6212 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6213 ( may_trigger(F/A) ->
6214 build_head(F,A,[0],VarsSusp,Delegate),
6215 ( chr_pp_flag(debugable,off) ->
6216 Goal = Delegate
6217 ;
6218 get_target_module(Mod),
6219 Goal = Mod:Delegate
6220 )
6221 ;
6222 Goal = true
6223 ).
6225 %===============================================================================
6226 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6227 :- chr_option(mode,has_active_occurrence(+)).
6228 :- chr_option(mode,has_active_occurrence(+,+)).
6230 :- chr_constraint memo_has_active_occurrence/1.
6231 :- chr_option(mode,memo_has_active_occurrence(+)).
6232 %-------------------------------------------------------------------------------
6233 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6234 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6236 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6237 O > MO | fail.
6238 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6239 has_active_occurrence(C,O) <=>
6240 NO is O + 1,
6241 has_active_occurrence(C,NO).
6242 has_active_occurrence(C,O) <=> true.
6243 %===============================================================================
6245 gen_cond_attach_clause(F/A,Id,L,T) :-
6246 ( is_finally_stored(F/A) ->
6247 get_allocation_occurrence(F/A,AllocationOccurrence),
6248 get_max_occurrence(F/A,MaxOccurrence),
6249 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6250 ( only_ground_indexed_arguments(F/A) ->
6251 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6252 ;
6253 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6254 )
6255 ; vars_susp(A,Args,Susp,AllArgs),
6256 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6257 ),
6258 build_head(F,A,Id,AllArgs,Head),
6259 Clause = ( Head :- Body ),
6260 add_dummy_location(Clause,LocatedClause),
6261 L = [LocatedClause | T]
6262 ;
6263 L = T
6264 ).
6266 :- chr_constraint use_auxiliary_predicate/1.
6267 :- chr_option(mode,use_auxiliary_predicate(+)).
6269 :- chr_constraint use_auxiliary_predicate/2.
6270 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6272 :- chr_constraint is_used_auxiliary_predicate/1.
6273 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6275 :- chr_constraint is_used_auxiliary_predicate/2.
6276 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6279 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6281 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6283 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6285 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6287 is_used_auxiliary_predicate(P) <=> fail.
6289 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6290 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6292 is_used_auxiliary_predicate(P,C) <=> fail.
6294 %------------------------------------------------------------------------------%
6295 % Only generate import statements for actually used modules.
6296 %------------------------------------------------------------------------------%
6298 :- chr_constraint use_auxiliary_module/1.
6299 :- chr_option(mode,use_auxiliary_module(+)).
6301 :- chr_constraint is_used_auxiliary_module/1.
6302 :- chr_option(mode,is_used_auxiliary_module(+)).
6305 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6307 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6309 is_used_auxiliary_module(P) <=> fail.
6311 % only called for constraints with
6312 % at least one
6313 % non-ground indexed argument
6314 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6315 vars_susp(A,Args,Susp,AllArgs),
6316 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6317 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6318 Attach = true
6319 ;
6320 attach_constraint_atom(F/A,Vars,Susp,Attach)
6321 ),
6322 FTerm =.. [F|Args],
6323 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6324 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6325 ( may_trigger(F/A) ->
6326 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6327 Goal =
6328 (
6329 ( var(Susp) ->
6330 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6331 InsertCall,
6332 Attach
6333 ;
6334 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6335 )
6336 )
6337 ;
6338 Goal =
6339 (
6340 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6341 InsertCall,
6342 Attach
6343 )
6344 ).
6346 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6347 vars_susp(A,Args,Susp,AllArgs),
6348 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6349 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6350 attach_constraint_atom(F/A,Vars,Susp,Attach)
6351 ;
6352 Attach = true
6353 ),
6354 FTerm =.. [F|Args],
6355 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6356 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6357 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6358 Goal =
6359 (
6360 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6361 InsertCall
6362 )
6363 ;
6364 Goal =
6365 (
6366 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6367 InsertCall,
6368 Attach
6369 )
6370 ).
6372 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6373 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6374 attach_constraint_atom(FA,Vars,Susp,Attach)
6375 ;
6376 Attach = true
6377 ),
6378 insert_constraint_goal(FA,Susp,Args,InsertCall),
6379 ( chr_pp_flag(late_allocation,on) ->
6380 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6381 ;
6382 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6383 ).
6385 %-------------------------------------------------------------------------------
6386 :- chr_constraint occurrences_code/6.
6387 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6388 %-------------------------------------------------------------------------------
6389 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6390 <=> O > MO
6391 | NId = Id, L = T.
6392 occurrences_code(C,O,Id,NId,L,T)
6393 <=>
6394 occurrence_code(C,O,Id,Id1,L,L1),
6395 NO is O + 1,
6396 occurrences_code(C,NO,Id1,NId,L1,T).
6397 %-------------------------------------------------------------------------------
6398 :- chr_constraint occurrence_code/6.
6399 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6400 %-------------------------------------------------------------------------------
6401 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6402 <=>
6403 ( named_history(RuleNb,_,_) ->
6404 does_use_history(C,O)
6405 ;
6406 true
6407 ),
6408 NId = Id,
6409 L = T.
6410 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6411 <=> true |
6412 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6413 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6414 NId = Id,
6415 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6416 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6418 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6419 ( should_skip_to_next_id(C,O) ->
6420 inc_id(Id,NId),
6421 ( unconditional_occurrence(C,O) ->
6422 L1 = T
6423 ;
6424 gen_alloc_inc_clause(C,O,Id,L1,T)
6425 )
6426 ;
6427 NId = Id,
6428 L1 = T
6429 )
6430 ).
6432 occurrence_code(C,O,_,_,_,_)
6433 <=>
6434 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6435 %-------------------------------------------------------------------------------
6437 %% Generate code based on one removed head of a CHR rule
6438 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6439 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6440 Rule = rule(_,Head2,_,_),
6441 ( Head2 == [] ->
6442 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6443 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6444 ;
6445 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6446 ).
6448 %% Generate code based on one persistent head of a CHR rule
6449 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6450 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6451 Rule = rule(Head1,_,_,_),
6452 ( Head1 == [] ->
6453 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6454 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6455 ;
6456 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6457 ).
6459 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6460 vars_susp(A,Vars,Susp,VarsSusp),
6461 build_head(F,A,Id,VarsSusp,Head),
6462 inc_id(Id,IncId),
6463 build_head(F,A,IncId,VarsSusp,CallHead),
6464 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6465 Clause =
6466 (
6467 Head :-
6468 ConditionalAlloc,
6469 CallHead
6470 ),
6471 add_dummy_location(Clause,LocatedClause),
6472 L = [LocatedClause|T].
6474 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6475 get_allocation_occurrence(FA,AO),
6476 get_occurrence_code_id(FA,AO,AId),
6477 get_occurrence_code_id(FA,O,Id),
6478 ( chr_pp_flag(debugable,off), Id == AId ->
6479 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6480 ( may_trigger(FA) ->
6481 Goal = (var(Susp) -> Goal0 ; true)
6482 ;
6483 Goal = Goal0
6484 )
6485 ;
6486 Goal = true
6487 ).
6489 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6490 get_allocation_occurrence(FA,AO),
6491 ( chr_pp_flag(debugable,off), O < AO ->
6492 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6493 ( may_trigger(FA) ->
6494 Goal = (var(Susp) -> Goal0 ; true)
6495 ;
6496 Goal = Goal0
6497 )
6498 ;
6499 Goal = true
6500 ).
6502 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6504 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6505 %
6506 % Reorders guard goals with respect to partner constraint retrieval goals and
6507 % active constraint. Returns combined partner retrieval + guard goal.
6509 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6510 ( chr_pp_flag(guard_via_reschedule,on) ->
6511 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6512 list2conj(ScheduleSkeleton,GoalSkeleton)
6513 ;
6514 length(Retrievals,RL), length(LookupSkeleton,RL),
6515 length(GuardList,GL), length(GuardListSkeleton,GL),
6516 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6517 list2conj(GoalListSkeleton,GoalSkeleton)
6518 ).
6519 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6520 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6521 initialize_unit_dictionary(ActiveHead,Dict),
6522 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6523 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6524 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6525 dependency_reorder(Units,NUnits),
6526 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6527 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6528 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6530 wrappedunits2lists([],[],[],[]).
6531 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6532 Ss = [GoalCopy|TSs],
6533 ( WrappedGoal = lookup(Goal) ->
6534 Ls = [GoalCopy|TLs],
6535 Gs = TGs
6536 ; WrappedGoal = guard(Goal) ->
6537 Gs = [N-GoalCopy|TGs],
6538 Ls = TLs
6539 ),
6540 wrappedunits2lists(Units,TGs,TLs,TSs).
6542 guard_splitting(Rule,SplitGuardList) :-
6543 Rule = rule(H1,H2,Guard,_),
6544 append(H1,H2,Heads),
6545 conj2list(Guard,GuardList),
6546 term_variables(Heads,HeadVars),
6547 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6548 append(GuardPrefix,[RestGuard],SplitGuardList),
6549 term_variables(RestGuardList,GuardVars1),
6550 % variables that are declared to be ground don't need to be locked
6551 ground_vars(Heads,GroundVars),
6552 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6553 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6554 maplist(chr_lock,GuardVars,Locks),
6555 maplist(chr_unlock,GuardVars,Unlocks),
6556 list2conj(Locks,LockPhase),
6557 list2conj(Unlocks,UnlockPhase),
6558 list2conj(RestGuardList,RestGuard1),
6559 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6561 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6562 Rule = rule(_,_,_,Body),
6563 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6564 my_term_copy(Body,VarDict2,BodyCopy).
6567 split_off_simple_guard_new([],_,[],[]).
6568 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6569 ( simple_guard_new(G,VarDict) ->
6570 S = [G|Ss],
6571 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6572 ;
6573 S = [],
6574 C = [G|Gs]
6575 ).
6577 % simple guard: cheap and benign (does not bind variables)
6578 simple_guard_new(G,Vars) :-
6579 builtin_binds_b(G,BoundVars),
6580 not(( member(V,BoundVars),
6581 memberchk_eq(V,Vars)
6582 )).
6584 dependency_reorder(Units,NUnits) :-
6585 dependency_reorder(Units,[],NUnits).
6587 dependency_reorder([],Acc,Result) :-
6588 reverse(Acc,Result).
6590 dependency_reorder([Unit|Units],Acc,Result) :-
6591 Unit = unit(_GID,_Goal,Type,GIDs),
6592 ( Type == fixed ->
6593 NAcc = [Unit|Acc]
6594 ;
6595 dependency_insert(Acc,Unit,GIDs,NAcc)
6596 ),
6597 dependency_reorder(Units,NAcc,Result).
6599 dependency_insert([],Unit,_,[Unit]).
6600 dependency_insert([X|Xs],Unit,GIDs,L) :-
6601 X = unit(GID,_,_,_),
6602 ( memberchk(GID,GIDs) ->
6603 L = [Unit,X|Xs]
6604 ;
6605 L = [X | T],
6606 dependency_insert(Xs,Unit,GIDs,T)
6607 ).
6609 build_units(Retrievals,Guard,InitialDict,Units) :-
6610 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6611 build_guard_units(Guard,N,Dict,Tail).
6613 build_retrieval_units([],N,N,Dict,Dict,L,L).
6614 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6615 term_variables(U,Vs),
6616 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6617 L = [unit(N,U,fixed,GIDs)|L1],
6618 N1 is N + 1,
6619 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6621 initialize_unit_dictionary(Term,Dict) :-
6622 term_variables(Term,Vars),
6623 pair_all_with(Vars,0,Dict).
6625 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6626 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6627 ( lookup_eq(Dict,V,GID) ->
6628 ( (GID == This ; memberchk(GID,GIDs) ) ->
6629 GIDs1 = GIDs
6630 ;
6631 GIDs1 = [GID|GIDs]
6632 ),
6633 Dict1 = Dict
6634 ;
6635 Dict1 = [V - This|Dict],
6636 GIDs1 = GIDs
6637 ),
6638 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6640 build_guard_units(Guard,N,Dict,Units) :-
6641 ( Guard = [Goal] ->
6642 Units = [unit(N,Goal,fixed,[])]
6643 ; Guard = [Goal|Goals] ->
6644 term_variables(Goal,Vs),
6645 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6646 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6647 N1 is N + 1,
6648 build_guard_units(Goals,N1,NDict,RUnits)
6649 ).
6651 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6652 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6653 ( lookup_eq(Dict,V,GID) ->
6654 ( (GID == This ; memberchk(GID,GIDs) ) ->
6655 GIDs1 = GIDs
6656 ;
6657 GIDs1 = [GID|GIDs]
6658 ),
6659 Dict1 = [V - This|Dict]
6660 ;
6661 Dict1 = [V - This|Dict],
6662 GIDs1 = GIDs
6663 ),
6664 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6666 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6668 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6669 %% ____ _ ____ _ _
6670 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6671 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6672 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6673 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6674 %%
6675 %% _ _ _ ___ __
6676 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6677 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6678 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6679 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6680 %% |_|
6681 :- chr_constraint
6682 functional_dependency/4,
6683 get_functional_dependency/4.
6685 :- chr_option(mode,functional_dependency(+,+,?,?)).
6686 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6688 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6689 <=>
6690 RuleNb > 1, AO > O
6691 |
6692 functional_dependency(C,1,Pattern,Key).
6694 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6695 <=>
6696 RuleNb2 >= RuleNb1
6697 |
6698 QPattern = Pattern, QKey = Key.
6699 get_functional_dependency(_,_,_,_)
6700 <=>
6701 fail.
6703 functional_dependency_analysis(Rules) :-
6704 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6705 functional_dependency_analysis_main(Rules)
6706 ;
6707 true
6708 ).
6710 functional_dependency_analysis_main([]).
6711 functional_dependency_analysis_main([PRule|PRules]) :-
6712 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6713 functional_dependency(C,RuleNb,Pattern,Key)
6714 ;
6715 true
6716 ),
6717 functional_dependency_analysis_main(PRules).
6719 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6720 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6721 Rule = rule(H1,H2,Guard,_),
6722 ( H1 = [C1],
6723 H2 = [C2] ->
6724 true
6725 ; H1 = [C1,C2],
6726 H2 == [] ->
6727 true
6728 ),
6729 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6730 term_variables(C1,Vs),
6731 \+ (
6732 member(V1,Vs),
6733 lookup_eq(List,V1,V2),
6734 memberchk_eq(V2,Vs)
6735 ),
6736 select_pragma_unique_variables(Vs,List,Key1),
6737 copy_term_nat(C1-Key1,Pattern-Key),
6738 functor(C1,F,A).
6740 select_pragma_unique_variables([],_,[]).
6741 select_pragma_unique_variables([V|Vs],List,L) :-
6742 ( lookup_eq(List,V,_) ->
6743 L = T
6744 ;
6745 L = [V|T]
6746 ),
6747 select_pragma_unique_variables(Vs,List,T).
6749 % depends on functional dependency analysis
6750 % and shape of rule: C1 \ C2 <=> true.
6751 set_semantics_rules(Rules) :-
6752 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6753 set_semantics_rules_main(Rules)
6754 ;
6755 true
6756 ).
6758 set_semantics_rules_main([]).
6759 set_semantics_rules_main([R|Rs]) :-
6760 set_semantics_rule_main(R),
6761 set_semantics_rules_main(Rs).
6763 set_semantics_rule_main(PragmaRule) :-
6764 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6765 ( Rule = rule([C1],[C2],true,_),
6766 IDs = ids([ID1],[ID2]),
6767 \+ is_passive(RuleNb,ID1),
6768 functor(C1,F,A),
6769 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6770 copy_term_nat(Pattern-Key,C1-Key1),
6771 copy_term_nat(Pattern-Key,C2-Key2),
6772 Key1 == Key2 ->
6773 passive(RuleNb,ID2)
6774 ;
6775 true
6776 ).
6778 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6779 \+ any_passive_head(RuleNb),
6780 variable_replacement(C1-C2,C2-C1,List),
6781 copy_with_variable_replacement(G,OtherG,List),
6782 negate_b(G,NotG),
6783 once(entails_b(NotG,OtherG)).
6785 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6786 % where C1 and C2 are symmteric constraints
6787 symmetry_analysis(Rules) :-
6788 ( chr_pp_flag(check_unnecessary_active,off) ->
6789 true
6790 ;
6791 symmetry_analysis_main(Rules)
6792 ).
6794 symmetry_analysis_main([]).
6795 symmetry_analysis_main([R|Rs]) :-
6796 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6797 Rule = rule(H1,H2,_,_),
6798 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6799 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6800 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6801 ;
6802 true
6803 ),
6804 symmetry_analysis_main(Rs).
6806 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6807 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6808 ( \+ is_passive(RuleNb,ID),
6809 member2(PreHs,PreIDs,PreH-PreID),
6810 \+ is_passive(RuleNb,PreID),
6811 variable_replacement(PreH,H,List),
6812 copy_with_variable_replacement(Rule,Rule2,List),
6813 identical_guarded_rules(Rule,Rule2) ->
6814 passive(RuleNb,ID)
6815 ;
6816 true
6817 ),
6818 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6820 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6821 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6822 ( \+ is_passive(RuleNb,ID),
6823 member2(PreHs,PreIDs,PreH-PreID),
6824 \+ is_passive(RuleNb,PreID),
6825 variable_replacement(PreH,H,List),
6826 copy_with_variable_replacement(Rule,Rule2,List),
6827 identical_rules(Rule,Rule2) ->
6828 passive(RuleNb,ID)
6829 ;
6830 true
6831 ),
6832 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6834 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6836 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6837 %% ____ _ _ _ __ _ _ _
6838 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6839 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6840 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6841 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6842 %% |_|
6843 %% {{{
6845 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,Symbol,O,Id,L,T) :-
6846 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6847 head_info1(Head,Symbol,_Vars,Susp,HeadVars,HeadPairs),
6848 build_head(Symbol,Id,HeadVars,ClauseHead),
6849 get_constraint_mode(Symbol,Mode),
6850 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6853 guard_splitting(Rule,GuardList0),
6854 ( is_stored_in_guard(Symbol, RuleNb) ->
6855 GuardList = [Hole1|GuardList0]
6856 ;
6857 GuardList = GuardList0
6858 ),
6859 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6861 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6863 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6865 ( is_stored_in_guard(Symbol, RuleNb) ->
6866 gen_occ_allocation_in_guard(Symbol,O,Vars,Susp,Allocation),
6867 gen_uncond_attach_goal(Symbol,Susp,Vars,Attachment,_),
6868 GuardCopyList = [Hole1Copy|_],
6869 Hole1Copy = (Allocation, Attachment)
6870 ;
6871 true
6872 ),
6875 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6876 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6878 ( chr_pp_flag(debugable,on) ->
6879 Rule = rule(_,_,Guard,Body),
6880 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6881 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6882 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6883 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6884 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6885 ;
6886 Cut = ActualCut
6887 ),
6888 actual_cut(Symbol,O,ActualCut),
6889 Clause = ( ClauseHead :-
6890 FirstMatching,
6891 RescheduledTest,
6892 Cut,
6893 SuspsDetachments,
6894 SuspDetachment,
6895 BodyCopy
6896 ),
6897 add_location(Clause,RuleNb,LocatedClause),
6898 L = [LocatedClause | T].
6900 actual_cut(Symbol,Occurrence,ActualCut) :-
6901 ( unconditional_occurrence(Symbol,Occurrence),
6902 chr_pp_flag(late_allocation,on) ->
6903 ActualCut = true
6904 ;
6905 ActualCut = (!)
6906 ).
6907 % }}}
6909 add_location(Clause,RuleNb,NClause) :-
6910 ( chr_pp_flag(line_numbers,on) ->
6911 get_chr_source_file(File),
6912 get_line_number(RuleNb,LineNb),
6913 NClause = '$source_location'(File,LineNb):Clause
6914 ;
6915 NClause = Clause
6916 ).
6918 add_dummy_location(Clause,NClause) :-
6919 ( chr_pp_flag(line_numbers,on) ->
6920 get_chr_source_file(File),
6921 NClause = '$source_location'(File,1):Clause
6922 ;
6923 NClause = Clause
6924 ).
6925 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6926 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6927 %
6928 % Return goal matching newly introduced variables with variables in
6929 % previously looked-up heads.
6930 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6931 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6932 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6934 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6935 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6936 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6937 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6938 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6939 list2conj(GoalList,Goal).
6941 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6942 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6943 ( Mode == (+) ->
6944 term_variables(Arg,GroundVars0,GroundVars),
6945 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6946 ;
6947 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6948 ).
6949 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6950 ( var(Arg) ->
6951 ( lookup_eq(VarDict,Arg,OtherVar) ->
6952 ( Mode = (+) ->
6953 ( memberchk_eq(Arg,GroundVars) ->
6954 GoalList = [Var = OtherVar | RestGoalList],
6955 GroundVars1 = GroundVars
6956 ;
6957 GoalList = [Var == OtherVar | RestGoalList],
6958 GroundVars1 = [Arg|GroundVars]
6959 )
6960 ;
6961 GoalList = [Var == OtherVar | RestGoalList],
6962 GroundVars1 = GroundVars
6963 ),
6964 VarDict1 = VarDict
6965 ;
6966 VarDict1 = [Arg-Var | VarDict],
6967 GoalList = RestGoalList,
6968 ( Mode = (+) ->
6969 GroundVars1 = [Arg|GroundVars]
6970 ;
6971 GroundVars1 = GroundVars
6972 )
6973 ),
6974 Pairs = Rest,
6975 RestModes = Modes
6976 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6977 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6978 GoalList = [Goal|RestGoalList],
6979 VarDict = VarDict1,
6980 GroundVars1 = GroundVars,
6981 Pairs = Rest,
6982 RestModes = Modes
6983 ; atomic(Arg) ->
6984 ( Mode = (+) ->
6985 GoalList = [ Var = Arg | RestGoalList]
6986 ;
6987 GoalList = [ Var == Arg | RestGoalList]
6988 ),
6989 VarDict = VarDict1,
6990 GroundVars1 = GroundVars,
6991 Pairs = Rest,
6992 RestModes = Modes
6993 ; Mode == (+), is_ground(GroundVars,Arg) ->
6994 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6995 GoalList = [ Var = ArgCopy | RestGoalList],
6996 VarDict = VarDict1,
6997 GroundVars1 = GroundVars,
6998 Pairs = Rest,
6999 RestModes = Modes
7000 ; Mode == (?), is_ground(GroundVars,Arg) ->
7001 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
7002 GoalList = [ Var == ArgCopy | RestGoalList],
7003 VarDict = VarDict1,
7004 GroundVars1 = GroundVars,
7005 Pairs = Rest,
7006 RestModes = Modes
7007 ; Arg =.. [_|Args],
7008 functor(Arg,Fct,N),
7009 functor(Term,Fct,N),
7010 Term =.. [_|Vars],
7011 ( Mode = (+) ->
7012 GoalList = [ Var = Term | RestGoalList ]
7013 ;
7014 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
7015 ),
7016 pairup(Args,Vars,NewPairs),
7017 append(NewPairs,Rest,Pairs),
7018 replicate(N,Mode,NewModes),
7019 append(NewModes,Modes,RestModes),
7020 VarDict1 = VarDict,
7021 GroundVars1 = GroundVars
7022 ),
7023 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
7025 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7026 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
7027 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7028 add_heads_types([],VarTypes,VarTypes).
7029 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
7030 add_head_types(Head,VarTypes,VarTypes1),
7031 add_heads_types(Heads,VarTypes1,NVarTypes).
7033 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7034 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
7035 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7036 add_head_types(Head,VarTypes,NVarTypes) :-
7037 functor(Head,F,A),
7038 get_constraint_type_det(F/A,ArgTypes),
7039 Head =.. [_|Args],
7040 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
7042 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7043 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
7044 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7045 add_args_types([],[],VarTypes,VarTypes).
7046 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
7047 add_arg_types(Arg,Type,VarTypes,VarTypes1),
7048 add_args_types(Args,Types,VarTypes1,NVarTypes).
7050 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7051 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
7052 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7053 % OPTIMIZATION: don't add if `any'
7054 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
7055 ( Type == any ->
7056 NVarTypes = VarTypes
7057 ; var(Term) ->
7058 ( lookup_eq(VarTypes,Term,_) ->
7059 NVarTypes = VarTypes
7060 ;
7061 NVarTypes = [Term-Type|VarTypes]
7062 )
7063 ; % nonvar
7064 NVarTypes = VarTypes % approximate with any
7065 ).
7069 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7070 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
7071 %
7072 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7073 add_heads_ground_variables([],GroundVars,GroundVars).
7074 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
7075 add_head_ground_variables(Head,GroundVars,GroundVars1),
7076 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
7078 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7079 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
7080 %
7081 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7082 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
7083 functor(Head,F,A),
7084 get_constraint_mode(F/A,ArgModes),
7085 Head =.. [_|Args],
7086 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
7089 add_arg_ground_variables([],[],GroundVars,GroundVars).
7090 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
7091 ( Mode == (+) ->
7092 term_variables(Arg,Vars),
7093 add_var_ground_variables(Vars,GroundVars,GroundVars1)
7094 ;
7095 GroundVars = GroundVars1
7096 ),
7097 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
7099 add_var_ground_variables([],GroundVars,GroundVars).
7100 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
7101 ( memberchk_eq(Var,GroundVars) ->
7102 GroundVars1 = GroundVars
7103 ;
7104 GroundVars1 = [Var|GroundVars]
7105 ),
7106 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
7107 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7108 %% is_ground(+GroundVars,+Term) is semidet.
7109 %
7110 % Determine whether =Term= is always ground.
7111 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7112 is_ground(GroundVars,Term) :-
7113 ( ground(Term) ->
7114 true
7115 ; compound(Term) ->
7116 Term =.. [_|Args],
7117 maplist(is_ground(GroundVars),Args)
7118 ;
7119 memberchk_eq(Term,GroundVars)
7120 ).
7122 %% check_ground(+GroundVars,+Term,-Goal) is det.
7123 %
7124 % Return runtime check to see whether =Term= is ground.
7125 check_ground(GroundVars,Term,Goal) :-
7126 term_variables(Term,Variables),
7127 check_ground_variables(Variables,GroundVars,Goal).
7129 check_ground_variables([],_,true).
7130 check_ground_variables([Var|Vars],GroundVars,Goal) :-
7131 ( memberchk_eq(Var,GroundVars) ->
7132 check_ground_variables(Vars,GroundVars,Goal)
7133 ;
7134 Goal = (ground(Var), RGoal),
7135 check_ground_variables(Vars,GroundVars,RGoal)
7136 ).
7138 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
7139 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
7141 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
7142 ( Heads = [_|_] ->
7143 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
7144 ;
7145 GoalList = [],
7146 Susps = [],
7147 VarDict = NVarDict,
7148 GroundVars = NGroundVars
7149 ).
7151 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
7152 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
7153 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
7154 functor(H,F,A),
7155 head_info(H,A,Vars,_,_,Pairs),
7156 get_store_type(F/A,StoreType),
7157 ( StoreType == default ->
7158 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
7159 delay_phase_end(validate_store_type_assumptions,
7160 ( static_suspension_term(F/A,Suspension),
7161 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
7162 get_static_suspension_field(F/A,Suspension,state,active,GetState)
7163 )
7164 ),
7165 % create_get_mutable_ref(active,State,GetMutable),
7166 get_constraint_mode(F/A,Mode),
7167 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7168 NPairs = Pairs,
7169 sbag_member_call(Susp,VarSusps,Sbag),
7170 ExistentialLookup = (
7171 ViaGoal,
7172 Sbag,
7173 Susp = Suspension, % not inlined
7174 GetState
7175 ),
7176 inline_matching_goal(MatchingGoal,MatchingGoal2)
7177 ;
7178 delay_phase_end(validate_store_type_assumptions,
7179 ( static_suspension_term(F/A,Suspension),
7180 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7181 )
7182 ),
7183 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7184 get_constraint_mode(F/A,Mode),
7185 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7186 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7187 filter_append(NPairs,VarDict1,DA_), % order important here
7188 translate(GroundVars1,DA_,GroundVarsA),
7189 translate(GroundVars1,VarDict1,GroundVarsB),
7190 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB)
7191 ),
7192 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7193 Goal =
7194 (
7195 ExistentialLookup,
7196 DiffSuspGoals,
7197 MatchingGoal2
7198 ),
7199 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7201 inline_matching_goal(G1,G2) :-
7202 inline_matching_goal(G1,G2,[],[]).
7204 inline_matching_goal(A==B,true,GVA,GVB) :-
7205 memberchk_eq(A,GVA),
7206 memberchk_eq(B,GVB),
7207 A=B, !.
7208 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7209 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7210 inline_matching_goal(A,A2,GVA,GVB),
7211 inline_matching_goal(B,B2,GVA,GVB).
7212 inline_matching_goal(X,X,_,_).
7215 filter_mode([],_,_,[]).
7216 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7217 ( Var == V ->
7218 Modes = [M|MT],
7219 filter_mode(Rest,R,Ms,MT)
7220 ;
7221 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7222 ).
7224 filter_append([],VarDict,VarDict).
7225 filter_append([X|Xs],VarDict,NVarDict) :-
7226 ( X = silent(_) ->
7227 filter_append(Xs,VarDict,NVarDict)
7228 ;
7229 NVarDict = [X|NVarDict0],
7230 filter_append(Xs,VarDict,NVarDict0)
7231 ).
7233 check_unique_keys([],_).
7234 check_unique_keys([V|Vs],Dict) :-
7235 lookup_eq(Dict,V,_),
7236 check_unique_keys(Vs,Dict).
7238 % Generates tests to ensure the found constraint differs from previously found constraints
7239 % TODO: detect more cases where constraints need be different
7240 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7241 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7242 list2conj(DiffSuspGoalList,DiffSuspGoals).
7244 different_from_other_susps_(_,[],_,_,[]) :- !.
7245 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7246 ( functor(Head,F,A), functor(PreHead,F,A),
7247 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7248 \+ \+ PreHeadCopy = HeadCopy ->
7250 List = [Susp \== PreSusp | Tail]
7251 ;
7252 List = Tail
7253 ),
7254 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7256 % passive_head_via(in,in,in,in,out,out,out) :-
7257 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7258 functor(Head,F,A),
7259 get_constraint_index(F/A,Pos),
7260 /* which static variables may contain runtime variables */
7261 common_variables(Head,PrevHeads,CommonVars0),
7262 ground_vars([Head],GroundVars),
7263 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7264 /********************************************************/
7265 global_list_store_name(F/A,Name),
7266 GlobalGoal = nb_getval(Name,AllSusps),
7267 get_constraint_mode(F/A,ArgModes),
7268 ( Vars == [] ->
7269 Goal = GlobalGoal
7270 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7271 translate([CommonVar],VarDict,[Var]),
7272 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7273 Goal = AttrGoal
7274 ;
7275 translate(CommonVars,VarDict,Vars),
7276 add_heads_types(PrevHeads,[],TypeDict),
7277 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7278 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7279 Goal =
7280 ( ViaGoal ->
7281 AttrGoal
7282 ;
7283 GlobalGoal
7284 )
7285 ).
7287 common_variables(T,Ts,Vs) :-
7288 term_variables(T,V1),
7289 term_variables(Ts,V2),
7290 intersect_eq(V1,V2,Vs).
7292 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7293 via_goal(Vars,TypeDict,ViaGoal,Var),
7294 get_target_module(Mod),
7295 AttrGoal =
7296 ( get_attr(Var,Mod,TSusps),
7297 TSuspsEqSusps % TSusps = Susps
7298 ),
7299 get_max_constraint_index(N),
7300 ( N == 1 ->
7301 TSuspsEqSusps = true, % TSusps = Susps
7302 AllSusps = TSusps
7303 ;
7304 get_constraint_index(FA,Pos),
7305 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7306 ).
7307 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7308 ( Vars = [] ->
7309 ViaGoal = fail
7310 ; Vars = [A] ->
7311 lookup_type(TypeDict,A,Type),
7312 ( atomic_type(Type) ->
7313 ViaGoal = var(A),
7314 A = Var
7315 ;
7316 ViaGoal = 'chr newvia_1'(A,Var)
7317 )
7318 ; Vars = [A,B] ->
7319 ViaGoal = 'chr newvia_2'(A,B,Var)
7320 ;
7321 ViaGoal = 'chr newvia'(Vars,Var)
7322 ).
7323 lookup_type(TypeDict,Var,Type) :-
7324 ( lookup_eq(TypeDict,Var,Type) ->
7325 true
7326 ;
7327 Type = any % default type
7328 ).
7329 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7330 get_target_module(Mod),
7331 AttrGoal =
7332 ( get_attr(Var,Mod,TSusps),
7333 TSuspsEqSusps % TSusps = Susps
7334 ),
7335 get_max_constraint_index(N),
7336 ( N == 1 ->
7337 TSuspsEqSusps = true, % TSusps = Susps
7338 AllSusps = TSusps
7339 ;
7340 get_constraint_index(FA,Pos),
7341 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7342 ).
7344 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7345 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7346 list2conj(GuardCopyList,GuardCopy).
7348 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7349 Rule = rule(_,H,Guard,Body),
7350 conj2list(Guard,GuardList),
7351 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7352 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7354 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7355 term_variables(RestGuardList,GuardVars),
7356 term_variables(RestGuardListCopyCore,GuardCopyVars),
7357 % variables that are declared to be ground don't need to be locked
7358 ground_vars(H,GroundVars),
7359 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7360 ( chr_pp_flag(guard_locks,off) ->
7361 Locks = [],
7362 Unlocks = []
7363 ;
7364 bagof(Lock - Unlock,
7365 X ^ Y ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7366 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7367 memberchk_eq(Y,GuardCopyVars), % redundant check? or multiple entries for X possible?
7368 chr_lock(Y,Lock),
7369 chr_unlock(Y,Unlock)
7370 ),
7371 LocksUnlocks) ->
7372 once(pairup(Locks,Unlocks,LocksUnlocks))
7373 ;
7374 Locks = [],
7375 Unlocks = []
7376 ),
7377 list2conj(Locks,LockPhase),
7378 list2conj(Unlocks,UnlockPhase),
7379 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7380 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7381 my_term_copy(Body,VarDict2,BodyCopy).
7384 split_off_simple_guard([],_,[],[]).
7385 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7386 ( simple_guard(G,VarDict) ->
7387 S = [G|Ss],
7388 split_off_simple_guard(Gs,VarDict,Ss,C)
7389 ;
7390 S = [],
7391 C = [G|Gs]
7392 ).
7394 % simple guard: cheap and benign (does not bind variables)
7395 simple_guard(G,VarDict) :-
7396 binds_b(G,Vars),
7397 \+ (( member(V,Vars),
7398 lookup_eq(VarDict,V,_)
7399 )).
7401 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7402 functor(Head,F,A),
7403 C = F/A,
7404 ( is_stored(C) ->
7405 (
7406 (
7407 Id == [0], chr_pp_flag(store_in_guards, off)
7408 ;
7409 ( get_allocation_occurrence(C,AO),
7410 get_max_occurrence(C,MO),
7411 MO < AO )
7412 ),
7413 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7414 SuspDetachment = true
7415 ;
7416 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7417 ( chr_pp_flag(late_allocation,on) ->
7418 SuspDetachment =
7419 ( var(Susp) ->
7420 true
7421 ;
7422 UnCondSuspDetachment
7423 )
7424 ;
7425 SuspDetachment = UnCondSuspDetachment
7426 )
7427 )
7428 ;
7429 SuspDetachment = true
7430 ).
7432 partner_constraint_detachments([],[],_,true).
7433 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7434 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7435 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7437 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7438 functor(Head,F,A),
7439 C = F/A,
7440 ( is_stored(C) ->
7441 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7442 ( chr_pp_flag(debugable,on) ->
7443 DebugEvent = 'chr debug_event'(remove(Susp))
7444 ;
7445 DebugEvent = true
7446 ),
7447 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7448 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7449 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7450 detach_constraint_atom(C,Vars,Susp,Detach)
7451 ;
7452 Detach = true
7453 )
7454 ;
7455 SuspDetachment = true
7456 ).
7458 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7460 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7461 %% ____ _ _ _ _
7462 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7463 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7464 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7465 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7466 %% |_| |___/
7467 %% {{{
7469 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7470 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7471 Rule = rule(_Heads,Heads2,Guard,Body),
7473 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7474 get_constraint_mode(F/A,Mode),
7475 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7477 build_head(F,A,Id,HeadVars,ClauseHead),
7479 append(RestHeads,Heads2,Heads),
7480 append(OtherIDs,Heads2IDs,IDs),
7481 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7483 guard_splitting(Rule,GuardList0),
7484 ( is_stored_in_guard(F/A, RuleNb) ->
7485 GuardList = [Hole1|GuardList0]
7486 ;
7487 GuardList = GuardList0
7488 ),
7489 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7491 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7492 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7494 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7496 ( is_stored_in_guard(F/A, RuleNb) ->
7497 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7498 GuardCopyList = [Hole1Copy|_],
7499 Hole1Copy = Attachment
7500 ;
7501 true
7502 ),
7504 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7505 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7506 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7508 ( chr_pp_flag(debugable,on) ->
7509 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7510 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7511 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7512 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7513 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7514 instrument_goal((!),DebugTry,DebugApply,Cut)
7515 ;
7516 Cut = (!)
7517 ),
7519 Clause = ( ClauseHead :-
7520 FirstMatching,
7521 RescheduledTest,
7522 Cut,
7523 SuspsDetachments,
7524 SuspDetachment,
7525 BodyCopy
7526 ),
7527 add_location(Clause,RuleNb,LocatedClause),
7528 L = [LocatedClause | T].
7530 % }}}
7532 split_by_ids([],[],_,[],[]).
7533 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7534 ( memberchk_eq(I,I1s) ->
7535 S1s = [S | R1s],
7536 S2s = R2s
7537 ;
7538 S1s = R1s,
7539 S2s = [S | R2s]
7540 ),
7541 split_by_ids(Is,Ss,I1s,R1s,R2s).
7543 split_by_ids([],[],_,[],[],[],[]).
7544 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7545 ( memberchk_eq(I,I1s) ->
7546 S1s = [S | R1s],
7547 SI1s = [I|RSI1s],
7548 S2s = R2s,
7549 SI2s = RSI2s
7550 ;
7551 S1s = R1s,
7552 SI1s = RSI1s,
7553 S2s = [S | R2s],
7554 SI2s = [I|RSI2s]
7555 ),
7556 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7557 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7560 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7561 %% ____ _ _ _ ____
7562 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7563 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7564 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7565 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7566 %% |_| |___/
7568 %% Genereate prelude + worker predicate
7569 %% prelude calls worker
7570 %% worker iterates over one type of removed constraints
7571 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7572 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7573 Rule = rule(Heads1,_,Guard,Body),
7574 append(Heads1,RestHeads2,Heads),
7575 append(IDs1,RestIDs,IDs),
7576 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7577 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7578 extend_id(Id,Id1),
7579 ( memberchk_eq(NID,IDs2) ->
7580 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7581 ;
7582 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7583 ),
7584 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7585 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7587 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7588 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7589 Heads = [Head|RHeads],
7590 inc_id(Id,Id1),
7591 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7592 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7593 ( memberchk_eq(ID,IDs2) ->
7594 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7595 ;
7596 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7597 ).
7599 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7600 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7601 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7602 build_head(F,A,Id1,VarsSusp,ClauseHead),
7603 get_constraint_mode(F/A,Mode),
7604 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7606 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7608 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7610 extend_id(Id1,DelegateId),
7611 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7612 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7613 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7615 PreludeClause =
7616 ( ClauseHead :-
7617 FirstMatching,
7618 ModConstraintsGoal,
7619 !,
7620 ConstraintAllocationGoal,
7621 Delegate
7622 ),
7623 add_dummy_location(PreludeClause,LocatedPreludeClause),
7624 L = [LocatedPreludeClause|T].
7626 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7627 Term =.. [_|Args],
7628 delegate_variables(Term,Terms,VarDict,Args,Vars).
7630 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7631 term_variables(PrevTerms,PrevVars),
7632 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7634 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7635 term_variables(Term,V1),
7636 term_variables(Terms,V2),
7637 intersect_eq(V1,V2,V3),
7638 list_difference_eq(V3,PrevVars,V4),
7639 translate(V4,VarDict,Vars).
7642 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7643 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7644 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7645 Rule = rule(_,_,Guard,Body),
7646 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7648 gen_var(OtherSusp),
7649 gen_var(OtherSusps),
7651 functor(CurrentHead,OtherF,OtherA),
7652 gen_vars(OtherA,OtherVars),
7653 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7654 get_constraint_mode(OtherF/OtherA,Mode),
7655 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7657 delay_phase_end(validate_store_type_assumptions,
7658 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7659 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7660 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7661 )
7662 ),
7663 % create_get_mutable_ref(active,State,GetMutable),
7664 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7665 CurrentSuspTest = (
7666 OtherSusp = OtherSuspension,
7667 GetState,
7668 DiffSuspGoals,
7669 FirstMatching
7670 ),
7672 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7673 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7675 guard_splitting(Rule,GuardList0),
7676 ( is_stored_in_guard(F/A, RuleNb) ->
7677 GuardList = [Hole1|GuardList0]
7678 ;
7679 GuardList = GuardList0
7680 ),
7681 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7683 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7684 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7685 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7687 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7689 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7690 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7691 RecursiveVars2 = [[]|PreVarsAndSusps],
7692 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7694 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7695 ( is_stored_in_guard(F/A, RuleNb) ->
7696 GuardCopyList = [GuardAttachment|_] % once( ) ??
7697 ;
7698 true
7699 ),
7701 ( is_observed(F/A,O) ->
7702 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7703 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7704 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7705 ;
7706 Attachment = true,
7707 ConditionalRecursiveCall = RecursiveCall,
7708 ConditionalRecursiveCall2 = RecursiveCall2
7709 ),
7711 ( chr_pp_flag(debugable,on) ->
7712 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7713 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7714 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7715 ;
7716 DebugTry = true,
7717 DebugApply = true
7718 ),
7720 ( is_stored_in_guard(F/A, RuleNb) ->
7721 GuardAttachment = Attachment,
7722 BodyAttachment = true
7723 ;
7724 GuardAttachment = true,
7725 BodyAttachment = Attachment % will be true if not observed at all
7726 ),
7728 ( member(unique(ID1,UniqueKeys), Pragmas),
7729 check_unique_keys(UniqueKeys,VarDict) ->
7730 Clause =
7731 ( ClauseHead :-
7732 ( CurrentSuspTest ->
7733 ( RescheduledTest,
7734 DebugTry ->
7735 DebugApply,
7736 Susps1Detachments,
7737 BodyAttachment,
7738 BodyCopy,
7739 ConditionalRecursiveCall2
7740 ;
7741 RecursiveCall2
7742 )
7743 ;
7744 RecursiveCall
7745 )
7746 )
7747 ;
7748 Clause =
7749 ( ClauseHead :-
7750 ( CurrentSuspTest,
7751 RescheduledTest,
7752 DebugTry ->
7753 DebugApply,
7754 Susps1Detachments,
7755 BodyAttachment,
7756 BodyCopy,
7757 ConditionalRecursiveCall
7758 ;
7759 RecursiveCall
7760 )
7761 )
7762 ),
7763 add_location(Clause,RuleNb,LocatedClause),
7764 L = [LocatedClause | T].
7766 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7767 ( may_trigger(FA) ->
7768 does_use_field(FA,generation),
7769 delay_phase_end(validate_store_type_assumptions,
7770 ( static_suspension_term(FA,Suspension),
7771 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7772 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7773 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7774 )
7775 )
7776 ;
7777 delay_phase_end(validate_store_type_assumptions,
7778 ( static_suspension_term(FA,Suspension),
7779 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7780 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7781 )
7782 ),
7783 GetGeneration = true
7784 ),
7785 ConditionalCall =
7786 ( Susp = Suspension,
7787 GetState,
7788 GetGeneration ->
7789 UpdateState,
7790 Call
7791 ;
7792 true
7793 ).
7795 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7798 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7799 %% ____ _ _
7800 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7801 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7802 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7803 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7804 %% |_| |___/
7806 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7807 ( RestHeads == [] ->
7808 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7809 ;
7810 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7811 ).
7812 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7813 %% Single headed propagation
7814 %% everything in a single clause
7815 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7816 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7817 build_head(F,A,Id,VarsSusp,ClauseHead),
7819 inc_id(Id,NextId),
7820 build_head(F,A,NextId,VarsSusp,NextHead),
7822 get_constraint_mode(F/A,Mode),
7823 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7824 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7826 % - recursive call -
7827 RecursiveCall = NextHead,
7829 actual_cut(F/A,O,ActualCut),
7831 Rule = rule(_,_,Guard,Body),
7832 ( chr_pp_flag(debugable,on) ->
7833 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7834 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7835 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7836 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7837 ;
7838 Cut = ActualCut
7839 ),
7840 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7841 use_auxiliary_predicate(novel_production),
7842 use_auxiliary_predicate(extend_history),
7843 does_use_history(F/A,O),
7844 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7846 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7847 ( HistoryIDs == [] ->
7848 empty_named_history_novel_production(HistoryName,NovelProduction),
7849 empty_named_history_extend_history(HistoryName,ExtendHistory)
7850 ;
7851 Tuple = HistoryName
7852 )
7853 ;
7854 Tuple = RuleNb
7855 ),
7857 ( var(NovelProduction) ->
7858 NovelProduction = '$novel_production'(Susp,Tuple),
7859 ExtendHistory = '$extend_history'(Susp,Tuple)
7860 ;
7861 true
7862 ),
7864 ( is_observed(F/A,O) ->
7865 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7866 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7867 ;
7868 Attachment = true,
7869 ConditionalRecursiveCall = RecursiveCall
7870 )
7871 ;
7872 Allocation = true,
7873 NovelProduction = true,
7874 ExtendHistory = true,
7876 ( is_observed(F/A,O) ->
7877 get_allocation_occurrence(F/A,AllocO),
7878 ( O == AllocO ->
7879 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7880 Generation = 0
7881 ; % more room for improvement?
7882 Attachment = (Attachment1, Attachment2),
7883 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7884 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7885 ),
7886 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7887 ;
7888 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7889 ConditionalRecursiveCall = RecursiveCall
7890 )
7891 ),
7893 ( is_stored_in_guard(F/A, RuleNb) ->
7894 GuardAttachment = Attachment,
7895 BodyAttachment = true
7896 ;
7897 GuardAttachment = true,
7898 BodyAttachment = Attachment % will be true if not observed at all
7899 ),
7901 Clause = (
7902 ClauseHead :-
7903 HeadMatching,
7904 Allocation,
7905 NovelProduction,
7906 GuardAttachment,
7907 GuardCopy,
7908 Cut,
7909 ExtendHistory,
7910 BodyAttachment,
7911 BodyCopy,
7912 ConditionalRecursiveCall
7913 ),
7914 add_location(Clause,RuleNb,LocatedClause),
7915 ProgramList = [LocatedClause | ProgramTail].
7917 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7918 %% multi headed propagation
7919 %% prelude + predicates to accumulate the necessary combinations of suspended
7920 %% constraints + predicate to execute the body
7921 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7922 RestHeads = [First|Rest],
7923 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7924 extend_id(Id,ExtendedId),
7925 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7927 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7928 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7929 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7930 build_head(F,A,Id,VarsSusp,PreludeHead),
7931 get_constraint_mode(F/A,Mode),
7932 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7933 Rule = rule(_,_,Guard,Body),
7934 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7936 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7938 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7940 extend_id(Id,NestedId),
7941 append([Susps|VarsSusp],ExtraVars,NestedVars),
7942 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7943 NestedCall = NestedHead,
7945 Prelude = (
7946 PreludeHead :-
7947 FirstMatching,
7948 FirstSuspGoal,
7949 !,
7950 CondAllocation,
7951 NestedCall
7952 ),
7953 add_dummy_location(Prelude,LocatedPrelude),
7954 L = [LocatedPrelude|T].
7956 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7957 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7958 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7959 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7961 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7962 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7963 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7964 inc_id(Id,IncId),
7965 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7967 %check_fd_lookup_condition(_,_,_,_) :- fail.
7968 check_fd_lookup_condition(F,A,_,_) :-
7969 get_store_type(F/A,global_singleton), !.
7970 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7971 \+ may_trigger(F/A),
7972 get_functional_dependency(F/A,1,P,K),
7973 copy_term(P-K,CurrentHead-Key),
7974 term_variables(PreHeads,PreVars),
7975 intersect_eq(Key,PreVars,Key),!.
7977 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7978 Rule = rule(_,H2,Guard,Body),
7979 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7980 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7981 init(AllSusps,RestSusps),
7982 last(AllSusps,Susp),
7983 gen_var(OtherSusp),
7984 gen_var(OtherSusps),
7985 functor(CurrentHead,OtherF,OtherA),
7986 gen_vars(OtherA,OtherVars),
7987 delay_phase_end(validate_store_type_assumptions,
7988 ( static_suspension_term(OtherF/OtherA,Suspension),
7989 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7990 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7991 )
7992 ),
7993 % create_get_mutable_ref(active,State,GetMutable),
7994 CurrentSuspTest = (
7995 OtherSusp = Suspension,
7996 GetState
7997 ),
7998 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7999 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8000 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8001 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8002 RecursiveVars = PreVarsAndSusps1
8003 ;
8004 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8005 PrevId0 = Id
8006 ),
8007 ( PrevId0 = [_] ->
8008 PrevId = PrevId0
8009 ;
8010 PrevId = [O|PrevId0]
8011 ),
8012 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8013 RecursiveCall = RecursiveHead,
8014 CurrentHead =.. [_|OtherArgs],
8015 pairup(OtherArgs,OtherVars,OtherPairs),
8016 get_constraint_mode(OtherF/OtherA,Mode),
8017 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
8019 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
8020 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
8021 get_occurrence(F/A,O,_,ID),
8023 ( is_observed(F/A,O) ->
8024 init(FirstVarsSusp,FirstVars),
8025 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
8026 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
8027 ;
8028 Attachment = true,
8029 ConditionalRecursiveCall = RecursiveCall
8030 ),
8031 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
8032 NovelProduction = true,
8033 ExtendHistory = true
8034 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
8035 NovelProduction = true,
8036 ExtendHistory = true
8037 ;
8038 get_occurrence(F/A,O,_,ID),
8039 use_auxiliary_predicate(novel_production),
8040 use_auxiliary_predicate(extend_history),
8041 does_use_history(F/A,O),
8042 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
8043 ( HistoryIDs == [] ->
8044 empty_named_history_novel_production(HistoryName,NovelProduction),
8045 empty_named_history_extend_history(HistoryName,ExtendHistory)
8046 ;
8047 reverse([OtherSusp|RestSusps],NamedSusps),
8048 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
8049 HistorySusps = [HistorySusp|_],
8051 ( length(HistoryIDs, 1) ->
8052 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
8053 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
8054 ;
8055 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
8056 Tuple =.. [t,HistoryName|HistorySusps]
8057 )
8058 )
8059 ;
8060 HistorySusp = Susp,
8061 maplist(extract_symbol,H2,ConstraintSymbols),
8062 sort([ID|RestIDs],HistoryIDs),
8063 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
8064 Tuple =.. [t,RuleNb|HistorySusps]
8065 ),
8067 ( var(NovelProduction) ->
8068 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
8069 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
8070 NovelProduction = ( TupleVar = Tuple, NovelProductions )
8071 ;
8072 true
8073 )
8074 ),
8077 ( chr_pp_flag(debugable,on) ->
8078 Rule = rule(_,_,Guard,Body),
8079 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
8080 get_occurrence(F/A,O,_,ID),
8081 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
8082 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
8083 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
8084 ;
8085 DebugTry = true,
8086 DebugApply = true
8087 ),
8089 ( is_stored_in_guard(F/A, RuleNb) ->
8090 GuardAttachment = Attachment,
8091 BodyAttachment = true
8092 ;
8093 GuardAttachment = true,
8094 BodyAttachment = Attachment % will be true if not observed at all
8095 ),
8097 Clause = (
8098 ClauseHead :-
8099 ( CurrentSuspTest,
8100 DiffSuspGoals,
8101 Matching,
8102 NovelProduction,
8103 GuardAttachment,
8104 GuardCopy,
8105 DebugTry ->
8106 DebugApply,
8107 ExtendHistory,
8108 BodyAttachment,
8109 BodyCopy,
8110 ConditionalRecursiveCall
8111 ; RecursiveCall
8112 )
8113 ),
8114 add_location(Clause,RuleNb,LocatedClause),
8115 L = [LocatedClause|T].
8117 extract_symbol(Head,F/A) :-
8118 functor(Head,F,A).
8120 novel_production_calls([],[],[],_,_,true).
8121 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
8122 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
8123 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
8124 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
8126 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
8127 reverse(ReversedRestSusps,RestSusps),
8128 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
8130 named_history_susps([],_,_,[]).
8131 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
8132 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
8133 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
8137 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
8138 !,
8139 functor(Head,F,A),
8140 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
8141 get_constraint_mode(F/A,Mode),
8142 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
8143 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
8144 append(VarsSusp,ExtraVars,HeadVars).
8145 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
8146 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
8147 functor(Head,F,A),
8148 gen_var(Susps),
8149 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8150 get_constraint_mode(F/A,Mode),
8151 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8152 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8153 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
8155 % returns
8156 % VarDict for the copies of variables in the original heads
8157 % VarsSuspsList list of lists of arguments for the successive heads
8158 % FirstVarsSusp top level arguments
8159 % SuspList list of all suspensions
8160 % Iterators list of all iterators
8161 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
8162 !,
8163 functor(Head,F,A),
8164 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
8165 get_constraint_mode(F/A,Mode),
8166 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
8167 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
8168 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
8169 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
8170 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
8171 functor(Head,F,A),
8172 gen_var(Susps),
8173 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8174 get_constraint_mode(F/A,Mode),
8175 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8176 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8177 append(HeadVars,[Susp,Susps],Vars).
8179 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8180 !,
8181 functor(Head,F,A),
8182 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8183 get_constraint_mode(F/A,Mode),
8184 head_arg_matches(Pairs,Mode,[],_,VarDict),
8185 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8186 append(VarsSusp,ExtraVars,HeadVars).
8187 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8188 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8189 functor(Head,F,A),
8190 gen_var(Susps),
8191 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8192 get_constraint_mode(F/A,Mode),
8193 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8194 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8195 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8197 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8199 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8200 %% ____ _ _ _ _
8201 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8202 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8203 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8204 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8205 %%
8206 %% ____ _ _ _
8207 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8208 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8209 %% | _ < __/ |_| | | | __/\ V / (_| | |
8210 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8211 %%
8212 %% ____ _ _
8213 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8214 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8215 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8216 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8217 %% |___/
8219 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8220 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8221 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8222 ;
8223 NRestHeads = RestHeads,
8224 NRestIDs = RestIDs
8225 ).
8227 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8228 term_variables(Head,Vars),
8229 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8230 copy_term_nat(InitialData,InitialDataCopy),
8231 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8232 InitialDataCopy = InitialData,
8233 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8234 reverse(RNRestHeads,NRestHeads),
8235 reverse(RNRestIDs,NRestIDs).
8237 final_data(Entry) :-
8238 Entry = entry(_,_,_,_,[],_).
8240 expand_data(Entry,NEntry,Cost) :-
8241 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8242 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8243 term_variables([Head1|Vars],Vars1),
8244 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8245 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8247 % Assigns score to head based on known variables and heads to lookup
8248 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8249 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8250 functor(Head,F,A),
8251 get_store_type(F/A,StoreType),
8252 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8253 % }}}
8255 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8256 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8257 term_variables(Head,HeadVars0),
8258 term_variables(RestHeads,RestVars),
8259 ground_vars([Head],GroundVars),
8260 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8261 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8262 NScore is min(CScore,Score).
8263 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8264 ( CScore =< 100 ->
8265 Score = CScore
8266 ;
8267 order_score_indexes(Indexes,Head,KnownVars,Score)
8268 ).
8269 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8270 ( CScore =< 100 ->
8271 Score = CScore
8272 ;
8273 order_score_indexes(Indexes,Head,KnownVars,Score)
8274 ).
8275 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8276 term_variables(Head,HeadVars),
8277 term_variables(RestHeads,RestVars),
8278 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8279 Score is Score_ * 200,
8280 NScore is min(CScore,Score).
8281 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8282 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8283 Score = 1. % guaranteed O(1)
8284 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8285 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8286 multi_order_score([],_,_,_,_,_,Score,Score).
8287 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8288 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8289 ; Score1 = Score0
8290 ),
8291 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8293 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8294 arg(Index,Head,Arg),
8295 memberchk_eq(Arg,KnownVars),
8296 Score is min(CScore,10).
8297 order_score(type_indexed_identifier_store(Index,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8298 arg(Index,Head,Arg),
8299 memberchk_eq(Arg,KnownVars),
8300 Score is min(CScore,10).
8301 % }}}
8304 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8305 order_score_indexes(Indexes,Head,Vars,Score) :-
8306 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8307 numbervars(VarsCopy,0,_),
8308 order_score_indexes(Indexes,HeadCopy,Score).
8310 order_score_indexes([I|Is],Head,Score) :-
8311 args(I,Head,Args),
8312 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8313 Score = 100
8314 ;
8315 order_score_indexes(Is,Head,Score)
8316 ).
8317 % }}}
8319 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8321 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8322 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8323 ( K-R-O == 0-0-0 ->
8324 Score = 0
8325 ; K > 0 ->
8326 Score is max(10 - K,0)
8327 ; R > 0 ->
8328 Score is max(10 - R,1) * 100
8329 ;
8330 Score is max(10-O,1) * 1000
8331 ).
8332 order_score_count_vars([],_,_,0-0-0).
8333 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8334 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8335 ( memberchk_eq(V,KnownVars) ->
8336 NK is K + 1,
8337 NR = R, NO = O
8338 ; memberchk_eq(V,RestVars) ->
8339 NR is R + 1,
8340 NK = K, NO = O
8341 ;
8342 NO is O + 1,
8343 NK = K, NR = R
8344 ).
8346 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8347 %% ___ _ _ _
8348 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8349 %% | || '_ \| | | '_ \| | '_ \ / _` |
8350 %% | || | | | | | | | | | | | | (_| |
8351 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8352 %% |___/
8354 %% SWI begin
8355 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8356 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8357 %% SWI end
8359 %% SICStus begin
8360 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8361 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8362 %% SICStus end
8364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8366 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8367 %% _ _ _ _ _ _ _
8368 %% | | | | |_(_) (_) |_ _ _
8369 %% | | | | __| | | | __| | | |
8370 %% | |_| | |_| | | | |_| |_| |
8371 %% \___/ \__|_|_|_|\__|\__, |
8372 %% |___/
8374 % Create a fresh variable.
8375 gen_var(_).
8377 % Create =N= fresh variables.
8378 gen_vars(N,Xs) :-
8379 length(Xs,N).
8381 ast_head_info1(AstHead,Vars,Susp,VarsSusp,HeadPairs) :-
8382 AstHead = chr_constraint(_/A,Args,_),
8383 vars_susp(A,Vars,Susp,VarsSusp),
8384 pairup(Args,Vars,HeadPairs).
8386 head_info1(Head,_/A,Vars,Susp,VarsSusp,HeadPairs) :-
8387 vars_susp(A,Vars,Susp,VarsSusp),
8388 Head =.. [_|Args],
8389 pairup(Args,Vars,HeadPairs).
8391 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8392 vars_susp(A,Vars,Susp,VarsSusp),
8393 Head =.. [_|Args],
8394 pairup(Args,Vars,HeadPairs).
8396 inc_id([N|Ns],[O|Ns]) :-
8397 O is N + 1.
8398 dec_id([N|Ns],[M|Ns]) :-
8399 M is N - 1.
8401 extend_id(Id,[0|Id]).
8403 next_id([_,N|Ns],[O|Ns]) :-
8404 O is N + 1.
8406 % return clause Head
8407 % for F/A constraint symbol, predicate identifier Id and arguments Head
8408 build_head(F/A,Id,Args,Head) :-
8409 build_head(F,A,Id,Args,Head).
8410 build_head(F,A,Id,Args,Head) :-
8411 buildName(F,A,Id,Name),
8412 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8413 ( may_trigger(F/A) ;
8414 get_allocation_occurrence(F/A,AO),
8415 get_max_occurrence(F/A,MO),
8416 MO >= AO ) ) ->
8417 Head =.. [Name|Args]
8418 ;
8419 init(Args,ArgsWOSusp), % XXX not entirely correct!
8420 Head =.. [Name|ArgsWOSusp]
8421 ).
8423 % return predicate name Result
8424 % for Fct/Aty constraint symbol and predicate identifier List
8425 buildName(Fct,Aty,List,Result) :-
8426 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8427 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8428 MO >= AO ) ; List \= [0])) ) ) ->
8429 atom_concat(Fct, '___' ,FctSlash),
8430 atomic_concat(FctSlash,Aty,FctSlashAty),
8431 buildName_(List,FctSlashAty,Result)
8432 ;
8433 Result = Fct
8434 ).
8436 buildName_([],Name,Name).
8437 buildName_([N|Ns],Name,Result) :-
8438 buildName_(Ns,Name,Name1),
8439 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8440 atomic_concat(NameDash,N,Result).
8442 vars_susp(A,Vars,Susp,VarsSusp) :-
8443 length(Vars,A),
8444 append(Vars,[Susp],VarsSusp).
8446 or_pattern(Pos,Pat) :-
8447 Pow is Pos - 1,
8448 Pat is 1 << Pow. % was 2 ** X
8450 and_pattern(Pos,Pat) :-
8451 X is Pos - 1,
8452 Y is 1 << X, % was 2 ** X
8453 Pat is (-1)*(Y + 1).
8455 make_name(Prefix,F/A,Name) :-
8456 atom_concat_list([Prefix,F,'___',A],Name).
8458 %===============================================================================
8459 % Attribute for attributed variables
8461 make_attr(N,Mask,SuspsList,Attr) :-
8462 length(SuspsList,N),
8463 Attr =.. [v,Mask|SuspsList].
8465 get_all_suspensions2(N,Attr,SuspensionsList) :-
8466 chr_pp_flag(dynattr,off), !,
8467 make_attr(N,_,SuspensionsList,Attr).
8469 % NEW
8470 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8471 % writeln(get_all_suspensions2),
8472 length(SuspensionsList,N),
8473 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8476 % NEW
8477 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8478 % writeln(normalize_attr),
8479 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8481 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8482 chr_pp_flag(dynattr,off),
8483 !, % chr_pp_flag(experiment,off), !,
8484 make_attr(N,_,SuspsList,Attr),
8485 nth1(Position,SuspsList,Suspensions).
8487 % get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8488 % chr_pp_flag(dynattr,off),
8489 % chr_pp_flag(experiment,on), !,
8490 % Position1 is Position + 1,
8491 % Goal = arg(Position1,TAttr,Suspensions).
8493 % NEW
8494 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8495 % writeln(get_suspensions),
8496 Goal =
8497 ( memberchk(Position-Suspensions,TAttr) ->
8498 true
8499 ;
8500 Suspensions = []
8501 ).
8503 %-------------------------------------------------------------------------------
8504 % +N: number of constraint symbols
8505 % +Suspension: source-level variable, for suspension
8506 % +Position: constraint symbol number
8507 % -Attr: source-level term, for new attribute
8508 singleton_attr(N,Suspension,Position,Attr) :-
8509 chr_pp_flag(dynattr,off), !,
8510 or_pattern(Position,Pattern),
8511 make_attr(N,Pattern,SuspsList,Attr),
8512 nth1(Position,SuspsList,[Suspension]),
8513 chr_delete(SuspsList,[Suspension],RestSuspsList),
8514 set_elems(RestSuspsList,[]).
8516 % NEW
8517 singleton_attr(N,Suspension,Position,Attr) :-
8518 % writeln(singleton_attr),
8519 Attr = [Position-[Suspension]].
8521 %-------------------------------------------------------------------------------
8522 % +N: number of constraint symbols
8523 % +Suspension: source-level variable, for suspension
8524 % +Position: constraint symbol number
8525 % +TAttr: source-level variable, for old attribute
8526 % -Goal: goal for creating new attribute
8527 % -NTAttr: source-level variable, for new attribute
8528 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8529 chr_pp_flag(dynattr,off), !,
8530 make_attr(N,Mask,SuspsList,Attr),
8531 or_pattern(Position,Pattern),
8532 nth1(Position,SuspsList,Susps),
8533 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8534 make_attr(N,Mask,SuspsList1,NewAttr1),
8535 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8536 make_attr(N,NewMask,SuspsList2,NewAttr2),
8537 Goal = (
8538 TAttr = Attr,
8539 ( Mask /\ Pattern =:= Pattern ->
8540 NTAttr = NewAttr1
8541 ;
8542 NewMask is Mask \/ Pattern,
8543 NTAttr = NewAttr2
8544 )
8545 ), !.
8547 % NEW
8548 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8549 % writeln(add_attr),
8550 Goal =
8551 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8552 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8553 ;
8554 NTAttr = [Position-[Suspension]|TAttr]
8555 ).
8557 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8558 chr_pp_flag(dynattr,off),
8559 chr_pp_flag(experiment,off), !,
8560 or_pattern(Position,Pattern),
8561 and_pattern(Position,DelPattern),
8562 make_attr(N,Mask,SuspsList,Attr),
8563 nth1(Position,SuspsList,Susps),
8564 substitute_eq(Susps,SuspsList,[],SuspsList1),
8565 make_attr(N,NewMask,SuspsList1,Attr1),
8566 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8567 make_attr(N,Mask,SuspsList2,Attr2),
8568 get_target_module(Mod),
8569 Goal = (
8570 TAttr = Attr,
8571 ( Mask /\ Pattern =:= Pattern ->
8572 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8573 ( NewSusps == [] ->
8574 NewMask is Mask /\ DelPattern,
8575 ( NewMask == 0 ->
8576 del_attr(Var,Mod)
8577 ;
8578 put_attr(Var,Mod,Attr1)
8579 )
8580 ;
8581 put_attr(Var,Mod,Attr2)
8582 )
8583 ;
8584 true
8585 )
8586 ), !.
8587 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8588 chr_pp_flag(dynattr,off),
8589 chr_pp_flag(experiment,on), !,
8590 or_pattern(Position,Pattern),
8591 and_pattern(Position,DelPattern),
8592 Position1 is Position + 1,
8593 get_target_module(Mod),
8594 Goal = (
8595 arg(1,TAttr,Mask),
8596 ( Mask /\ Pattern =:= Pattern ->
8597 arg(Position1,TAttr,Susps),
8598 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8599 ( NewSusps == [] ->
8600 NewMask is Mask /\ DelPattern,
8601 ( NewMask == 0 ->
8602 del_attr(Var,Mod)
8603 ;
8604 setarg(1,TAttr,NewMask),
8605 setarg(Position1,TAttr,NewSusps)
8606 )
8607 ;
8608 setarg(Position1,TAttr,NewSusps)
8609 )
8610 ;
8611 true
8612 )
8613 ), !.
8615 % NEW
8616 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8617 % writeln(rem_attr),
8618 get_target_module(Mod),
8619 Goal =
8620 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8621 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8622 ( NSuspensions == [] ->
8623 ( RAttr == [] ->
8624 del_attr(Var,Mod)
8625 ;
8626 put_attr(Var,Mod,RAttr)
8627 )
8628 ;
8629 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8630 )
8631 ;
8632 true
8633 ).
8635 %-------------------------------------------------------------------------------
8636 % +N: number of constraint symbols
8637 % +TAttr1: source-level variable, for attribute
8638 % +TAttr2: source-level variable, for other attribute
8639 % -Goal: goal for merging the two attributes
8640 % -Attr: source-level term, for merged attribute
8641 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8642 chr_pp_flag(dynattr,off), !,
8643 make_attr(N,Mask1,SuspsList1,Attr1),
8644 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8645 Goal = (
8646 TAttr1 = Attr1,
8647 Goal2
8648 ).
8650 % NEW
8651 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8652 % writeln(merge_attributes),
8653 Goal = (
8654 sort(TAttr1,Sorted1),
8655 sort(TAttr2,Sorted2),
8656 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8657 ).
8660 %-------------------------------------------------------------------------------
8661 % +N: number of constraint symbols
8662 % +Mask1: ...
8663 % +SuspsList1: static term, for suspensions list
8664 % +TAttr2: source-level variable, for other attribute
8665 % -Goal: goal for merging the two attributes
8666 % -Attr: source-level term, for merged attribute
8667 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8668 make_attr(N,Mask2,SuspsList2,Attr2),
8669 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8670 list2conj(Gs,SortGoals),
8671 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8672 make_attr(N,Mask,SuspsList,Attr),
8673 Goal = (
8674 TAttr2 = Attr2,
8675 SortGoals,
8676 Mask is Mask1 \/ Mask2
8677 ).
8680 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8681 % Storetype dependent lookup
8683 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8684 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8685 %% -Goal,-SuspensionList) is det.
8686 %
8687 % Create a universal lookup goal for given head.
8688 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8689 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8690 functor(Head,F,A),
8691 get_store_type(F/A,StoreType),
8692 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8694 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8695 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8696 %% -Goal,-SuspensionList) is det.
8697 %
8698 % Create a universal lookup goal for given head.
8699 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8700 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8701 functor(Head,F,A),
8702 get_store_type(F/A,StoreType),
8703 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8705 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8706 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8707 %% +GroundVars,-Goal,-SuspensionList) is det.
8708 %
8709 % Create a universal lookup goal for given head.
8710 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8711 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8712 functor(Head,F,A),
8713 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8714 update_store_type(F/A,default).
8715 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8716 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8717 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8718 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8719 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8720 functor(Head,F,A),
8721 global_ground_store_name(F/A,StoreName),
8722 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8723 update_store_type(F/A,global_ground).
8724 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8725 arg(VarIndex,Head,OVar),
8726 arg(KeyIndex,Head,OKey),
8727 translate([OVar,OKey],VarDict,[Var,Key]),
8728 get_target_module(Module),
8729 Goal = (
8730 get_attr(Var,Module,AssocStore),
8731 lookup_assoc_store(AssocStore,Key,AllSusps)
8732 ).
8733 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8734 functor(Head,F,A),
8735 global_singleton_store_name(F/A,StoreName),
8736 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8737 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8738 update_store_type(F/A,global_singleton).
8739 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8740 once((
8741 member(ST,StoreTypes),
8742 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8743 )).
8744 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8745 functor(Head,F,A),
8746 arg(Index,Head,Var),
8747 translate([Var],VarDict,[KeyVar]),
8748 delay_phase_end(validate_store_type_assumptions,
8749 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8750 ),
8751 update_store_type(F/A,identifier_store(Index)),
8752 get_identifier_index(F/A,Index,_).
8753 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8754 functor(Head,F,A),
8755 arg(Index,Head,Var),
8756 ( var(Var) ->
8757 translate([Var],VarDict,[KeyVar]),
8758 Goal = StructGoal
8759 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8760 lookup_only_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8761 Goal = (LookupGoal,StructGoal)
8762 ),
8763 delay_phase_end(validate_store_type_assumptions,
8764 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8765 ),
8766 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8767 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8769 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8770 get_identifier_size(ISize),
8771 functor(Struct,struct,ISize),
8772 get_identifier_index(C,Index,IIndex),
8773 arg(IIndex,Struct,AllSusps),
8774 Goal = (KeyVar = Struct).
8776 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8777 type_indexed_identifier_structure(IndexType,Struct),
8778 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8779 arg(IIndex,Struct,AllSusps),
8780 Goal = (KeyVar = Struct).
8782 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8783 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8784 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8785 %
8786 % Create a universal hash lookup goal for given head.
8787 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8788 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8789 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8790 ( KeyArgCopies = [KeyCopy] ->
8791 true
8792 ;
8793 KeyCopy =.. [k|KeyArgCopies]
8794 ),
8795 functor(Head,F,A),
8796 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8798 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8799 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8801 Goal = (GroundCheck,LookupGoal),
8803 ( HashType == inthash ->
8804 update_store_type(F/A,multi_inthash([Index]))
8805 ;
8806 update_store_type(F/A,multi_hash([Index]))
8807 ).
8809 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8810 member(Index,Indexes),
8811 args(Index,Head,KeyArgs),
8812 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8813 !.
8815 % check whether we can copy the given terms
8816 % with the given dictionary, and, if so, do so
8817 key_in_scope([],VarDict,[]).
8818 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8819 term_variables(Arg,Vars),
8820 translate(Vars,VarDict,VarCopies),
8821 copy_term(Arg/Vars,ArgCopy/VarCopies),
8822 key_in_scope(Args,VarDict,ArgCopies).
8824 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8825 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8826 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8827 %% +VarArgDict,-NewVarArgDict) is det.
8828 %
8829 % Create existential lookup goal for given head.
8830 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8831 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8832 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8833 sbag_member_call(Susp,AllSusps,Sbag),
8834 functor(Head,F,A),
8835 delay_phase_end(validate_store_type_assumptions,
8836 ( static_suspension_term(F/A,SuspTerm),
8837 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8838 )
8839 ),
8840 Goal = (
8841 UniversalGoal,
8842 Sbag,
8843 Susp = SuspTerm,
8844 GetState
8845 ).
8846 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8847 functor(Head,F,A),
8848 global_singleton_store_name(F/A,StoreName),
8849 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8850 Goal = (
8851 GetStoreGoal, % nb_getval(StoreName,Susp),
8852 Susp \== [],
8853 Susp = SuspTerm
8854 ),
8855 update_store_type(F/A,global_singleton).
8856 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8857 once((
8858 member(ST,StoreTypes),
8859 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8860 )).
8861 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8862 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8863 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8864 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8865 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8866 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8867 hash_index_filter(Pairs,[Index],NPairs),
8869 functor(Head,F,A),
8870 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8871 Sbag = (AllSusps = [Susp])
8872 ;
8873 sbag_member_call(Susp,AllSusps,Sbag)
8874 ),
8875 delay_phase_end(validate_store_type_assumptions,
8876 ( static_suspension_term(F/A,SuspTerm),
8877 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8878 )
8879 ),
8880 Goal = (
8881 LookupGoal,
8882 Sbag,
8883 Susp = SuspTerm, % not inlined
8884 GetState
8885 ).
8886 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8887 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8888 hash_index_filter(Pairs,[Index],NPairs),
8890 functor(Head,F,A),
8891 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8892 Sbag = (AllSusps = [Susp])
8893 ;
8894 sbag_member_call(Susp,AllSusps,Sbag)
8895 ),
8896 delay_phase_end(validate_store_type_assumptions,
8897 ( static_suspension_term(F/A,SuspTerm),
8898 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8899 )
8900 ),
8901 Goal = (
8902 LookupGoal,
8903 Sbag,
8904 Susp = SuspTerm, % not inlined
8905 GetState
8906 ).
8907 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8908 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8909 sbag_member_call(Susp,Susps,Sbag),
8910 functor(Head,F,A),
8911 delay_phase_end(validate_store_type_assumptions,
8912 ( static_suspension_term(F/A,SuspTerm),
8913 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8914 )
8915 ),
8916 Goal = (
8917 UGoal,
8918 Sbag,
8919 Susp = SuspTerm, % not inlined
8920 GetState
8921 ).
8923 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8924 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8925 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8926 %% +VarArgDict,-NewVarArgDict) is det.
8927 %
8928 % Create existential hash lookup goal for given head.
8929 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8930 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8931 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8933 hash_index_filter(Pairs,Index,NPairs),
8935 functor(Head,F,A),
8936 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8937 Sbag = (AllSusps = [Susp])
8938 ;
8939 sbag_member_call(Susp,AllSusps,Sbag)
8940 ),
8941 delay_phase_end(validate_store_type_assumptions,
8942 ( static_suspension_term(F/A,SuspTerm),
8943 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8944 )
8945 ),
8946 Goal = (
8947 LookupGoal,
8948 Sbag,
8949 Susp = SuspTerm, % not inlined
8950 GetState
8951 ).
8953 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8954 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8955 %
8956 % Filter out pairs already covered by given hash index.
8957 % makes them 'silent'
8958 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8959 hash_index_filter(Pairs,Index,NPairs) :-
8960 hash_index_filter(Pairs,Index,1,NPairs).
8962 hash_index_filter([],_,_,[]).
8963 hash_index_filter([P|Ps],Index,N,NPairs) :-
8964 ( Index = [I|Is] ->
8965 NN is N + 1,
8966 ( I > N ->
8967 NPairs = [P|NPs],
8968 hash_index_filter(Ps,[I|Is],NN,NPs)
8969 ; I == N ->
8970 NPairs = [silent(P)|NPs],
8971 hash_index_filter(Ps,Is,NN,NPs)
8972 )
8973 ;
8974 NPairs = [P|Ps]
8975 ).
8977 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8978 %------------------------------------------------------------------------------%
8979 %% assume_constraint_stores(+ConstraintSymbols) is det.
8980 %
8981 % Compute all constraint store types that are possible for the given
8982 % =ConstraintSymbols=.
8983 %------------------------------------------------------------------------------%
8984 assume_constraint_stores([]).
8985 assume_constraint_stores([C|Cs]) :-
8986 ( chr_pp_flag(debugable,off),
8987 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8988 is_stored(C),
8989 get_store_type(C,default) ->
8990 get_indexed_arguments(C,AllIndexedArgs),
8991 get_constraint_mode(C,Modes),
8992 aggregate_all(bag(Index)-count,
8993 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8994 IndexedArgs-NbIndexedArgs),
8995 % Construct Index Combinations
8996 ( NbIndexedArgs > 10 ->
8997 findall([Index],member(Index,IndexedArgs),Indexes)
8998 ;
8999 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
9000 predsort(longer_list,UnsortedIndexes,Indexes)
9001 ),
9002 % EXPERIMENTAL HEURISTIC
9003 % findall(Index, (
9004 % member(Arg1,IndexedArgs),
9005 % member(Arg2,IndexedArgs),
9006 % Arg1 =< Arg2,
9007 % sort([Arg1,Arg2], Index)
9008 % ), UnsortedIndexes),
9009 % predsort(longer_list,UnsortedIndexes,Indexes),
9010 % Choose Index Type
9011 ( get_functional_dependency(C,1,Pattern,Key),
9012 all_distinct_var_args(Pattern), Key == [] ->
9013 assumed_store_type(C,global_singleton)
9014 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
9015 get_constraint_type_det(C,ArgTypes),
9016 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
9018 ( IntHashIndexes = [] ->
9019 Stores = Stores1
9020 ;
9021 Stores = [multi_inthash(IntHashIndexes)|Stores1]
9022 ),
9023 ( HashIndexes = [] ->
9024 Stores1 = Stores2
9025 ;
9026 Stores1 = [multi_hash(HashIndexes)|Stores2]
9027 ),
9028 ( IdentifierIndexes = [] ->
9029 Stores2 = Stores3
9030 ;
9031 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
9032 append(WrappedIdentifierIndexes,Stores3,Stores2)
9033 ),
9034 append(CompoundIdentifierIndexes,Stores4,Stores3),
9035 ( only_ground_indexed_arguments(C)
9036 -> Stores4 = [global_ground]
9037 ; Stores4 = [default]
9038 ),
9039 assumed_store_type(C,multi_store(Stores))
9040 ; true
9041 )
9042 ;
9043 true
9044 ),
9045 assume_constraint_stores(Cs).
9047 %------------------------------------------------------------------------------%
9048 %% partition_indexes(+Indexes,+Types,
9049 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
9050 %------------------------------------------------------------------------------%
9051 partition_indexes([],_,[],[],[],[]).
9052 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
9053 ( Index = [I],
9054 nth1(I,Types,Type),
9055 unalias_type(Type,UnAliasedType),
9056 UnAliasedType == chr_identifier ->
9057 IdentifierIndexes = [I|RIdentifierIndexes],
9058 IntHashIndexes = RIntHashIndexes,
9059 HashIndexes = RHashIndexes,
9060 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9061 ; Index = [I],
9062 nth1(I,Types,Type),
9063 unalias_type(Type,UnAliasedType),
9064 nonvar(UnAliasedType),
9065 UnAliasedType = chr_identifier(IndexType) ->
9066 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
9067 IdentifierIndexes = RIdentifierIndexes,
9068 IntHashIndexes = RIntHashIndexes,
9069 HashIndexes = RHashIndexes
9070 ; Index = [I],
9071 nth1(I,Types,Type),
9072 unalias_type(Type,UnAliasedType),
9073 UnAliasedType == dense_int ->
9074 IntHashIndexes = [Index|RIntHashIndexes],
9075 HashIndexes = RHashIndexes,
9076 IdentifierIndexes = RIdentifierIndexes,
9077 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9078 ; member(I,Index),
9079 nth1(I,Types,Type),
9080 unalias_type(Type,UnAliasedType),
9081 nonvar(UnAliasedType),
9082 UnAliasedType = chr_identifier(_) ->
9083 % don't use chr_identifiers in hash indexes
9084 IntHashIndexes = RIntHashIndexes,
9085 HashIndexes = RHashIndexes,
9086 IdentifierIndexes = RIdentifierIndexes,
9087 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9088 ;
9089 IntHashIndexes = RIntHashIndexes,
9090 HashIndexes = [Index|RHashIndexes],
9091 IdentifierIndexes = RIdentifierIndexes,
9092 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9093 ),
9094 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
9096 longer_list(R,L1,L2) :-
9097 length(L1,N1),
9098 length(L2,N2),
9099 compare(Rt,N2,N1),
9100 ( Rt == (=) ->
9101 compare(R,L1,L2)
9102 ;
9103 R = Rt
9104 ).
9106 all_distinct_var_args(Term) :-
9107 copy_term_nat(Term,TermCopy),
9108 functor(Term,F,A),
9109 functor(Pattern,F,A),
9110 Pattern =@= TermCopy.
9112 get_indexed_arguments(C,IndexedArgs) :-
9113 C = F/A,
9114 get_indexed_arguments(1,A,C,IndexedArgs).
9116 get_indexed_arguments(I,N,C,L) :-
9117 ( I > N ->
9118 L = []
9119 ; ( is_indexed_argument(C,I) ->
9120 L = [I|T]
9121 ;
9122 L = T
9123 ),
9124 J is I + 1,
9125 get_indexed_arguments(J,N,C,T)
9126 ).
9128 validate_store_type_assumptions([]).
9129 validate_store_type_assumptions([C|Cs]) :-
9130 validate_store_type_assumption(C),
9131 validate_store_type_assumptions(Cs).
9133 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9134 % new code generation
9135 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
9136 Rule = rule(H1,_,Guard,Body),
9137 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9138 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
9139 flatten(VarsAndSuspsList,VarsAndSusps),
9140 Vars = [ [] | VarsAndSusps],
9141 build_head(F,A,[O|Id],Vars,Head),
9142 ( PrevId0 = [_] ->
9143 get_success_continuation_code_id(F/A,O,PredictedPrevId),
9144 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
9145 PrevId = [PredictedPrevId] % PrevId = PrevId0
9146 ;
9147 PrevId = [O|PrevId0]
9148 ),
9149 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9150 Clause = ( Head :- PredecessorCall),
9151 add_dummy_location(Clause,LocatedClause),
9152 L = [LocatedClause | T].
9153 % ( H1 == [],
9154 % functor(CurrentHead,CF,CA),
9155 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
9156 % L = T
9157 % ;
9158 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9159 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
9160 % flatten(VarsAndSuspsList,VarsAndSusps),
9161 % Vars = [ [] | VarsAndSusps],
9162 % build_head(F,A,Id,Vars,Head),
9163 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9164 % Clause = ( Head :- PredecessorCall),
9165 % L = [Clause | T]
9166 % ).
9168 % skips back intelligently over global_singleton lookups
9169 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
9170 ( Id = [0|_] ->
9171 % TOM: add partial success continuation optimization here!
9172 next_id(Id,PrevId),
9173 PrevVarsAndSusps = BaseCallArgs
9174 ;
9175 VarsAndSuspsList = [_|AllButFirstList],
9176 dec_id(Id,PrevId1),
9177 ( PrevHeads = [PrevHead|PrevHeads1],
9178 functor(PrevHead,F,A),
9179 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
9180 PrevIterators = [_|PrevIterators1],
9181 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
9182 ;
9183 PrevId = PrevId1,
9184 flatten(AllButFirstList,AllButFirst),
9185 PrevIterators = [PrevIterator|_],
9186 PrevVarsAndSusps = [PrevIterator|AllButFirst]
9187 )
9188 ).
9190 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
9191 Rule = rule(_,_,Guard,Body),
9192 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
9193 init(AllSusps,PreSusps),
9194 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
9195 gen_var(OtherSusps),
9196 functor(CurrentHead,OtherF,OtherA),
9197 gen_vars(OtherA,OtherVars),
9198 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
9199 get_constraint_mode(OtherF/OtherA,Mode),
9200 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
9202 delay_phase_end(validate_store_type_assumptions,
9203 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
9204 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
9205 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
9206 )
9207 ),
9209 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
9210 % create_get_mutable_ref(active,State,GetMutable),
9211 CurrentSuspTest = (
9212 OtherSusp = OtherSuspension,
9213 GetState,
9214 DiffSuspGoals,
9215 FirstMatching
9216 ),
9217 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
9218 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
9219 inc_id(Id,NestedId),
9220 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
9221 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
9222 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
9223 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
9224 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9226 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9227 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9228 RecursiveVars = PreVarsAndSusps1
9229 ;
9230 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9231 PrevId0 = Id
9232 ),
9233 ( PrevId0 = [_] ->
9234 PrevId = PrevId0
9235 ;
9236 PrevId = [O|PrevId0]
9237 ),
9238 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9240 Clause = (
9241 ClauseHead :-
9242 ( CurrentSuspTest,
9243 NextSuspGoal
9244 ->
9245 NestedHead
9246 ; RecursiveHead
9247 )
9248 ),
9249 add_dummy_location(Clause,LocatedClause),
9250 L = [LocatedClause|T].
9252 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9254 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9255 % Observation Analysis
9256 %
9257 % CLASSIFICATION
9258 % Enabled
9259 %
9260 % Analysis based on Abstract Interpretation paper.
9261 %
9262 % TODO:
9263 % stronger analysis domain [research]
9265 :- chr_constraint
9266 initial_call_pattern/1,
9267 call_pattern/1,
9268 call_pattern_worker/1,
9269 final_answer_pattern/2,
9270 abstract_constraints/1,
9271 depends_on/2,
9272 depends_on_ap/4,
9273 depends_on_goal/2,
9274 ai_observed_internal/2,
9275 % ai_observed/2,
9276 ai_not_observed_internal/2,
9277 ai_not_observed/2,
9278 ai_is_observed/2,
9279 depends_on_as/3,
9280 ai_observation_gather_results/0.
9282 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9283 :- chr_type program_point == any.
9285 :- chr_option(mode,initial_call_pattern(+)).
9286 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9288 :- chr_option(mode,call_pattern(+)).
9289 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9291 :- chr_option(mode,call_pattern_worker(+)).
9292 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9294 :- chr_option(mode,final_answer_pattern(+,+)).
9295 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9297 :- chr_option(mode,abstract_constraints(+)).
9298 :- chr_option(type_declaration,abstract_constraints(list)).
9300 :- chr_option(mode,depends_on(+,+)).
9301 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9303 :- chr_option(mode,depends_on_as(+,+,+)).
9304 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9305 :- chr_option(mode,depends_on_goal(+,+)).
9306 :- chr_option(mode,ai_is_observed(+,+)).
9307 :- chr_option(mode,ai_not_observed(+,+)).
9308 % :- chr_option(mode,ai_observed(+,+)).
9309 :- chr_option(mode,ai_not_observed_internal(+,+)).
9310 :- chr_option(mode,ai_observed_internal(+,+)).
9313 abstract_constraints_fd @
9314 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9316 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9317 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9318 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9320 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9321 ai_is_observed(_,_) <=> true.
9323 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9324 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9325 ai_observation_gather_results <=> true.
9327 %------------------------------------------------------------------------------%
9328 % Main Analysis Entry
9329 %------------------------------------------------------------------------------%
9330 ai_observation_analysis(ACs) :-
9331 ( chr_pp_flag(ai_observation_analysis,on),
9332 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9333 list_to_ord_set(ACs,ACSet),
9334 abstract_constraints(ACSet),
9335 ai_observation_schedule_initial_calls(ACSet,ACSet),
9336 ai_observation_gather_results
9337 ;
9338 true
9339 ).
9341 ai_observation_schedule_initial_calls([],_).
9342 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9343 ai_observation_schedule_initial_call(AC,ACs),
9344 ai_observation_schedule_initial_calls(RACs,ACs).
9346 ai_observation_schedule_initial_call(AC,ACs) :-
9347 ai_observation_top(AC,CallPattern),
9348 % ai_observation_bot(AC,ACs,CallPattern),
9349 initial_call_pattern(CallPattern).
9351 ai_observation_schedule_new_calls([],AP).
9352 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9353 AP = odom(_,Set),
9354 initial_call_pattern(odom(AC,Set)),
9355 ai_observation_schedule_new_calls(ACs,AP).
9357 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9358 <=>
9359 ai_observation_leq(AP2,AP1)
9360 |
9361 true.
9363 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9365 initial_call_pattern(CP) ==> call_pattern(CP).
9367 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9368 ==>
9369 ai_observation_schedule_new_calls(ACs,AP)
9370 pragma
9371 passive(ID3).
9373 call_pattern(CP) \ call_pattern(CP) <=> true.
9375 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9376 final_answer_pattern(CP1,AP).
9378 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9380 call_pattern(CP) ==> call_pattern_worker(CP).
9382 %------------------------------------------------------------------------------%
9383 % Abstract Goal
9384 %------------------------------------------------------------------------------%
9386 % AbstractGoala
9387 %call_pattern(odom([],Set)) ==>
9388 % final_answer_pattern(odom([],Set),odom([],Set)).
9390 call_pattern_worker(odom([],Set)) <=>
9391 % writeln(' - AbstractGoal'(odom([],Set))),
9392 final_answer_pattern(odom([],Set),odom([],Set)).
9394 % AbstractGoalb
9395 call_pattern_worker(odom([G|Gs],Set)) <=>
9396 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9397 CP1 = odom(G,Set),
9398 depends_on_goal(odom([G|Gs],Set),CP1),
9399 call_pattern(CP1).
9401 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9402 <=> true pragma passive(ID).
9403 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9404 ==>
9405 CP1 = odom([_|Gs],_),
9406 AP2 = odom([],Set),
9407 CCP = odom(Gs,Set),
9408 call_pattern(CCP),
9409 depends_on(CP1,CCP).
9411 %------------------------------------------------------------------------------%
9412 % Abstract Disjunction
9413 %------------------------------------------------------------------------------%
9415 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9416 CP = odom((AG1;AG2),Set),
9417 InitialAnswerApproximation = odom([],Set),
9418 final_answer_pattern(CP,InitialAnswerApproximation),
9419 CP1 = odom(AG1,Set),
9420 CP2 = odom(AG2,Set),
9421 call_pattern(CP1),
9422 call_pattern(CP2),
9423 depends_on_as(CP,CP1,CP2).
9425 %------------------------------------------------------------------------------%
9426 % Abstract Solve
9427 %------------------------------------------------------------------------------%
9428 call_pattern_worker(odom(builtin,Set)) <=>
9429 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9430 ord_empty(EmptySet),
9431 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9433 %------------------------------------------------------------------------------%
9434 % Abstract Drop
9435 %------------------------------------------------------------------------------%
9436 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9437 <=>
9438 O > MO
9439 |
9440 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9441 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9442 pragma
9443 passive(ID2).
9445 %------------------------------------------------------------------------------%
9446 % Abstract Activate
9447 %------------------------------------------------------------------------------%
9448 call_pattern_worker(odom(AC,Set))
9449 <=>
9450 AC = _ / _
9451 |
9452 % writeln(' - AbstractActivate'(odom(AC,Set))),
9453 CP = odom(occ(AC,1),Set),
9454 call_pattern(CP),
9455 depends_on(odom(AC,Set),CP).
9457 %------------------------------------------------------------------------------%
9458 % Abstract Passive
9459 %------------------------------------------------------------------------------%
9460 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9461 <=>
9462 is_passive(RuleNb,ID)
9463 |
9464 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9465 % DEFAULT
9466 NO is O + 1,
9467 DCP = odom(occ(C,NO),Set),
9468 call_pattern(DCP),
9469 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9470 depends_on(odom(occ(C,O),Set),DCP)
9471 pragma
9472 passive(ID2).
9473 %------------------------------------------------------------------------------%
9474 % Abstract Simplify
9475 %------------------------------------------------------------------------------%
9477 % AbstractSimplify
9478 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9479 <=>
9480 \+ is_passive(RuleNb,ID)
9481 |
9482 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9483 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9484 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9485 ai_observation_memo_abstract_goal(RuleNb,AG),
9486 call_pattern(odom(AG,Set2)),
9487 % DEFAULT
9488 NO is O + 1,
9489 DCP = odom(occ(C,NO),Set),
9490 call_pattern(DCP),
9491 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9492 % DEADLOCK AVOIDANCE
9493 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9494 pragma
9495 passive(ID2).
9497 depends_on_as(CP,CPS,CPD),
9498 final_answer_pattern(CPS,APS),
9499 final_answer_pattern(CPD,APD) ==>
9500 ai_observation_lub(APS,APD,AP),
9501 final_answer_pattern(CP,AP).
9504 :- chr_constraint
9505 ai_observation_memo_simplification_rest_heads/3,
9506 ai_observation_memoed_simplification_rest_heads/3.
9508 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9509 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9511 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9512 <=>
9513 QRH = RH.
9514 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9515 <=>
9516 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9517 once(select2(ID,_,IDs1,H1,_,RestH1)),
9518 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9519 ai_observation_abstract_constraints(H2,ACs,AH2),
9520 append(ARestHeads,AH2,AbstractHeads),
9521 sort(AbstractHeads,QRH),
9522 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9523 pragma
9524 passive(ID1),
9525 passive(ID2),
9526 passive(ID3).
9528 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9530 %------------------------------------------------------------------------------%
9531 % Abstract Propagate
9532 %------------------------------------------------------------------------------%
9535 % AbstractPropagate
9536 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9537 <=>
9538 \+ is_passive(RuleNb,ID)
9539 |
9540 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9541 % observe partners
9542 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9543 ai_observation_observe_set(Set,AHs,Set2),
9544 ord_add_element(Set2,C,Set3),
9545 ai_observation_memo_abstract_goal(RuleNb,AG),
9546 call_pattern(odom(AG,Set3)),
9547 ( ord_memberchk(C,Set2) ->
9548 Delete = no
9549 ;
9550 Delete = yes
9551 ),
9552 % DEFAULT
9553 NO is O + 1,
9554 DCP = odom(occ(C,NO),Set),
9555 call_pattern(DCP),
9556 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9557 pragma
9558 passive(ID2).
9560 :- chr_constraint
9561 ai_observation_memo_propagation_rest_heads/3,
9562 ai_observation_memoed_propagation_rest_heads/3.
9564 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9565 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9567 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9568 <=>
9569 QRH = RH.
9570 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9571 <=>
9572 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9573 once(select2(ID,_,IDs2,H2,_,RestH2)),
9574 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9575 ai_observation_abstract_constraints(H1,ACs,AH1),
9576 append(ARestHeads,AH1,AbstractHeads),
9577 sort(AbstractHeads,QRH),
9578 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9579 pragma
9580 passive(ID1),
9581 passive(ID2),
9582 passive(ID3).
9584 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9586 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9587 final_answer_pattern(CP,APD).
9588 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9589 final_answer_pattern(CPD,APD) ==>
9590 true |
9591 CP = odom(occ(C,O),_),
9592 ( ai_observation_is_observed(APP,C) ->
9593 ai_observed_internal(C,O)
9594 ;
9595 ai_not_observed_internal(C,O)
9596 ),
9597 ( Delete == yes ->
9598 APP = odom([],Set0),
9599 ord_del_element(Set0,C,Set),
9600 NAPP = odom([],Set)
9601 ;
9602 NAPP = APP
9603 ),
9604 ai_observation_lub(NAPP,APD,AP),
9605 final_answer_pattern(CP,AP).
9607 %------------------------------------------------------------------------------%
9608 % Catch All
9609 %------------------------------------------------------------------------------%
9611 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9613 %------------------------------------------------------------------------------%
9614 % Auxiliary Predicates
9615 %------------------------------------------------------------------------------%
9617 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9618 ord_intersection(S1,S2,S3).
9620 ai_observation_bot(AG,AS,odom(AG,AS)).
9622 ai_observation_top(AG,odom(AG,EmptyS)) :-
9623 ord_empty(EmptyS).
9625 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9626 ord_subset(S2,S1).
9628 ai_observation_observe_set(S,ACSet,NS) :-
9629 ord_subtract(S,ACSet,NS).
9631 ai_observation_abstract_constraint(C,ACs,AC) :-
9632 functor(C,F,A),
9633 AC = F/A,
9634 memberchk(AC,ACs).
9636 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9637 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9639 %------------------------------------------------------------------------------%
9640 % Abstraction of Rule Bodies
9641 %------------------------------------------------------------------------------%
9643 :- chr_constraint
9644 ai_observation_memoed_abstract_goal/2,
9645 ai_observation_memo_abstract_goal/2.
9647 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9648 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9650 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9651 <=>
9652 QAG = AG
9653 pragma
9654 passive(ID1).
9656 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9657 <=>
9658 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9659 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9660 QAG = AG,
9661 ai_observation_memoed_abstract_goal(RuleNb,AG)
9662 pragma
9663 passive(ID1),
9664 passive(ID2).
9666 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9667 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9668 term_variables((H1,H2,Guard),HVars),
9669 append(H1,H2,Heads),
9670 % variables that are declared to be ground are safe,
9671 ground_vars(Heads,GroundVars),
9672 % so we remove them from the list of 'dangerous' head variables
9673 list_difference_eq(HVars,GroundVars,HV),
9674 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9675 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9676 % HV are 'dangerous' variables, all others are fresh and safe
9678 ground_vars([],[]).
9679 ground_vars([H|Hs],GroundVars) :-
9680 functor(H,F,A),
9681 get_constraint_mode(F/A,Mode),
9682 % TOM: fix this code!
9683 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9684 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9685 ground_vars(Hs,GroundVars2),
9686 append(GroundVars1,GroundVars2,GroundVars).
9688 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9689 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9690 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9691 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9692 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9693 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9694 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9695 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9696 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9697 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9698 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9699 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9700 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9701 % non-CHR constraint is safe if it only binds fresh variables
9702 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9703 builtin_binds_b(G,Vars),
9704 intersect_eq(Vars,HV,[]),
9705 !.
9706 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9707 AG = builtin. % default case if goal is not recognized/safe
9709 ai_observation_is_observed(odom(_,ACSet),AC) :-
9710 \+ ord_memberchk(AC,ACSet).
9712 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9713 unconditional_occurrence(C,O) :-
9714 get_occurrence(C,O,RuleNb,ID),
9715 get_rule(RuleNb,PRule),
9716 PRule = pragma(ORule,_,_,_,_),
9717 copy_term_nat(ORule,Rule),
9718 Rule = rule(H1,H2,Guard,_),
9719 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9720 once((
9721 H1 = [Head], H2 == []
9722 ;
9723 H2 = [Head], H1 == [], \+ may_trigger(C)
9724 )),
9725 all_distinct_var_args(Head).
9727 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9729 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9730 % Partial wake analysis
9731 %
9732 % In a Var = Var unification do not wake up constraints of both variables,
9733 % but rather only those of one variable.
9734 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9736 :- chr_constraint partial_wake_analysis/0.
9737 :- chr_constraint no_partial_wake/1.
9738 :- chr_option(mode,no_partial_wake(+)).
9739 :- chr_constraint wakes_partially/1.
9740 :- chr_option(mode,wakes_partially(+)).
9742 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9743 ==>
9744 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9745 ( is_passive(RuleNb,ID) ->
9746 true
9747 ; Type == simplification ->
9748 select(H,H1,RestH1),
9749 H =.. [_|Args],
9750 term_variables(Guard,Vars),
9751 partial_wake_args(Args,ArgModes,Vars,FA)
9752 ; % Type == propagation ->
9753 select(H,H2,RestH2),
9754 H =.. [_|Args],
9755 term_variables(Guard,Vars),
9756 partial_wake_args(Args,ArgModes,Vars,FA)
9757 ).
9759 partial_wake_args([],_,_,_).
9760 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9761 ( Mode \== (+) ->
9762 ( nonvar(Arg) ->
9763 no_partial_wake(C)
9764 ; memberchk_eq(Arg,Vars) ->
9765 no_partial_wake(C)
9766 ;
9767 true
9768 )
9769 ;
9770 true
9771 ),
9772 partial_wake_args(Args,Modes,Vars,C).
9774 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9776 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9778 wakes_partially(C) <=> true.
9781 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9782 % Generate rules that implement chr_show_store/1 functionality.
9783 %
9784 % CLASSIFICATION
9785 % Experimental
9786 % Unused
9787 %
9788 % Generates additional rules:
9789 %
9790 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9791 % ...
9792 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9793 % $show <=> true.
9795 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9796 ( chr_pp_flag(show,on) ->
9797 Constraints = ['$show'/0|Constraints0],
9798 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9799 inc_rule_count(RuleNb),
9800 Rule = pragma(
9801 rule(['$show'],[],true,true),
9802 ids([0],[]),
9803 [],
9804 no,
9805 RuleNb
9806 )
9807 ;
9808 Constraints = Constraints0,
9809 Rules = Rules0
9810 ).
9812 generate_show_rules([],Rules,Rules).
9813 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9814 functor(C,F,A),
9815 inc_rule_count(RuleNb),
9816 Rule = pragma(
9817 rule([],['$show',C],true,writeln(C)),
9818 ids([],[0,1]),
9819 [passive(1)],
9820 no,
9821 RuleNb
9822 ),
9823 generate_show_rules(Rest,Tail,Rules).
9825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9826 % Custom supension term layout
9828 static_suspension_term(F/A,Suspension) :-
9829 suspension_term_base(F/A,Base),
9830 Arity is Base + A,
9831 functor(Suspension,suspension,Arity).
9833 has_suspension_field(FA,Field) :-
9834 suspension_term_base_fields(FA,Fields),
9835 memberchk(Field,Fields).
9837 suspension_term_base(FA,Base) :-
9838 suspension_term_base_fields(FA,Fields),
9839 length(Fields,Base).
9841 suspension_term_base_fields(FA,Fields) :-
9842 ( chr_pp_flag(debugable,on) ->
9843 % 1. ID
9844 % 2. State
9845 % 3. Propagation History
9846 % 4. Generation Number
9847 % 5. Continuation Goal
9848 % 6. Functor
9849 Fields = [id,state,history,generation,continuation,functor]
9850 ;
9851 ( uses_history(FA) ->
9852 Fields = [id,state,history|Fields2]
9853 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9854 Fields = [state|Fields2]
9855 ;
9856 Fields = [id,state|Fields2]
9857 ),
9858 ( only_ground_indexed_arguments(FA) ->
9859 get_store_type(FA,StoreType),
9860 basic_store_types(StoreType,BasicStoreTypes),
9861 ( memberchk(global_ground,BasicStoreTypes) ->
9862 % 1. ID
9863 % 2. State
9864 % 3. Propagation History
9865 % 4. Global List Prev
9866 Fields2 = [global_list_prev|Fields3]
9867 ;
9868 % 1. ID
9869 % 2. State
9870 % 3. Propagation History
9871 Fields2 = Fields3
9872 ),
9873 ( chr_pp_flag(ht_removal,on)
9874 -> ht_prev_fields(BasicStoreTypes,Fields3)
9875 ; Fields3 = []
9876 )
9877 ; may_trigger(FA) ->
9878 % 1. ID
9879 % 2. State
9880 % 3. Propagation History
9881 ( uses_field(FA,generation) ->
9882 % 4. Generation Number
9883 % 5. Global List Prev
9884 Fields2 = [generation,global_list_prev|Fields3]
9885 ;
9886 Fields2 = [global_list_prev|Fields3]
9887 ),
9888 ( chr_pp_flag(mixed_stores,on),
9889 chr_pp_flag(ht_removal,on)
9890 -> get_store_type(FA,StoreType),
9891 basic_store_types(StoreType,BasicStoreTypes),
9892 ht_prev_fields(BasicStoreTypes,Fields3)
9893 ; Fields3 = []
9894 )
9895 ;
9896 % 1. ID
9897 % 2. State
9898 % 3. Propagation History
9899 % 4. Global List Prev
9900 Fields2 = [global_list_prev|Fields3],
9901 ( chr_pp_flag(mixed_stores,on),
9902 chr_pp_flag(ht_removal,on)
9903 -> get_store_type(FA,StoreType),
9904 basic_store_types(StoreType,BasicStoreTypes),
9905 ht_prev_fields(BasicStoreTypes,Fields3)
9906 ; Fields3 = []
9907 )
9908 )
9909 ).
9911 ht_prev_fields(Stores,Prevs) :-
9912 ht_prev_fields_int(Stores,PrevsList),
9913 append(PrevsList,Prevs).
9914 ht_prev_fields_int([],[]).
9915 ht_prev_fields_int([H|T],Fields) :-
9916 ( H = multi_hash(Indexes)
9917 -> maplist(ht_prev_field,Indexes,FH),
9918 Fields = [FH|FT]
9919 ; Fields = FT
9920 ),
9921 ht_prev_fields_int(T,FT).
9923 ht_prev_field(Index,Field) :-
9924 concat_atom(['multi_hash_prev-'|Index],Field).
9926 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9927 suspension_term_base_fields(FA,Fields),
9928 nth1(Index,Fields,FieldName), !,
9929 arg(Index,StaticSuspension,Field).
9930 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9931 suspension_term_base(FA,Base),
9932 StaticSuspension =.. [_|Args],
9933 drop(Base,Args,Field).
9934 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9935 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9938 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9939 suspension_term_base_fields(FA,Fields),
9940 nth1(Index,Fields,FieldName), !,
9941 Goal = arg(Index,DynamicSuspension,Field).
9942 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9943 static_suspension_term(FA,StaticSuspension),
9944 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9945 Goal = (DynamicSuspension = StaticSuspension).
9946 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9947 suspension_term_base(FA,Base),
9948 Index is I + Base,
9949 Goal = arg(Index,DynamicSuspension,Field).
9950 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9951 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9954 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9955 suspension_term_base_fields(FA,Fields),
9956 nth1(Index,Fields,FieldName), !,
9957 Goal = setarg(Index,DynamicSuspension,Field).
9958 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9959 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9961 basic_store_types(multi_store(Types),Types) :- !.
9962 basic_store_types(Type,[Type]).
9964 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9965 %
9967 :- chr_constraint
9968 phase_end/1,
9969 delay_phase_end/2.
9971 :- chr_option(mode,phase_end(+)).
9972 :- chr_option(mode,delay_phase_end(+,?)).
9974 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9975 % phase_end(Phase) <=> true.
9978 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9979 :- chr_constraint
9980 does_use_history/2,
9981 uses_history/1,
9982 novel_production_call/4.
9984 :- chr_option(mode,uses_history(+)).
9985 :- chr_option(mode,does_use_history(+,+)).
9986 :- chr_option(mode,novel_production_call(+,+,?,?)).
9988 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9989 does_use_history(FA,_) \ uses_history(FA) <=> true.
9990 uses_history(_FA) <=> fail.
9992 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9993 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9995 :- chr_constraint
9996 does_use_field/2,
9997 uses_field/2.
9999 :- chr_option(mode,uses_field(+,+)).
10000 :- chr_option(mode,does_use_field(+,+)).
10002 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
10003 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
10004 uses_field(_FA,_Field) <=> fail.
10006 :- chr_constraint
10007 uses_state/2,
10008 if_used_state/5,
10009 used_states_known/0.
10011 :- chr_option(mode,uses_state(+,+)).
10012 :- chr_option(mode,if_used_state(+,+,?,?,?)).
10015 % states ::= not_stored_yet | passive | active | triggered | removed
10016 %
10017 % allocate CREATES not_stored_yet
10018 % remove CHECKS not_stored_yet
10019 % activate CHECKS not_stored_yet
10020 %
10021 % ==> no allocate THEN no not_stored_yet
10023 % recurs CREATES inactive
10024 % lookup CHECKS inactive
10026 % insert CREATES active
10027 % activate CREATES active
10028 % lookup CHECKS active
10029 % recurs CHECKS active
10031 % runsusp CREATES triggered
10032 % lookup CHECKS triggered
10033 %
10034 % ==> no runsusp THEN no triggered
10036 % remove CREATES removed
10037 % runsusp CHECKS removed
10038 % lookup CHECKS removed
10039 % recurs CHECKS removed
10040 %
10041 % ==> no remove THEN no removed
10043 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
10045 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
10047 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10048 <=> ResultGoal = Used.
10049 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10050 <=> ResultGoal = NotUsed.
10052 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10053 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
10054 % (Feature for SSS)
10055 %
10056 % 1. Checking
10057 % ~~~~~~~~~~~
10058 %
10059 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10060 %
10061 % :- chr_option(declare_stored_constraints,on).
10062 %
10063 % the compiler will check for the storedness of constraints.
10064 %
10065 % By default, the compiler assumes that the programmer wants his constraints to
10066 % be never-stored. Hence, a warning will be issues when a constraint is actually
10067 % stored.
10068 %
10069 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
10070 % to a constraint declaration, i.e. writes
10071 %
10072 % :- chr_constraint c(...) # stored.
10073 %
10074 % In that case a warning is issued when the constraint is never-stored.
10075 %
10076 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
10077 % constraints are stored anyway.
10078 %
10079 %
10080 % 2. Rule Generation
10081 % ~~~~~~~~~~~~~~~~~~
10082 %
10083 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10084 %
10085 % :- chr_option(declare_stored_constraints,on).
10086 %
10087 % the compiler will generate default simplification rules for constraints.
10088 %
10089 % By default, no default rule is generated for a constraint. However, if the
10090 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
10091 %
10092 % :- chr_constraint c(...) # default(Goal).
10093 %
10094 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
10095 % the compiler generates a rule:
10096 %
10097 % c(_,...,_) <=> Goal.
10098 %
10099 % at the end of the program. If multiple default rules are generated, for several constraints,
10100 % then the order of the default rules is not specified.
10103 :- chr_constraint stored_assertion/1.
10104 :- chr_option(mode,stored_assertion(+)).
10105 :- chr_option(type_declaration,stored_assertion(constraint)).
10107 :- chr_constraint never_stored_default/2.
10108 :- chr_option(mode,never_stored_default(+,?)).
10109 :- chr_option(type_declaration,never_stored_default(constraint,any)).
10111 % Rule Generation
10112 % ~~~~~~~~~~~~~~~
10114 generate_never_stored_rules(Constraints,Rules) :-
10115 ( chr_pp_flag(declare_stored_constraints,on) ->
10116 never_stored_rules(Constraints,Rules)
10117 ;
10118 Rules = []
10119 ).
10121 :- chr_constraint never_stored_rules/2.
10122 :- chr_option(mode,never_stored_rules(+,?)).
10123 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
10125 never_stored_rules([],Rules) <=> Rules = [].
10126 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
10127 Constraint = F/A,
10128 functor(Head,F,A),
10129 inc_rule_count(RuleNb),
10130 Rule = pragma(
10131 rule([Head],[],true,Goal),
10132 ids([0],[]),
10133 [],
10134 no,
10135 RuleNb
10136 ),
10137 Rules = [Rule|Tail],
10138 never_stored_rules(Constraints,Tail).
10139 never_stored_rules([_|Constraints],Rules) <=>
10140 never_stored_rules(Constraints,Rules).
10142 % Checking
10143 % ~~~~~~~~
10145 check_storedness_assertions(Constraints) :-
10146 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
10147 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
10148 ;
10149 true
10150 ).
10153 :- chr_constraint check_storedness_assertion/1.
10154 :- chr_option(mode,check_storedness_assertion(+)).
10155 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
10157 check_storedness_assertion(Constraint), stored_assertion(Constraint)
10158 <=> ( is_stored(Constraint) ->
10159 true
10160 ;
10161 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
10162 ).
10163 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
10164 <=> ( is_finally_stored(Constraint) ->
10165 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10166 ; is_stored(Constraint) ->
10167 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10168 ;
10169 true
10170 ).
10171 % never-stored, no default goal
10172 check_storedness_assertion(Constraint)
10173 <=> ( is_finally_stored(Constraint) ->
10174 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10175 ; is_stored(Constraint) ->
10176 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10177 ;
10178 true
10179 ).
10181 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
10182 % success continuation analysis
10184 % TODO
10185 % also use for forward jumping improvement!
10186 % use Prolog indexing for generated code
10187 %
10188 % EXPORTED
10189 %
10190 % should_skip_to_next_id(C,O)
10191 %
10192 % get_occurrence_code_id(C,O,Id)
10193 %
10194 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
10196 continuation_analysis(ConstraintSymbols) :-
10197 maplist(analyse_continuations,ConstraintSymbols).
10199 analyse_continuations(C) :-
10200 % 1. compute success continuations of the
10201 % occurrences of constraint C
10202 continuation_analysis(C,1),
10203 % 2. determine for which occurrences
10204 % to skip to next code id
10205 get_max_occurrence(C,MO),
10206 LO is MO + 1,
10207 bulk_propagation(C,1,LO),
10208 % 3. determine code id for each occurrence
10209 set_occurrence_code_id(C,1,0).
10211 % 1. Compute the success continuations of constrait C
10212 %-------------------------------------------------------------------------------
10214 continuation_analysis(C,O) :-
10215 get_max_occurrence(C,MO),
10216 ( O > MO ->
10217 true
10218 ; O == MO ->
10219 NextO is O + 1,
10220 continuation_occurrence(C,O,NextO)
10221 ;
10222 constraint_continuation(C,O,MO,NextO),
10223 continuation_occurrence(C,O,NextO),
10224 NO is O + 1,
10225 continuation_analysis(C,NO)
10226 ).
10228 constraint_continuation(C,O,MO,NextO) :-
10229 ( get_occurrence_head(C,O,Head) ->
10230 NO is O + 1,
10231 ( between(NO,MO,NextO),
10232 get_occurrence_head(C,NextO,NextHead),
10233 unifiable(Head,NextHead,_) ->
10234 true
10235 ;
10236 NextO is MO + 1
10237 )
10238 ; % current occurrence is passive
10239 NextO = MO
10240 ).
10242 get_occurrence_head(C,O,Head) :-
10243 get_occurrence(C,O,RuleNb,Id),
10244 \+ is_passive(RuleNb,Id),
10245 get_rule(RuleNb,Rule),
10246 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10247 ( select2(Id,Head,Ids1,H1,_,_) -> true
10248 ; select2(Id,Head,Ids2,H2,_,_)
10249 ).
10251 :- chr_constraint continuation_occurrence/3.
10252 :- chr_option(mode,continuation_occurrence(+,+,+)).
10254 :- chr_constraint get_success_continuation_occurrence/3.
10255 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10257 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10258 <=>
10259 X = NO.
10261 get_success_continuation_occurrence(C,O,X)
10262 <=>
10263 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10265 % 2. figure out when to skip to next code id
10266 %-------------------------------------------------------------------------------
10267 % don't go beyond the last occurrence
10268 % we have to go to next id for storage here
10270 :- chr_constraint skip_to_next_id/2.
10271 :- chr_option(mode,skip_to_next_id(+,+)).
10273 :- chr_constraint should_skip_to_next_id/2.
10274 :- chr_option(mode,should_skip_to_next_id(+,+)).
10276 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10277 <=>
10278 true.
10280 should_skip_to_next_id(_,_)
10281 <=>
10282 fail.
10284 :- chr_constraint bulk_propagation/3.
10285 :- chr_option(mode,bulk_propagation(+,+,+)).
10287 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10288 <=>
10289 O >= MO
10290 |
10291 skip_to_next_id(C,O).
10292 % we have to go to the next id here because
10293 % a predecessor needs it
10294 bulk_propagation(C,O,LO)
10295 <=>
10296 LO =:= O + 1
10297 |
10298 skip_to_next_id(C,O),
10299 get_max_occurrence(C,MO),
10300 NLO is MO + 1,
10301 bulk_propagation(C,LO,NLO).
10302 % we have to go to the next id here because
10303 % we're running into a simplification rule
10304 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10305 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10306 <=>
10307 NO =:= O + 1
10308 |
10309 skip_to_next_id(C,O),
10310 get_max_occurrence(C,MO),
10311 NLO is MO + 1,
10312 bulk_propagation(C,NO,NLO).
10313 % we skip the next id here
10314 % and go to the next occurrence
10315 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10316 <=>
10317 NextO > O + 1
10318 |
10319 NLO is min(LO,NextO),
10320 NO is O + 1,
10321 bulk_propagation(C,NO,NLO).
10322 % default case
10323 % err on the safe side
10324 bulk_propagation(C,O,LO)
10325 <=>
10326 skip_to_next_id(C,O),
10327 get_max_occurrence(C,MO),
10328 NLO is MO + 1,
10329 NO is O + 1,
10330 bulk_propagation(C,NO,NLO).
10332 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10334 % if this occurrence is passive, but has to skip,
10335 % then the previous one must skip instead...
10336 % IMPROVE reasoning is conservative
10337 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10338 ==>
10339 O > 1
10340 |
10341 PO is O - 1,
10342 skip_to_next_id(C,PO).
10344 % 3. determine code id of each occurrence
10345 %-------------------------------------------------------------------------------
10347 :- chr_constraint set_occurrence_code_id/3.
10348 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10350 :- chr_constraint occurrence_code_id/3.
10351 :- chr_option(mode,occurrence_code_id(+,+,+)).
10353 % stop at the end
10354 set_occurrence_code_id(C,O,IdNb)
10355 <=>
10356 get_max_occurrence(C,MO),
10357 O > MO
10358 |
10359 occurrence_code_id(C,O,IdNb).
10361 % passive occurrences don't change the code id
10362 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10363 <=>
10364 occurrence_code_id(C,O,IdNb),
10365 NO is O + 1,
10366 set_occurrence_code_id(C,NO,IdNb).
10368 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10369 <=>
10370 occurrence_code_id(C,O,IdNb),
10371 NO is O + 1,
10372 set_occurrence_code_id(C,NO,IdNb).
10374 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10375 <=>
10376 occurrence_code_id(C,O,IdNb),
10377 NO is O + 1,
10378 NIdNb is IdNb + 1,
10379 set_occurrence_code_id(C,NO,NIdNb).
10381 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10382 <=>
10383 occurrence_code_id(C,O,IdNb),
10384 NO is O + 1,
10385 set_occurrence_code_id(C,NO,IdNb).
10387 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10389 :- chr_constraint get_occurrence_code_id/3.
10390 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10392 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10393 <=>
10394 X = IdNb.
10396 get_occurrence_code_id(C,O,X)
10397 <=>
10398 ( O == 0 ->
10399 true % X = 0
10400 ;
10401 format('no occurrence code for ~w!\n',[C:O])
10402 ).
10404 get_success_continuation_code_id(C,O,NextId) :-
10405 get_success_continuation_occurrence(C,O,NextO),
10406 get_occurrence_code_id(C,NextO,NextId).
10408 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10409 % COLLECT CONSTANTS FOR INLINING
10410 %
10411 % for SSS
10413 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10415 % collect_constants(+rules,+ast_rules,+constraint_symbols,+clauses) {{{
10416 collect_constants(Rules,AstRules,Constraints,Clauses0) :-
10417 ( not_restarted, chr_pp_flag(experiment,on) ->
10418 ( chr_pp_flag(sss,on) ->
10419 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10420 copy_term_nat(Clauses0,Clauses),
10421 flatten_clauses(Clauses,Dictionary,FlatClauses),
10422 install_new_declarations_and_restart(FlatClauses)
10423 ;
10424 maplist(collect_rule_constants(Constraints),AstRules),
10425 ( chr_pp_flag(verbose,on) ->
10426 print_chr_constants
10427 ;
10428 true
10429 ),
10430 ( chr_pp_flag(experiment,on) ->
10431 flattening_dictionary(Constraints,Dictionary),
10432 copy_term_nat(Clauses0,Clauses),
10433 flatten_clauses(Clauses,Dictionary,FlatClauses),
10434 install_new_declarations_and_restart(FlatClauses)
10435 ;
10436 true
10437 )
10438 )
10439 ;
10440 true
10441 ).
10443 :- chr_constraint chr_constants/1.
10444 :- chr_option(mode,chr_constants(+)).
10446 :- chr_constraint get_chr_constants/1.
10448 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10450 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10452 % collect_rule_constants(+constraint_symbols,+ast_rule) {{{
10453 collect_rule_constants(Constraints,AstRule) :-
10454 AstRule = ast_rule(AstHead,_,_,AstBody,_),
10455 collect_head_constants(AstHead),
10456 collect_body_constants(AstBody,Constraints).
10458 collect_head_constants(simplification(H1)) :-
10459 maplist(collect_constraint_constants,H1).
10460 collect_head_constants(propagation(H2)) :-
10461 maplist(collect_constraint_constants,H2).
10462 collect_head_constants(simpagation(H1,H2)) :-
10463 maplist(collect_constraint_constants,H1),
10464 maplist(collect_constraint_constants,H2).
10466 collect_body_constants(AstBody,Constraints) :-
10467 maplist(collect_goal_constants(Constraints),AstBody).
10469 collect_goal_constants(Constraints,Goal) :-
10470 ( ast_nonvar(Goal) ->
10471 ast_symbol(Goal,Symbol),
10472 ( memberchk(Symbol,Constraints) ->
10473 ast_term_to_term(Goal,Term),
10474 ast_args(Goal,Arguments),
10475 collect_constraint_constants(chr_constraint(Symbol,Arguments,Term))
10476 ; Symbol == (:)/2,
10477 ast_args(Goal,[Arg1,Goal2]),
10478 Arg1 = atomic(Mod),
10479 get_target_module(Module),
10480 Mod == Module,
10481 ast_nonvar(Goal2),
10482 ast_symbol(Goal2,Symbol2),
10483 memberchk(Symbol2,Constraints) ->
10484 ast_term_to_term(Goal2,Term2),
10485 ast_args(Goal2,Arguments2),
10486 collect_constraint_constants(chr_constraint(Symbol2,Arguments2,Term2))
10487 ;
10488 true
10489 )
10490 ;
10491 true
10492 ).
10494 collect_constraint_constants(Head) :-
10495 Head = chr_constraint(Symbol,Arguments,_),
10496 get_constraint_type_det(Symbol,Types),
10497 collect_all_arg_constants(Arguments,Types,[]).
10499 collect_all_arg_constants([],[],Constants) :-
10500 ( Constants \== [] ->
10501 add_chr_constants(Constants)
10502 ;
10503 true
10504 ).
10505 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10506 unalias_type(Type,NormalizedType),
10507 ( is_chr_constants_type(NormalizedType,Key,_) ->
10508 ( ast_ground(Arg) ->
10509 ast_term_to_term(Arg,Term),
10510 collect_all_arg_constants(Args,Types,[Key-Term|Constants0])
10511 ; % no useful information here
10512 true
10513 )
10514 ;
10515 collect_all_arg_constants(Args,Types,Constants0)
10516 ).
10518 add_chr_constants(Pairs) :-
10519 keysort(Pairs,SortedPairs),
10520 add_chr_constants_(SortedPairs).
10522 :- chr_constraint add_chr_constants_/1.
10523 :- chr_option(mode,add_chr_constants_(+)).
10525 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10526 sort([Constants|MoreConstants],NConstants),
10527 chr_constants(NConstants).
10529 add_chr_constants_(Constants) <=>
10530 chr_constants([Constants]).
10532 % }}}
10534 :- chr_constraint print_chr_constants/0. % {{{
10536 print_chr_constants, chr_constants(Constants) # Id ==>
10537 format('\t* chr_constants : ~w.\n',[Constants])
10538 pragma passive(Id).
10540 print_chr_constants <=>
10541 true.
10543 % }}}
10545 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10546 flattening_dictionary([],[]).
10547 flattening_dictionary([CS|CSs],Dictionary) :-
10548 ( flattening_dictionary_entry(CS,Entry) ->
10549 Dictionary = [Entry|Rest]
10550 ;
10551 Dictionary = Rest
10552 ),
10553 flattening_dictionary(CSs,Rest).
10555 flattening_dictionary_entry(CS,Entry) :-
10556 get_constraint_type_det(CS,Types),
10557 constant_positions(Types,1,Positions,Keys,Handler,MaybeEnum),
10558 ( Positions \== [] -> % there are chr_constant arguments
10559 pairup(Keys,Constants,Pairs0),
10560 keysort(Pairs0,Pairs),
10561 Entry = CS-Positions-Specs-Handler,
10562 get_chr_constants(ConstantsList),
10563 findall(Spec,
10564 ( member(Pairs,ConstantsList)
10565 , flat_spec(CS,Positions,Constants,Spec)
10566 ),
10567 Specs)
10568 ; MaybeEnum == yes ->
10569 enum_positions(Types,1,EnumPositions,ConstantsLists,EnumHandler),
10570 Entry = CS-EnumPositions-Specs-EnumHandler,
10571 findall(Spec,
10572 ( cartesian_product(Terms,ConstantsLists)
10573 , flat_spec(CS,EnumPositions,Terms,Spec)
10574 ),
10575 Specs)
10576 ).
10578 constant_positions([],_,[],[],no,no).
10579 constant_positions([Type|Types],I,Positions,Keys,Handler,MaybeEnum) :-
10580 unalias_type(Type,NormalizedType),
10581 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10582 compose_error_handlers(ErrorHandler,NHandler,Handler),
10583 Positions = [I|NPositions],
10584 Keys = [Key|NKeys],
10585 MaybeEnum = NMaybeEnum
10586 ;
10587 ( is_chr_enum_type(NormalizedType,_,_) ->
10588 MaybeEnum = yes
10589 ;
10590 MaybeEnum = NMaybeEnum
10591 ),
10592 NPositions = Positions,
10593 NKeys = Keys,
10594 NHandler = Handler
10595 ),
10596 J is I + 1,
10597 constant_positions(Types,J,NPositions,NKeys,NHandler,NMaybeEnum).
10599 compose_error_handlers(no,Handler,Handler).
10600 compose_error_handlers(yes(Handler),_,yes(Handler)).
10602 enum_positions([],_,[],[],no).
10603 enum_positions([Type|Types],I,Positions,ConstantsLists,Handler) :-
10604 unalias_type(Type,NormalizedType),
10605 ( is_chr_enum_type(NormalizedType,Constants,ErrorHandler) ->
10606 compose_error_handlers(ErrorHandler,NHandler,Handler),
10607 Positions = [I|NPositions],
10608 ConstantsLists = [Constants|NConstantsLists]
10609 ; Positions = NPositions,
10610 ConstantsLists = NConstantsLists,
10611 Handler = NHandler
10612 ),
10613 J is I + 1,
10614 enum_positions(Types,J,NPositions,NConstantsLists,NHandler).
10616 cartesian_product([],[]).
10617 cartesian_product([E|Es],[L|Ls]) :-
10618 member(E,L),
10619 cartesian_product(Es,Ls).
10621 flat_spec(C/N,Positions,Terms,Spec) :-
10622 Spec = Terms - Functor,
10623 term_to_atom(Terms,TermsAtom),
10624 term_to_atom(Positions,PositionsAtom),
10625 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10627 % }}}
10629 % }}}
10630 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10631 % RESTART AFTER FLATTENING {{{
10633 restart_after_flattening(Declarations,Declarations) :-
10634 nb_setval('$chr_restart_after_flattening',started).
10635 restart_after_flattening(_,Declarations) :-
10636 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10637 nb_setval('$chr_restart_after_flattening',restarted).
10639 not_restarted :-
10640 nb_getval('$chr_restart_after_flattening',started).
10642 install_new_declarations_and_restart(Declarations) :-
10643 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10644 fail. /* fails to choicepoint of restart_after_flattening */
10645 % }}}
10646 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10647 % FLATTENING {{{
10649 % DONE
10650 % -) generate dictionary from collected chr_constants
10651 % enable with :- chr_option(experiment,on).
10652 % -) issue constraint declarations for constraints not present in
10653 % dictionary
10654 % -) integrate with CHR compiler
10655 % -) pass Mike's test code (full syntactic support for current CHR code)
10656 % -) rewrite the body using the inliner
10657 %
10658 % TODO:
10659 % -) refined semantics correctness issue
10660 % -) incorporate chr_enum into dictionary generation
10661 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10663 flatten_clauses(Clauses,Dict,NClauses) :-
10664 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10665 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10667 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10668 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10669 dispatching_rules(Dict,NClauses1),
10670 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10671 flatten_rules(Clauses,Dict,NClauses3),
10672 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10674 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10675 % Declarations for non-flattened constraints
10677 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10678 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10679 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10680 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10681 flatten(DeclarationsList,Declarations).
10683 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10684 [(:- chr_constraint ConstraintSymbol),
10685 (:- chr_option(mode,ModeDeclPattern)),
10686 (:- chr_option(type_declaration,TypeDeclPattern))
10687 ]) :-
10688 ConstraintSymbol = Functor / Arity,
10689 % print optional mode declaration
10690 functor(ModeDeclPattern,Functor,Arity),
10691 ( memberchk(ModeDeclPattern,ModeDecls) ->
10692 true
10693 ;
10694 replicate(Arity,(?),Modes),
10695 ModeDeclPattern =.. [_|Modes]
10696 ),
10697 % print optional type declaration
10698 functor(TypeDeclPattern,Functor,Arity),
10699 ( memberchk(TypeDeclPattern,TypeDecls) ->
10700 true
10701 ;
10702 replicate(Arity,any,Types),
10703 TypeDeclPattern =.. [_|Types]
10704 ).
10705 % }}}
10706 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10707 % read clauses from file
10708 % CHR are returned
10709 % declared constaints are returned
10710 % type definitions are returned and printed
10711 % mode declarations are returned
10712 % other clauses are returned
10714 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10715 flatten_readcontent([],[],[],[],[],[],[]).
10716 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10717 % read(Clause),
10718 ( Clause == end_of_file ->
10719 Rules = [],
10720 ConstraintSymbols = [],
10721 ModeDecls = [],
10722 TypeDecls = [],
10723 TypeDefs = [],
10724 RestClauses = []
10725 ; crude_is_rule(Clause) ->
10726 Rules = [Clause|RestRules],
10727 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10728 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10729 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10730 append(SomeModeDecls,RestModeDecls,ModeDecls),
10731 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10732 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10733 ; is_mode_declaration(Clause,ModeDecl) ->
10734 ModeDecls = [ModeDecl|RestModeDecls],
10735 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10736 ; is_type_declaration(Clause,TypeDecl) ->
10737 TypeDecls = [TypeDecl|RestTypeDecls],
10738 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10739 ; is_type_definition(Clause,TypeDef) ->
10740 RestClauses = [Clause|NRestClauses],
10741 TypeDefs = [TypeDef|RestTypeDefs],
10742 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10743 ; ( Clause = (:- op(A,B,C)) ->
10744 % assert operators in order to read and print them out properly
10745 op(A,B,C)
10746 ;
10747 true
10748 ),
10749 RestClauses = [Clause|NRestClauses],
10750 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10751 ).
10753 crude_is_rule(_ @ _).
10754 crude_is_rule(_ pragma _).
10755 crude_is_rule(_ ==> _).
10756 crude_is_rule(_ <=> _).
10758 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10759 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10760 conj2list(Cs,Constraints0),
10761 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10763 pure_extract_type_mode([],[],[],[]).
10764 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10765 pure_extract_type_mode(R,R2,Modes,Types).
10766 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10767 functor(C,F,A),
10768 ConstraintSymbol = F/A,
10769 C =.. [_|Args],
10770 extract_types_and_modes(Args,ArgTypes,ArgModes),
10771 Mode =.. [F|ArgModes],
10772 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10773 Types = RTypes
10774 ;
10775 Types = [Type|RTypes],
10776 Type =.. [F|ArgTypes]
10777 ),
10778 pure_extract_type_mode(R,R2,Modes,RTypes).
10780 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10782 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10783 % }}}
10784 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10785 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10786 % including mode and type declarations
10788 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10789 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10790 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10791 flatten(ConstraintSpecs0,ConstraintSpecs).
10793 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10794 [(:- chr_constraint ConstraintSpec),
10795 (:- chr_option(mode,NewModeDecl)),
10796 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10797 member(C/N-I-SFs-_,Dict),
10798 arg_modes(C,N,ModeDecls,Modes),
10799 specialize_modes(Modes,I,SpecializedModes),
10800 arg_types(C,N,TypeDecls,Types),
10801 specialize_types(Types,I,SpecializedTypes),
10802 length(I,IndexSize),
10803 AN is N - IndexSize,
10804 member(_Term-F,SFs),
10805 ConstraintSpec = F/AN,
10806 NewModeDecl =.. [F|SpecializedModes],
10807 NewTypeDecl =.. [F|SpecializedTypes].
10809 arg_modes(C,N,ModeDecls,ArgModes) :-
10810 functor(ConstraintPattern,C,N),
10811 ( memberchk(ConstraintPattern,ModeDecls) ->
10812 ConstraintPattern =.. [_|ArgModes]
10813 ;
10814 replicate(N,?,ArgModes)
10815 ).
10817 specialize_modes(Modes,I,SpecializedModes) :-
10818 split_args(I,Modes,_,SpecializedModes).
10820 arg_types(C,N,TypeDecls,ArgTypes) :-
10821 functor(ConstraintPattern,C,N),
10822 ( memberchk(ConstraintPattern,TypeDecls) ->
10823 ConstraintPattern =.. [_|ArgTypes]
10824 ;
10825 replicate(N,any,ArgTypes)
10826 ).
10828 specialize_types(Types,I,SpecializedTypes) :-
10829 split_args(I,Types,_,SpecializedTypes).
10830 % }}}
10831 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10832 % DISPATCHING RULES
10833 %
10834 % dispatching_rules(+dict,-newrules)
10837 % {{{
10839 % This code generates a decision tree for calling the appropriate specialized
10840 % constraint based on the particular value of the argument the constraint
10841 % is being specialized on.
10842 %
10843 % In case an error handler is provided, the handler is called with the
10844 % unexpected constraint.
10846 dispatching_rules([],[]).
10847 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10848 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10849 dispatching_rules(Dict,RestDispatchingRules).
10851 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10852 ( increasing_numbers(I,1) ->
10853 /* index on first arguments */
10854 Rules0 = Rules,
10855 NCN = C/N
10856 ;
10857 /* reorder arguments for 1st argument indexing */
10858 functor(Head,C,N),
10859 Head =.. [_|Args],
10860 split_args(I,Args,GroundArgs,OtherArgs),
10861 append(GroundArgs,OtherArgs,ShuffledArgs),
10862 atom_concat(C,'_$shuffled',NC),
10863 Body =.. [NC|ShuffledArgs],
10864 [(Head :- Body)|Rules0] = Rules,
10865 NCN = NC / N
10866 ),
10867 Context = swap(C,I),
10868 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10870 increasing_numbers([],_).
10871 increasing_numbers([X|Ys],X) :-
10872 Y is X + 1,
10873 increasing_numbers(Ys,Y).
10875 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10876 length(I,IndexLength),
10877 once(pairup(TermLists,Functors,SFs)),
10878 maplist(head_tail,TermLists,Heads,Tails),
10879 Payload is N - IndexLength,
10880 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10881 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10883 dispatching_action(Functor,PayloadArgs,Goal) :-
10884 Goal =.. [Functor|PayloadArgs].
10886 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10887 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10889 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10890 % length MorePatterns == length Patterns == length Results
10891 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10892 MorePatterns = [List|_],
10893 length(List,N),
10894 aggregate_all(set(F/A),
10895 ( member(Pattern,Patterns),
10896 functor(Pattern,F,A)
10897 ),
10898 FAs),
10899 N1 is N + 1,
10900 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10902 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10903 ( MaybeErrorHandler = yes(ErrorHandler) ->
10904 Clauses0 = [ErrorClause|Clauses],
10905 ErrorClause = (Head :- Body),
10906 Arity is N + Payload,
10907 functor(Head,Symbol,Arity),
10908 reconstruct_original_term(Context,Head,Term),
10909 Body =.. [ErrorHandler,Term]
10910 ;
10911 Clauses0 = Clauses
10912 ).
10913 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10914 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10915 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10917 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10918 Clause = (Head :- Cut, Body),
10919 ( MaybeErrorHandler = yes(_) ->
10920 Cut = (!)
10921 ;
10922 Cut = true
10923 ),
10924 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10925 N1 is N + Payload,
10926 functor(Head,Symbol,N1),
10927 arg(1,Head,IndexPattern),
10928 Head =.. [_,_|RestArgs],
10929 length(PayloadArgs,Payload),
10930 once(append(Vs,PayloadArgs,RestArgs)),
10931 /* IndexPattern = F(...) */
10932 functor(IndexPattern,F,A),
10933 Context1 = index_functor(F,A,Context0),
10934 IndexPattern =.. [_|Args],
10935 append(Args,RestArgs,RecArgs),
10936 ( RecArgs == PayloadArgs ->
10937 /* nothing more to match on */
10938 List = Tail,
10939 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10940 MoreActions = [Action],
10941 call(Action,PayloadArgs,Body)
10942 ; /* more things to match on */
10943 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10944 ( MoreActions = [OneMoreAction] ->
10945 /* only one more thing to match on */
10946 MoreCases = [OneMoreCase],
10947 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10948 List = Tail,
10949 call(OneMoreAction,PayloadArgs,Body)
10950 ;
10951 /* more than one thing to match on */
10952 /* [ x1,..., xn]
10953 [xs1,...,xsn]
10954 */
10955 pairup(Cases,MoreCases,CasePairs),
10956 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10957 append(Args,Vs,[First|Rest]),
10958 First-Rest = CommonPatternPair,
10959 Context2 = gct([First|Rest],Context1),
10960 gensym(Prefix,RSymbol),
10961 append(DiffVars,PayloadArgs,RecCallVars),
10962 Body =.. [RSymbol|RecCallVars],
10963 findall(CH-CT,member([CH|CT],Differences),CPairs),
10964 once(pairup(CHs,CTs,CPairs)),
10965 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10966 )
10967 ).
10970 % split(list,int,before,at,after).
10972 split([X|Xs],I,Before,At,After) :-
10973 ( I == 1 ->
10974 Before = [],
10975 At = X,
10976 After = Xs
10977 ;
10978 J is I - 1,
10979 Before = [X|RBefore],
10980 split(Xs,J,RBefore,At,After)
10981 ).
10983 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10984 %
10985 % context ::= swap(functor,positions)
10986 % | index_functor(functor,arity,context)
10987 % | gct(Pattern,Context)
10989 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10990 functor(Term,_,Arity),
10991 functor(OriginalTerm,Functor,Arity),
10992 OriginalTerm =.. [_|OriginalArgs],
10993 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10994 Term =.. [_|Args],
10995 append(IndexArgs,OtherArgs,Args).
10996 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10997 Term0 =.. [Predicate|Args],
10998 split_at(Arity,Args,IndexArgs,RestArgs),
10999 Index =.. [Functor|IndexArgs],
11000 Term1 =.. [Predicate,Index|RestArgs],
11001 reconstruct_original_term(Context,Term1,OriginalTerm).
11002 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
11003 copy_term_nat(PatternList,IndexTerms),
11004 term_variables(IndexTerms,Variables),
11005 Term0 =.. [Predicate|Args0],
11006 append(Variables,RestArgs,Args0),
11007 append(IndexTerms,RestArgs,Args1),
11008 Term1 =.. [Predicate|Args1],
11009 reconstruct_original_term(Context,Term1,OriginalTerm).
11010 % }}}
11012 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
11013 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
11014 %
11015 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
11016 %
11017 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
11019 % {{{
11020 flatten_rules(Rules,Dict,FlatRules) :-
11021 flatten_rules1(Rules,Dict,FlatRulesList),
11022 flatten(FlatRulesList,FlatRules).
11024 flatten_rules1([],_,[]).
11025 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
11026 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
11027 flatten_rules1(Rules,Dict,FlatRulesList).
11029 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
11030 flatten_rule(Rule,Dict,NRule).
11031 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
11032 flatten_rule(Rule,Dict,NRule).
11033 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
11034 flatten_heads(H,Dict,NH),
11035 flatten_body(B,Dict,NB).
11036 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
11037 flatten_heads((H1,H2),Dict,(NH1,NH2)),
11038 flatten_body(B,Dict,NB).
11039 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
11040 flatten_heads(H,Dict,NH),
11041 flatten_body(B,Dict,NB).
11043 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
11044 flatten_heads(H1,Dict,NH1),
11045 flatten_heads(H2,Dict,NH2).
11046 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
11047 flatten_heads(H,Dict,NH).
11048 flatten_heads(H,Dict,NH) :-
11049 ( functor(H,C,N),
11050 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
11051 H =.. [_|AllArgs],
11052 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
11053 member(GroundArgs-Name,SFs),
11054 NH =.. [Name|OtherArgs]
11055 ;
11056 NH = H
11057 ).
11059 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
11060 conj2list(Guard,Guards),
11061 maplist(flatten_goal(Dict),Guards,NGuards),
11062 list2conj(NGuards,NGuard),
11063 conj2list(Body,Goals),
11064 maplist(flatten_goal(Dict),Goals,NGoals),
11065 list2conj(NGoals,NBody).
11066 flatten_body(Body,Dict,NBody) :-
11067 conj2list(Body,Goals),
11068 maplist(flatten_goal(Dict),Goals,NGoals),
11069 list2conj(NGoals,NBody).
11071 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
11072 flatten_goal(Dict,Goal,NGoal) :-
11073 ( is_specializable_goal(Goal,Dict,ArgPositions)
11074 ->
11075 specialize_goal(Goal,ArgPositions,NGoal)
11076 ; Goal = Mod : TheGoal,
11077 get_target_module(Module),
11078 Mod == Module,
11079 nonvar(TheGoal),
11080 is_specializable_goal(TheGoal,Dict,ArgPositions)
11081 ->
11082 specialize_goal(TheGoal,ArgPositions,NTheGoal),
11083 NGoal = Mod : NTheGoal
11084 ; partial_eval(Goal,NGoal)
11085 ->
11086 true
11087 ;
11088 NGoal = Goal
11089 ).
11091 %-------------------------------------------------------------------------------%
11092 % Specialize body/guard goal
11093 %-------------------------------------------------------------------------------%
11094 is_specializable_goal(Goal,Dict,ArgPositions) :-
11095 functor(Goal,C,N),
11096 memberchk(C/N-ArgPositions-_-_,Dict),
11097 args(ArgPositions,Goal,Args),
11098 ground(Args).
11100 specialize_goal(Goal,ArgPositions,NGoal) :-
11101 functor(Goal,C,N),
11102 Goal =.. [_|Args],
11103 split_args(ArgPositions,Args,GroundTerms,Others),
11104 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
11105 NGoal =.. [Functor|Others].
11107 %-------------------------------------------------------------------------------%
11108 % Partially evaluate predicates
11109 %-------------------------------------------------------------------------------%
11111 % append([],Y,Z) >--> Y = Z
11112 % append(X,[],Z) >--> X = Z
11113 partial_eval(append(L1,L2,L3),NGoal) :-
11114 ( L1 == [] ->
11115 NGoal = (L3 = L2)
11116 ; L2 == [] ->
11117 NGoal = (L3 = L1)
11119 ).
11120 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
11121 % where flatten(L1,L1')
11122 partial_eval(flatten_path(L1,L2),NGoal) :-
11123 nonvar(L1),
11124 flatten(L1,FlatterL1),
11125 FlatterL1 \== L1 ->
11126 NGoal = flatten_path(FlatterL1,L2).
11129 % }}}
11131 % }}}
11132 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11133 dump_code(Clauses) :-
11134 ( chr_pp_flag(dump,on) ->
11135 maplist(portray_clause,Clauses)
11136 ;
11137 true
11138 ).
11140 chr_banner :-
11141 chr_info(banner,'\tThe K.U.Leuven CHR System\n\t\tMain Developer:\tTom Schrijvers\n\t\tContributors:\tJon Sneyers, Bart Demoen, Jan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]).
11143 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11144 % LOCKING {{{
11146 chr_none_locked(Vars,Goal) :-
11147 chr_pp_flag(guard_locks,Flag),
11148 ( Flag == off ->
11149 Goal = true
11150 ; Flag == on ->
11151 Goal = 'chr none_locked'( Vars)
11152 ; Flag == error ->
11153 Goal = 'chr none_error_locked'( Vars)
11154 ).
11156 chr_not_locked(Var,Goal) :-
11157 chr_pp_flag(guard_locks,Flag),
11158 ( Flag == off ->
11159 Goal = true
11160 ; Flag == on ->
11161 Goal = 'chr not_locked'( Var)
11162 ; Flag == error ->
11163 Goal = 'chr not_error_locked'( Var)
11164 ).
11166 chr_lock(Var,Goal) :-
11167 chr_pp_flag(guard_locks,Flag),
11168 ( Flag == off ->
11169 Goal = true
11170 ; Flag == on ->
11171 Goal = 'chr lock'( Var)
11172 ; Flag == error ->
11173 Goal = 'chr error_lock'( Var)
11174 ).
11176 chr_unlock(Var,Goal) :-
11177 chr_pp_flag(guard_locks,Flag),
11178 ( Flag == off ->
11179 Goal = true
11180 ; Flag == on ->
11181 Goal = 'chr unlock'( Var)
11182 ; Flag == error ->
11183 Goal = 'chr unerror_lock'( Var)
11184 ).
11185 % }}}
11186 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11187 % AST representation
11188 % each AST representation caches the original term
11189 %
11190 % ast_term ::= atomic(Term)
11191 % | compound(Functor,Arity,list(ast_term),Term)
11192 % | var(int,Term)
11193 % -- unique integer identifier
11195 % Conversion Predicate {{{
11196 :- chr_type var_id == natural.
11198 term_to_ast_term(Term,AstTerm,VarEnv,NVarEnv) :-
11199 ( atomic(Term) ->
11200 AstTerm = atomic(Term),
11201 NVarEnv = VarEnv
11202 ; compound(Term) ->
11203 functor(Term,Functor,Arity),
11204 AstTerm = compound(Functor,Arity,AstTerms,Term),
11205 Term =.. [_|Args],
11206 maplist_dcg(chr_translate:term_to_ast_term,Args,AstTerms,VarEnv,NVarEnv)
11207 ; var(Term) ->
11208 var_to_ast_term(Term,VarEnv,AstTerm,NVarEnv)
11209 ).
11211 var_to_ast_term(Var,Env,AstTerm,NVarEnv) :-
11212 Env = VarDict - VarId,
11213 ( lookup_eq(VarDict,Var,AstTerm) ->
11214 NVarEnv = Env
11215 ;
11216 AstTerm = var(VarId,Var),
11217 NVarId is VarId + 1,
11218 NVarDict = [Var - AstTerm|VarDict],
11219 NVarEnv = NVarDict - NVarId
11220 ).
11222 % ast_constraint ::= chr_constraint(Symbol,Arguments,Constraint)
11223 chr_constraint_to_ast_constraint(CHRConstraint,AstConstraint,VarEnv,NVarEnv) :-
11224 AstConstraint = chr_constraint(Functor/Arity,AstTerms,CHRConstraint),
11225 functor(CHRConstraint,Functor,Arity),
11226 CHRConstraint =.. [_|Arguments],
11227 maplist_dcg(chr_translate:term_to_ast_term,Arguments,AstTerms,VarEnv,NVarEnv).
11229 % ast_head ::= simplification(list(chr_constraint))
11230 % | propagation(list(chr_constraint))
11231 % | simpagation(list(chr_constraint),list(chr_constraint))
11233 % head_id ::= int
11235 % ast_guard ::= list(ast_term)
11236 % ast_body ::= list(ast_term)
11238 % ast_rule ::= ast_rule(ast_head,ast_guard,guard,ast_body,body)
11240 rule_to_ast_rule(Rule,AstRule) :-
11241 AstRule = ast_rule(Head,AstGuard,Guard,AstBody,Body),
11242 Rule = rule(H1,H2,Guard,Body),
11243 EmptyVarEnv = []-1,
11244 ( H1 == [] ->
11245 Head = propagation(AstConstraints),
11246 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,AstConstraints,EmptyVarEnv,VarEnv1)
11247 ; H2 == [] ->
11248 Head = simplification(AstConstraints),
11249 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,AstConstraints,EmptyVarEnv,VarEnv1)
11250 ;
11251 Head = simpagation(RemovedAstConstraints,KeptAstConstraints),
11252 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,RemovedAstConstraints,EmptyVarEnv,VarEnv0),
11253 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,KeptAstConstraints,VarEnv0,VarEnv1)
11254 ),
11255 conj2list(Guard,GuardList),
11256 maplist_dcg(chr_translate:term_to_ast_term,GuardList,AstGuard,VarEnv1,VarEnv2),
11257 conj2list(Body,BodyList),
11258 maplist_dcg(chr_translate:term_to_ast_term,BodyList,AstBody,VarEnv2,_).
11260 pragma_rule_to_ast_rule(pragma(Rule,_,_,_,_),AstRule) :-
11261 rule_to_ast_rule(Rule,AstRule).
11263 check_rule_to_ast_rule(Rule) :-
11264 ( rule_to_ast_rule(Rule,AstRule) ->
11265 writeln(AstRule)
11266 ;
11267 writeln(failed(rule_to_ast_rule(Rule,AstRule)))
11268 ).
11270 % }}}
11272 % AST Utility Predicates {{{
11273 ast_term_to_term(var(_,Var),Var).
11274 ast_term_to_term(atomic(Atom),Atom).
11275 ast_term_to_term(compound(_,_,_,Compound),Compound).
11277 ast_nonvar(atomic(_)).
11278 ast_nonvar(compound(_,_,_,_)).
11280 ast_ground(atomic(_)).
11281 ast_ground(compound(_,_,Arguments,_)) :-
11282 maplist(ast_ground,Arguments).
11284 %------------------------------------------------------------------------------%
11285 % Check whether a term is ground, given a set of variables that are ground.
11286 %------------------------------------------------------------------------------%
11287 ast_is_ground(VarSet,AstTerm) :-
11288 ast_is_ground_(AstTerm,VarSet).
11290 ast_is_ground_(var(VarId,_),VarSet) :-
11291 tree_set_memberchk(VarId,VarSet).
11292 ast_is_ground_(atomic(_),_).
11293 ast_is_ground_(compound(_,_,Arguments,_),VarSet) :-
11294 maplist(ast_is_ground(VarSet),Arguments).
11295 %------------------------------------------------------------------------------%
11297 ast_functor(atomic(Atom),Atom,0).
11298 ast_functor(compound(Functor,Arity,_,_),Functor,Arity).
11300 ast_symbol(atomic(Atom),Atom/0).
11301 ast_symbol(compound(Functor,Arity,_,_),Functor/Arity).
11303 ast_args(atomic(_),[]).
11304 ast_args(compound(_,_,Arguments,_),Arguments).
11306 %------------------------------------------------------------------------------%
11307 % Add variables in a term to a given set.
11308 %------------------------------------------------------------------------------%
11309 ast_term_variables(atomic(_),Set,Set).
11310 ast_term_variables(compound(_,_,Args,_),Set,NSet) :-
11311 ast_term_list_variables(Args,Set,NSet).
11312 ast_term_variables(var(VarId,_),Set,NSet) :-
11313 tree_set_add(Set,VarId,NSet).
11315 ast_term_list_variables(Terms,Set,NSet) :-
11316 fold(Terms,chr_translate:ast_term_variables,Set,NSet).
11317 %------------------------------------------------------------------------------%
11319 ast_constraint_variables(chr_constraint(_,Args,_),Set,NSet) :-
11320 ast_term_list_variables(Args,Set,NSet).
11322 ast_constraint_list_variables(Constraints,Set,NSet) :-
11323 fold(Constraints,chr_translate:ast_constraint_variables,Set,NSet).
11325 ast_head_variables(simplification(H1),Set,NSet) :-
11326 ast_constraint_list_variables(H1,Set,NSet).
11327 ast_head_variables(propagation(H2),Set,NSet) :-
11328 ast_constraint_list_variables(H2,Set,NSet).
11329 ast_head_variables(simpagation(H1,H2),Set,NSet) :-
11330 ast_constraint_list_variables(H1,Set,Set1),
11331 ast_constraint_list_variables(H2,Set1,NSet).
11333 ast_var_memberchk(var(VarId,_),Set) :-
11334 tree_set_memberchk(VarId,Set).
11336 %------------------------------------------------------------------------------%
11337 % Return term based on AST-term with variables mapped.
11338 %------------------------------------------------------------------------------%
11339 ast_instantiate(Map,AstTerm,Term) :-
11340 ast_instantiate_(AstTerm,Map,Term).
11342 ast_instantiate_(var(VarId,_),Map,Term) :-
11343 get_assoc(VarId,Map,Term).
11344 ast_instantiate_(atomic(Atom),_,Atom).
11345 ast_instantiate_(compound(Functor,Arity,Arguments,_),Map,Term) :-
11346 functor(Term,Functor,Arity),
11347 Term =.. [_|Terms],
11348 maplist(ast_instantiate(Map),Arguments,Terms).
11349 %------------------------------------------------------------------------------%
11350 % }}}
11352 %------------------------------------------------------------------------------%
11353 % ast_head_arg_matches_(list(silent_pair(ast_term,var)
11354 % ,modes
11355 % ,map(var_id,...)
11356 % ,set(variables)
11357 % ,list(goal)
11358 % ,vardict
11359 % ,set(variables)
11360 % )
11361 %------------------------------------------------------------------------------%
11363 ast_head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
11364 ast_head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
11365 ( Mode == (+) ->
11366 ast_term_variables(Arg,GroundVars0,GroundVars),
11367 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
11368 ;
11369 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
11370 ).
11371 ast_head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
11372 ( Arg = var(VarId,_) ->
11373 ( get_assoc(VarId,VarDict,OtherVar) ->
11374 ( Mode = (+) ->
11375 ( tree_set_memberchk(VarId,GroundVars) ->
11376 GoalList = [Var = OtherVar | RestGoalList],
11377 GroundVars1 = GroundVars
11378 ;
11379 GoalList = [Var == OtherVar | RestGoalList],
11380 tree_set_add(GroundVars,VarId,GroundVars1)
11381 )
11382 ;
11383 GoalList = [Var == OtherVar | RestGoalList],
11384 GroundVars1 = GroundVars
11385 ),
11386 VarDict1 = VarDict
11387 ;
11388 put_assoc(VarId,VarDict,Var,VarDict1),
11389 GoalList = RestGoalList,
11390 ( Mode = (+) ->
11392 tree_set_add(GroundVars,VarId,GroundVars1)
11393 ;
11394 GroundVars1 = GroundVars
11395 )
11396 ),
11397 Pairs = Rest,
11398 RestModes = Modes
11399 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> % TODO
11400 identifier_label_atom(IndexType,Var,ActualArg,Goal),
11401 GoalList = [Goal|RestGoalList],
11402 VarDict = VarDict1,
11403 GroundVars1 = GroundVars,
11404 Pairs = Rest,
11405 RestModes = Modes
11406 ; Arg = atomic(Atom) ->
11407 ( Mode = (+) ->
11408 GoalList = [ Var = Atom | RestGoalList]
11409 ;
11410 GoalList = [ Var == Atom | RestGoalList]
11411 ),
11412 VarDict = VarDict1,
11413 GroundVars1 = GroundVars,
11414 Pairs = Rest,
11415 RestModes = Modes
11416 ; Mode == (+), ast_is_ground(GroundVars,Arg) ->
11417 ast_instantiate(VarDict,Arg,ArgInst),
11418 GoalList = [ Var = ArgInst | RestGoalList],
11419 VarDict = VarDict1,
11420 GroundVars1 = GroundVars,
11421 Pairs = Rest,
11422 RestModes = Modes
11423 ; Mode == (?), ast_is_ground(GroundVars,Arg) ->
11424 ast_instantiate(VarDict,Arg,ArgInst),
11425 GoalList = [ Var == ArgInst | RestGoalList],
11426 VarDict = VarDict1,
11427 GroundVars1 = GroundVars,
11428 Pairs = Rest,
11429 RestModes = Modes
11430 ; Arg = compound(Functor,Arity,Arguments,_),
11431 functor(Term,Functor,Arity),
11432 Term =.. [_|Vars],
11433 ( Mode = (+) ->
11434 GoalList = [ Var = Term | RestGoalList ]
11435 ;
11436 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
11437 ),
11438 pairup(Arguments,Vars,NewPairs),
11439 append(NewPairs,Rest,Pairs),
11440 replicate(N,Mode,NewModes),
11441 append(NewModes,Modes,RestModes),
11442 VarDict1 = VarDict,
11443 GroundVars1 = GroundVars
11444 ),
11445 ast_head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).