| blob | 2d899ccb66279efdae6533e2df65c3cdde7bbf3f |
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 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3772 ;
3773 L = T
3774 ).
3776 constants_initializers(C,Index,Constants) :-
3777 maplist(constant_initializer(C,Index),Constants).
3779 constant_initializer(C,Index,Constant) :-
3780 constants_store_name(C,Index,Constant,StoreName),
3781 prolog_global_variable(StoreName),
3782 module_initializer(nb_setval(StoreName,[])).
3784 lookup_identifier_atom(Key,X,IX,Atom) :-
3785 atom_concat('lookup_identifier_',Key,LookupFunctor),
3786 Atom =.. [LookupFunctor,X,IX].
3788 identifier_label_atom(IndexType,IX,X,Atom) :-
3789 type_indexed_identifier_name(IndexType,identifier_label,Name),
3790 Atom =.. [Name,IX,X].
3792 multi_store_generate_attach_code([],_,L,L).
3793 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3794 generate_attach_code(ST,C,L,L1),
3795 multi_store_generate_attach_code(STs,C,L1,T).
3797 multi_inthash_store_initialisations([],_,L,L).
3798 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3799 use_auxiliary_module(chr_integertable_store),
3800 multi_hash_store_name(FA,Index,StoreName),
3801 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3802 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3803 L1 = L,
3804 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3805 multi_hash_store_initialisations([],_,L,L).
3806 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3807 use_auxiliary_module(chr_hashtable_store),
3808 multi_hash_store_name(FA,Index,StoreName),
3809 prolog_global_variable(StoreName),
3810 make_init_store_goal(StoreName,HT,InitStoreGoal),
3811 module_initializer((new_ht(HT),InitStoreGoal)),
3812 L1 = L,
3813 multi_hash_store_initialisations(Indexes,FA,L1,T).
3815 global_list_store_initialisation(C,L,T) :-
3816 ( is_stored(C) ->
3817 global_list_store_name(C,StoreName),
3818 prolog_global_variable(StoreName),
3819 make_init_store_goal(StoreName,[],InitStoreGoal),
3820 module_initializer(InitStoreGoal)
3821 ;
3822 true
3823 ),
3824 L = T.
3825 global_ground_store_initialisation(C,L,T) :-
3826 global_ground_store_name(C,StoreName),
3827 prolog_global_variable(StoreName),
3828 make_init_store_goal(StoreName,[],InitStoreGoal),
3829 module_initializer(InitStoreGoal),
3830 L = T.
3831 global_singleton_store_initialisation(C,L,T) :-
3832 global_singleton_store_name(C,StoreName),
3833 prolog_global_variable(StoreName),
3834 make_init_store_goal(StoreName,[],InitStoreGoal),
3835 module_initializer(InitStoreGoal),
3836 L = T.
3837 identifier_store_initialization(IndexType,L,T) :-
3838 use_auxiliary_module(chr_hashtable_store),
3839 identifier_store_name(IndexType,StoreName),
3840 prolog_global_variable(StoreName),
3841 make_init_store_goal(StoreName,HT,InitStoreGoal),
3842 module_initializer((new_ht(HT),InitStoreGoal)),
3843 L = T.
3846 multi_inthash_via_lookups([],_,L,L).
3847 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3848 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3849 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3850 L = [(Head :- Body)|L1],
3851 multi_inthash_via_lookups(Indexes,C,L1,T).
3852 multi_hash_lookups([],_,L,L).
3853 multi_hash_lookups([Index|Indexes],C,L,T) :-
3854 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3855 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3856 L = [(Head :- Body)|L1],
3857 multi_hash_lookups(Indexes,C,L1,T).
3859 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3860 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3861 Head =.. [Name,Key,SuspsList].
3863 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3864 %
3865 % Returns goal that performs hash table lookup.
3866 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3867 % INLINED:
3868 get_store_type(ConstraintSymbol,multi_store(Stores)),
3869 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3870 ( ground(Key) ->
3871 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3872 Goal = nb_getval(StoreName,SuspsList)
3873 ;
3874 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3875 Lookup =.. [IndexName,Key,StoreName],
3876 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3877 )
3878 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3879 ( ground(Key) ->
3880 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3881 Goal = nb_getval(StoreName,SuspsList)
3882 ;
3883 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3884 Lookup =.. [IndexName,Key,StoreName],
3885 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3886 )
3887 ; memberchk(multi_hash([Index]),Stores) ->
3888 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3889 make_get_store_goal(StoreName,HT,GetStoreGoal),
3890 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3891 Goal =
3892 (
3893 GetStoreGoal, % nb_getval(StoreName,HT),
3894 HashCall, % hash_term(Key,Hash),
3895 lookup_ht1(HT,Hash,Key,SuspsList)
3896 )
3897 ;
3898 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3899 Goal =
3900 (
3901 GetStoreGoal, % nb_getval(StoreName,HT),
3902 Lookup
3903 )
3904 )
3905 ; HashType == inthash ->
3906 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3907 make_get_store_goal(StoreName,HT,GetStoreGoal),
3908 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3909 Goal =
3910 (
3911 GetStoreGoal, % nb_getval(StoreName,HT),
3912 Lookup
3913 )
3914 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3915 % find alternative index
3916 % -> SubIndex + RestIndex
3917 % -> SubKey + RestKeys
3918 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3919 % instantiate rest goal?
3920 % Goal = (SubGoal,RestGoal)
3921 ).
3924 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3925 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3927 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3928 ( ground(Key) ->
3929 % This is based on a property of SWI-Prolog's
3930 % hash_term/2 predicate:
3931 % the hash value is stable over repeated invocations
3932 % of SWI-Prolog
3933 hash_term(Key,Hash),
3934 Call = true
3935 % ; Index = [IndexPos],
3936 % get_constraint_type(Constraint,ArgTypes),
3937 % nth1(IndexPos,ArgTypes,Type),
3938 % unalias_type(Type,NormalType),
3939 % memberchk_eq(NormalType,[int,natural]) ->
3940 % ( NormalType == int ->
3941 % Call = (Hash is abs(Key))
3942 % ;
3943 % Hash = Key,
3944 % Call = true
3945 % )
3946 % ;
3947 % nonvar(Key),
3948 % specialize_hash_term(Key,NewKey),
3949 % NewKey \== Key,
3950 % Call = hash_term(NewKey,Hash)
3951 ).
3953 % specialize_hash_term(Term,NewTerm) :-
3954 % ( ground(Term) ->
3955 % hash_term(Term,NewTerm)
3956 % ; var(Term) ->
3957 % NewTerm = Term
3958 % ;
3959 % Term =.. [F|Args],
3960 % maplist(specialize_hash_term,Args,NewArgs),
3961 % NewTerm =.. [F|NewArgs]
3962 % ).
3964 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3965 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3966 ( /* chr_pp_flag(experiment,off) ->
3967 true
3968 ; */ atomic(Key) ->
3969 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3970 ; ground(Key) ->
3971 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3972 ;
3973 ( Index = [Pos],
3974 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3975 is_chr_constants_type(Type,_,_)
3976 ->
3977 true
3978 ;
3979 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3980 )
3981 ),
3982 delay_phase_end(validate_store_type_assumptions,
3983 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3985 :- chr_constraint actual_atomic_multi_hash_keys/3.
3986 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3988 :- chr_constraint actual_ground_multi_hash_keys/3.
3989 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3991 :- chr_constraint actual_non_ground_multi_hash_key/2.
3992 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3994 /*
3995 actual_atomic_multi_hash_keys(C,Index,Keys)
3996 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3998 actual_ground_multi_hash_keys(C,Index,Keys)
3999 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
4001 actual_non_ground_multi_hash_key(C,Index)
4002 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
4003 */
4004 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4005 <=> append(Keys1,Keys2,Keys0),
4006 sort(Keys0,Keys),
4007 actual_atomic_multi_hash_keys(C,Index,Keys).
4009 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4010 <=> append(Keys1,Keys2,Keys0),
4011 sort(Keys0,Keys),
4012 actual_ground_multi_hash_keys(C,Index,Keys).
4014 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
4015 <=> append(Keys1,Keys2,Keys0),
4016 sort(Keys0,Keys),
4017 actual_ground_multi_hash_keys(C,Index,Keys).
4019 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
4020 <=> true.
4022 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
4023 <=> true.
4025 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
4026 <=> true.
4028 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
4029 %
4030 % Returns predicate name of hash table lookup predicate.
4031 multi_hash_lookup_name(F/A,Index,Name) :-
4032 atom_concat_list(Index,IndexName),
4033 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
4035 multi_hash_store_name(F/A,Index,Name) :-
4036 get_target_module(Mod),
4037 atom_concat_list(Index,IndexName),
4038 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
4040 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
4041 ( Index = [I] ->
4042 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
4043 ;
4044 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
4045 Key =.. [k|Keys],
4046 list2conj(Bodies,KeyBody)
4047 ).
4049 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
4050 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
4052 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
4053 ( Index = [I] ->
4054 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
4055 ;
4056 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
4057 Key =.. [k|Keys],
4058 list2conj(Bodies,KeyBody)
4059 ).
4061 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
4062 arg(Index,Head,OriginalArg),
4063 ( ground(OriginalArg), OriginalArg = '$chr_identifier_match'(Value,KeyType) ->
4064 functor(Head,F,A),
4065 lookup_identifier_atom(KeyType,Value,Arg,Goal)
4066 ; term_variables(OriginalArg,OriginalVars),
4067 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
4068 translate(OriginalVars,VarDict,Vars) ->
4069 Goal = true
4070 ;
4071 functor(Head,F,A),
4072 C = F/A,
4073 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
4074 ).
4076 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
4077 ( Index = [I] ->
4078 UsedVars = [I-Key]
4079 ;
4080 pairup(Index,Keys,UsedVars),
4081 Key =.. [k|Keys]
4082 ).
4084 args(Index,Head,KeyArgs) :-
4085 maplist(arg1(Head),Index,KeyArgs).
4087 split_args(Indexes,Args,IArgs,NIArgs) :-
4088 split_args(Indexes,Args,1,IArgs,NIArgs).
4090 split_args([],Args,_,[],Args).
4091 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
4092 NJ is J + 1,
4093 ( I == J ->
4094 IArgs = [Arg|Rest],
4095 split_args(Is,Args,NJ,Rest,NIArgs)
4096 ;
4097 NIArgs = [Arg|Rest],
4098 split_args([I|Is],Args,NJ,IArgs,Rest)
4099 ).
4102 %-------------------------------------------------------------------------------
4103 atomic_constants_code(C,Index,Constants,L,T) :-
4104 constants_store_index_name(C,Index,IndexName),
4105 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
4106 append(Clauses,T,L).
4108 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
4109 constants_store_name(C,Index,Constant,StoreName),
4110 Clause =.. [IndexName,Constant,StoreName].
4112 %-------------------------------------------------------------------------------
4113 ground_constants_code(C,Index,Terms,L,T) :-
4114 constants_store_index_name(C,Index,IndexName),
4115 maplist(constants_store_name(C,Index),Terms,StoreNames),
4116 length(Terms,N),
4117 replicate(N,[],More),
4118 trie_index([Terms|More],StoreNames,IndexName,L,T).
4120 constants_store_name(F/A,Index,Term,Name) :-
4121 get_target_module(Mod),
4122 term_to_atom(Term,Constant),
4123 term_to_atom(Index,IndexAtom),
4124 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
4126 constants_store_index_name(F/A,Index,Name) :-
4127 get_target_module(Mod),
4128 term_to_atom(Index,IndexAtom),
4129 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
4131 % trie index code {{{
4132 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
4133 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
4135 trie_step([],_,_,[],[],L,L) :- !.
4136 % length MorePatterns == length Patterns == length Results
4137 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
4138 MorePatterns = [List|_],
4139 length(List,N),
4140 aggregate_all(set(F/A),
4141 ( member(Pattern,Patterns),
4142 functor(Pattern,F,A)
4143 ),
4144 FAs),
4145 N1 is N + 1,
4146 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4148 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4149 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4150 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4151 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4153 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4154 Clause = (Head :- Body),
4155 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4156 N1 is N + 1,
4157 functor(Head,Symbol,N1),
4158 arg(1,Head,IndexPattern),
4159 Head =.. [_,_|RestArgs],
4160 once(append(Vs,[Result],RestArgs)),
4161 /* IndexPattern = F() */
4162 functor(IndexPattern,F,A),
4163 IndexPattern =.. [_|Args],
4164 append(Args,RestArgs,RecArgs),
4165 ( RecArgs == [Result] ->
4166 /* nothing more to match on */
4167 List = Tail,
4168 Body = true,
4169 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4170 MoreResults = [Result]
4171 ; /* more things to match on */
4172 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4173 ( MoreCases = [OneMoreCase] ->
4174 /* only one more thing to match on */
4175 List = Tail,
4176 Body = true,
4177 append([Cases,OneMoreCase,MoreResults],RecArgs)
4178 ;
4179 /* more than one thing to match on */
4180 /* [ x1,..., xn]
4181 [xs1,...,xsn]
4182 */
4183 pairup(Cases,MoreCases,CasePairs),
4184 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4185 append(Args,Vs,[First|Rest]),
4186 First-Rest = CommonPatternPair,
4187 % Body = RSymbol(DiffVars,Result)
4188 gensym(Prefix,RSymbol),
4189 append(DiffVars,[Result],RecCallVars),
4190 Body =.. [RSymbol|RecCallVars],
4191 maplist(head_tail,Differences,CHs,CTs),
4192 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4193 )
4194 ).
4196 head_tail([H|T],H,T).
4198 rec_cases([],[],[],_,[],[],[]).
4199 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4200 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4201 Cases = [Case|NCases],
4202 MoreCases = [MoreCase|NMoreCases],
4203 MoreResults = [Result|NMoreResults],
4204 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4205 ;
4206 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4207 ).
4208 % }}}
4210 %% common_pattern(+terms,-term,-vars,-differences) is det.
4211 common_pattern(Ts,T,Vars,Differences) :-
4212 fold1(chr_translate:gct,Ts,T),
4213 term_variables(T,Vars),
4214 findall(Vars,member(T,Ts),Differences).
4216 gct(T1,T2,T) :-
4217 gct_(T1,T2,T,[],_).
4219 gct_(T1,T2,T,Dict0,Dict) :-
4220 ( nonvar(T1),
4221 nonvar(T2),
4222 functor(T1,F1,A1),
4223 functor(T2,F2,A2),
4224 F1 == F2,
4225 A1 == A2 ->
4226 functor(T,F1,A1),
4227 T1 =.. [_|Args1],
4228 T2 =.. [_|Args2],
4229 T =.. [_|Args],
4230 maplist_dcg(chr_translate:gct_,Args1,Args2,Args,Dict0,Dict)
4231 ;
4232 /* T is a variable */
4233 ( lookup_eq(Dict0,T1+T2,T) ->
4234 /* we already have a variable for this difference */
4235 Dict = Dict0
4236 ;
4237 /* T is a fresh variable */
4238 Dict = [(T1+T2)-T|Dict0]
4239 )
4240 ).
4243 %-------------------------------------------------------------------------------
4244 global_list_store_name(F/A,Name) :-
4245 get_target_module(Mod),
4246 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4247 global_ground_store_name(F/A,Name) :-
4248 get_target_module(Mod),
4249 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4250 global_singleton_store_name(F/A,Name) :-
4251 get_target_module(Mod),
4252 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4254 identifier_store_name(TypeName,Name) :-
4255 get_target_module(Mod),
4256 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4258 :- chr_constraint prolog_global_variable/1.
4259 :- chr_option(mode,prolog_global_variable(+)).
4261 :- chr_constraint prolog_global_variables/1.
4262 :- chr_option(mode,prolog_global_variables(-)).
4264 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4266 prolog_global_variables(List), prolog_global_variable(Name) <=>
4267 List = [Name|Tail],
4268 prolog_global_variables(Tail).
4269 prolog_global_variables(List) <=> List = [].
4271 %% SWI begin
4272 prolog_global_variables_code(Code) :-
4273 prolog_global_variables(Names),
4274 ( Names == [] ->
4275 Code = []
4276 ;
4277 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4278 Code = [(:- dynamic user:exception/3),
4279 (:- multifile user:exception/3),
4280 (user:exception(undefined_global_variable,Name,retry) :-
4281 (
4282 '$chr_prolog_global_variable'(Name),
4283 '$chr_initialization'
4284 )
4285 )
4286 |
4287 NameDeclarations
4288 ]
4289 ).
4290 %% SWI end
4291 %% SICStus begin
4292 % prolog_global_variables_code([]).
4293 %% SICStus end
4294 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4295 %sbag_member_call(S,L,sysh:mem(S,L)).
4296 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4297 %sbag_member_call(S,L,member(S,L)).
4298 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4299 %update_mutable_call(A,B,setarg(1, B, A)).
4300 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4301 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4303 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4304 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4305 % create_get_mutable(Value,Field,Get1).
4306 %
4307 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4308 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4309 % update_mutable_call(NewValue,Field,Set).
4310 %
4311 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4312 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4313 % create_get_mutable_ref(Value,Field,Get1),
4314 % update_mutable_call(NewValue,Field,Set).
4315 %
4316 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4317 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4318 % create_mutable_call(Value,Field,Create).
4319 %
4320 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4321 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4322 % create_get_mutable(Value,Field,Get).
4323 %
4324 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4325 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4326 % create_get_mutable_ref(Value,Field,Get),
4327 % update_mutable_call(NewValue,Field,Set).
4329 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4330 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4332 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4333 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4335 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4336 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4337 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4339 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4340 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4342 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4343 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4345 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4346 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4347 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4351 enumerate_stores_code(Constraints,[Clause|List]) :-
4352 Head = '$enumerate_constraints'(Constraint),
4353 Clause = ( Head :- Body),
4354 enumerate_store_bodies(Constraints,Constraint,List),
4355 ( List = [] ->
4356 Body = fail
4357 ;
4358 Body = ( nonvar(Constraint) ->
4359 functor(Constraint,Functor,_),
4360 '$enumerate_constraints'(Functor,Constraint)
4361 ;
4362 '$enumerate_constraints'(_,Constraint)
4363 )
4364 ).
4366 enumerate_store_bodies([],_,[]).
4367 enumerate_store_bodies([C|Cs],Constraint,L) :-
4368 ( is_stored(C) ->
4369 get_store_type(C,StoreType),
4370 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4371 true
4372 ;
4373 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4374 ),
4375 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4376 C = F/_,
4377 Constraint0 =.. [F|Arguments],
4378 Head = '$enumerate_constraints'(F,Constraint),
4379 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4380 L = [(Head :- Body)|T]
4381 ;
4382 L = T
4383 ),
4384 enumerate_store_bodies(Cs,Constraint,T).
4386 enumerate_store_body(default,C,Susp,Body) :-
4387 global_list_store_name(C,StoreName),
4388 sbag_member_call(Susp,List,Sbag),
4389 make_get_store_goal(StoreName,List,GetStoreGoal),
4390 Body =
4391 (
4392 GetStoreGoal, % nb_getval(StoreName,List),
4393 Sbag
4394 ).
4395 % get_constraint_index(C,Index),
4396 % get_target_module(Mod),
4397 % get_max_constraint_index(MaxIndex),
4398 % Body1 =
4399 % (
4400 % 'chr default_store'(GlobalStore),
4401 % get_attr(GlobalStore,Mod,Attr)
4402 % ),
4403 % ( MaxIndex > 1 ->
4404 % NIndex is Index + 1,
4405 % sbag_member_call(Susp,List,Sbag),
4406 % Body2 =
4407 % (
4408 % arg(NIndex,Attr,List),
4409 % Sbag
4410 % )
4411 % ;
4412 % sbag_member_call(Susp,Attr,Sbag),
4413 % Body2 = Sbag
4414 % ),
4415 % Body = (Body1,Body2).
4416 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4417 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4418 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4419 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4420 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4421 Completeness == complete, % fail if incomplete
4422 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4423 list2disj(Disjuncts, Disjunction),
4424 Body = ( Disjunction, member(Susp,Susps) ).
4425 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4426 constants_store_name(C,Index,Constant,StoreName).
4428 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4429 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4430 enumerate_store_body(global_ground,C,Susp,Body) :-
4431 global_ground_store_name(C,StoreName),
4432 sbag_member_call(Susp,List,Sbag),
4433 make_get_store_goal(StoreName,List,GetStoreGoal),
4434 Body =
4435 (
4436 GetStoreGoal, % nb_getval(StoreName,List),
4437 Sbag
4438 ).
4439 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4440 Body = fail.
4441 enumerate_store_body(global_singleton,C,Susp,Body) :-
4442 global_singleton_store_name(C,StoreName),
4443 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4444 Body =
4445 (
4446 GetStoreGoal, % nb_getval(StoreName,Susp),
4447 Susp \== []
4448 ).
4449 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4450 ( memberchk(global_ground,STs) ->
4451 enumerate_store_body(global_ground,C,Susp,Body)
4452 ;
4453 once((
4454 member(ST,STs),
4455 enumerate_store_body(ST,C,Susp,Body)
4456 ))
4457 ).
4458 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4459 Body = fail.
4460 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4461 Body = fail.
4463 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4464 multi_hash_store_name(C,I,StoreName),
4465 B =
4466 (
4467 nb_getval(StoreName,HT),
4468 value_iht(HT,Susp)
4469 ).
4470 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4471 multi_hash_store_name(C,I,StoreName),
4472 make_get_store_goal(StoreName,HT,GetStoreGoal),
4473 B =
4474 (
4475 GetStoreGoal, % nb_getval(StoreName,HT),
4476 value_ht(HT,Susp)
4477 ).
4479 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4480 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4481 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4483 :- chr_constraint
4484 background_info/1,
4485 background_info/2,
4486 get_bg_info/1,
4487 get_bg_info/2,
4488 get_bg_info_answer/1.
4490 background_info(X), background_info(Y) <=>
4491 append(X,Y,XY), background_info(XY).
4492 background_info(X) \ get_bg_info(Q) <=> Q=X.
4493 get_bg_info(Q) <=> Q = [].
4495 background_info(T,I), get_bg_info(A,Q) ==>
4496 copy_term_nat(T,T1),
4497 subsumes_chk(T1,A)
4498 |
4499 copy_term_nat(T-I,A-X),
4500 get_bg_info_answer([X]).
4501 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4502 append(X,Y,XY), get_bg_info_answer(XY).
4504 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4505 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4510 :- chr_constraint
4511 prev_guard_list/8,
4512 prev_guard_list/6,
4513 simplify_guards/1,
4514 set_all_passive/1.
4516 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4517 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4518 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4519 :- chr_option(mode,simplify_guards(+)).
4520 :- chr_option(mode,set_all_passive(+)).
4522 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4523 % GUARD SIMPLIFICATION
4524 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4525 % If the negation of the guards of earlier rules entails (part of)
4526 % the current guard, the current guard can be simplified. We can only
4527 % use earlier rules with a head that matches if the head of the current
4528 % rule does, and which make it impossible for the current rule to match
4529 % if they fire (i.e. they shouldn't be propagation rules and their
4530 % head constraints must be subsets of those of the current rule).
4531 % At this point, we know for sure that the negation of the guard
4532 % of such a rule has to be true (otherwise the earlier rule would have
4533 % fired, because of the refined operational semantics), so we can use
4534 % that information to simplify the guard by replacing all entailed
4535 % conditions by true/0. As a consequence, the never-stored analysis
4536 % (in a further phase) will detect more cases of never-stored constraints.
4537 %
4538 % e.g. c(X),d(Y) <=> X > 0 | ...
4539 % e(X) <=> X < 0 | ...
4540 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4541 % \____________/
4542 % true
4544 guard_simplification :-
4545 ( chr_pp_flag(guard_simplification,on) ->
4546 precompute_head_matchings,
4547 simplify_guards(1)
4548 ;
4549 true
4550 ).
4552 % for every rule, we create a prev_guard_list where the last argument
4553 % eventually is a list of the negations of earlier guards
4554 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4555 <=>
4556 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4557 append(Head1,Head2,Heads),
4558 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4559 tree_set_empty(Done),
4560 multiple_occ_constraints_checked(Done),
4561 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4563 append(IDs1,IDs2,IDs),
4564 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4565 empty_q(EmptyHeap),
4566 insert_list_q(HeapData,EmptyHeap,Heap),
4567 next_prev_rule(Heap,_,Heap1),
4568 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4569 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4570 NextRule is RuleNb+1,
4571 simplify_guards(NextRule).
4573 next_prev_rule(Heap,RuleNb,NHeap) :-
4574 ( find_min_q(Heap,_-Priority) ->
4575 Priority = (-RuleNb),
4576 normalize_heap(Heap,Priority,NHeap)
4577 ;
4578 RuleNb = 0,
4579 NHeap = Heap
4580 ).
4582 normalize_heap(Heap,Priority,NHeap) :-
4583 ( find_min_q(Heap,_-Priority) ->
4584 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4585 ( O > 1 ->
4586 NO is O -1,
4587 get_occurrence(C,NO,RuleNb,_),
4588 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4589 ;
4590 Heap2 = Heap1
4591 ),
4592 normalize_heap(Heap2,Priority,NHeap)
4593 ;
4594 NHeap = Heap
4595 ).
4597 % no more rule
4598 simplify_guards(_)
4599 <=>
4600 true.
4602 % The negation of the guard of a non-propagation rule is added
4603 % if its kept head constraints are a subset of the kept constraints of
4604 % the rule we're working on, and its removed head constraints (at least one)
4605 % are a subset of the removed constraints.
4607 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4608 <=>
4609 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4610 H1 \== [],
4611 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4612 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4613 |
4614 append(H1,H2,Heads),
4615 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4616 append(GuardList,DerivedInfo,GL1),
4617 normalize_conj_list(GL1,GL),
4618 append(GH_New1,GH,GH1),
4619 normalize_conj_list(GH1,GH_New),
4620 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4621 % PrevPrevRuleNb is PrevRuleNb-1,
4622 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4624 % if this isn't the case, we skip this one and try the next rule
4625 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4626 <=>
4627 ( N > 0 ->
4628 next_prev_rule(Heap,N1,NHeap),
4629 % N1 is N-1,
4630 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4631 ;
4632 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4633 ).
4635 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4636 <=>
4637 GH \== []
4638 |
4639 head_types_modes_condition(GH,H,TypeInfo),
4640 conj2list(TypeInfo,TI),
4641 term_variables(H,HeadVars),
4642 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4643 normalize_conj_list(Info,InfoL),
4644 append(H,InfoL,RelevantTerms),
4645 add_background_info([G|RelevantTerms],BGInfo),
4646 append(InfoL,BGInfo,AllInfo_),
4647 normalize_conj_list(AllInfo_,AllInfo),
4648 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4650 head_types_modes_condition([],H,true).
4651 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4652 types_modes_condition(H,GH,TI1),
4653 head_types_modes_condition(GHs,H,TI2).
4655 add_background_info(Term,Info) :-
4656 get_bg_info(GeneralInfo),
4657 add_background_info2(Term,TermInfo),
4658 append(GeneralInfo,TermInfo,Info).
4660 add_background_info2(X,[]) :- var(X), !.
4661 add_background_info2([],[]) :- !.
4662 add_background_info2([X|Xs],Info) :- !,
4663 add_background_info2(X,Info1),
4664 add_background_info2(Xs,Infos),
4665 append(Info1,Infos,Info).
4667 add_background_info2(X,Info) :-
4668 (functor(X,_,A), A>0 ->
4669 X =.. [_|XArgs],
4670 add_background_info2(XArgs,XArgInfo)
4671 ;
4672 XArgInfo = []
4673 ),
4674 get_bg_info(X,XInfo),
4675 append(XInfo,XArgInfo,Info).
4677 %%
4678 % when all earlier guards are added or skipped, we simplify the guard.
4679 % if it's different from the original one, we change the rule
4681 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4682 <=>
4683 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4684 G \== true, % let's not try to simplify this ;)
4685 append(M,GuardList,Info),
4686 (% if guard + context is a contradiction, it should be simplified to "fail"
4687 conj2list(G,GL), append(Info,GL,GuardWithContext),
4688 guard_entailment:entails_guard(GuardWithContext,fail) ->
4689 SimpleGuard = fail
4690 ;
4691 % otherwise we try to remove redundant conjuncts
4692 simplify_guard(G,B,Info,SimpleGuard,NB)
4693 ),
4694 G \== SimpleGuard % only do this if we can change the guard
4695 |
4696 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4697 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4699 %% normalize_conj_list(+List,-NormalList) is det.
4700 %
4701 % Removes =true= elements and flattens out conjunctions.
4703 normalize_conj_list(List,NormalList) :-
4704 list2conj(List,Conj),
4705 conj2list(Conj,NormalList).
4707 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4708 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4709 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4711 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4712 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4713 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4714 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4715 append(Renaming1,ExtraRenaming,Renaming2),
4716 list2conj(PrevMatchings,Match),
4717 negate_b(Match,HeadsDontMatch),
4718 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4719 list2conj(HeadsMatch,HeadsMatchBut),
4720 term_variables(Renaming2,RenVars),
4721 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4722 new_vars(MGVars,RenVars,ExtraRenaming2),
4723 append(Renaming2,ExtraRenaming2,Renaming),
4724 ( PrevGuard == true -> % true can't fail
4725 Info_ = HeadsDontMatch
4726 ;
4727 negate_b(PrevGuard,TheGuardFailed),
4728 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4729 ),
4730 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4731 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4732 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4733 list2conj(RenamedMatchings_,RenamedMatchings),
4734 apply_guard_wrt_term(H,RenamedG2,GH2),
4735 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4736 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4738 simplify_guard(G,B,Info,SG,NB) :-
4739 conj2list(G,LG),
4740 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4741 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4742 list2conj(SGL,SG).
4745 new_vars([],_,[]).
4746 new_vars([A|As],RV,ER) :-
4747 ( memberchk_eq(A,RV) ->
4748 new_vars(As,RV,ER)
4749 ;
4750 ER = [A-NewA,NewA-A|ER2],
4751 new_vars(As,RV,ER2)
4752 ).
4754 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4755 %
4756 % check if a list of constraints is a subset of another list of constraints
4757 % (multiset-subset), meanwhile computing a variable renaming to convert
4758 % one into the other.
4759 head_subset(H,Head,Renaming) :-
4760 head_subset(H,Head,Renaming,[],_).
4762 head_subset([],Remainder,Renaming,Renaming,Remainder).
4763 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4764 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4765 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4767 % check if A is in the list, remove it from Headleft
4768 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4769 ( variable_replacement(A,X,Acc,Renaming),
4770 Remainder = Xs
4771 ;
4772 Remainder = [X|RRemainder],
4773 head_member(Xs,A,Renaming,Acc,RRemainder)
4774 ).
4775 %-------------------------------------------------------------------------------%
4776 % memoing code to speed up repeated computation
4778 :- chr_constraint precompute_head_matchings/0.
4780 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4781 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4782 append(H1,H2,Heads),
4783 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4784 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4785 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4787 precompute_head_matchings <=> true.
4789 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4790 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4792 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4793 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4795 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4796 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4797 <=>
4798 Q1 = NHeads,
4799 Q2 = Matchings.
4800 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4802 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4803 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4804 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4805 %-------------------------------------------------------------------------------%
4807 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4808 extract_arguments(Heads,Arguments),
4809 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4810 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4812 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4813 extract_arguments(Heads,Arguments),
4814 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4815 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4817 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4818 extract_arguments(Heads,Arguments1),
4819 extract_arguments(MatchingFreeHeads,Arguments2),
4820 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4822 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4823 %
4824 % Returns list of arguments of given list of constraints.
4825 extract_arguments([],[]).
4826 extract_arguments([Constraint|Constraints],AllArguments) :-
4827 Constraint =.. [_|Arguments],
4828 append(Arguments,RestArguments,AllArguments),
4829 extract_arguments(Constraints,RestArguments).
4831 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4832 %
4833 % Substitutes arguments of constraints with those in the given list.
4835 substitute_arguments([],[],[]).
4836 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4837 functor(Constraint,F,N),
4838 split_at(N,Variables,Arguments,RestVariables),
4839 NConstraint =.. [F|Arguments],
4840 substitute_arguments(Constraints,RestVariables,NConstraints).
4842 make_matchings_explicit([],[],_,MC,MC,[]).
4843 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4844 ( var(Arg) ->
4845 ( memberchk_eq(Arg,VarAcc) ->
4846 list2disj(MatchingCondition,MatchingCondition_disj),
4847 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4848 NVarAcc = VarAcc
4849 ;
4850 Matchings = RestMatchings,
4851 NewVar = Arg,
4852 NVarAcc = [Arg|VarAcc]
4853 ),
4854 MatchingCondition2 = MatchingCondition
4855 ;
4856 functor(Arg,F,A),
4857 Arg =.. [F|RecArgs],
4858 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4859 FlatArg =.. [F|RecVars],
4860 ( RecMatchings == [] ->
4861 Matchings = [functor(NewVar,F,A)|RestMatchings]
4862 ;
4863 list2conj(RecMatchings,ArgM_conj),
4864 list2disj(MatchingCondition,MatchingCondition_disj),
4865 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4866 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4867 ),
4868 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4869 term_variables(Args,ArgVars),
4870 append(ArgVars,VarAcc,NVarAcc)
4871 ),
4872 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4875 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4876 %
4877 % Returns list of new variables and list of pairwise unifications between given list and variables.
4879 make_matchings_explicit_not_negated([],[],[]).
4880 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4881 Matchings = [Var = X|RMatchings],
4882 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4884 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4885 %
4886 % (Partially) applies substitutions of =Goal= to given list.
4888 apply_guard_wrt_term([],_Guard,[]).
4889 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4890 ( var(Term) ->
4891 apply_guard_wrt_variable(Guard,Term,NTerm)
4892 ;
4893 Term =.. [F|HArgs],
4894 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4895 NTerm =.. [F|NewHArgs]
4896 ),
4897 apply_guard_wrt_term(RH,Guard,RGH).
4899 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4900 %
4901 % (Partially) applies goal =Guard= wrt variable.
4903 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4904 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4905 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4906 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4907 ( Guard = (X = Y), Variable == X ->
4908 NVariable = Y
4909 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4910 functor(NVariable,Functor,Arity)
4911 ;
4912 NVariable = Variable
4913 ).
4916 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4917 % ALWAYS FAILING GUARDS
4918 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4920 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4921 ==>
4922 chr_pp_flag(check_impossible_rules,on),
4923 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4924 conj2list(G,GL),
4925 append(M,GuardList,Info),
4926 append(Info,GL,GuardWithContext),
4927 guard_entailment:entails_guard(GuardWithContext,fail)
4928 |
4929 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4930 set_all_passive(RuleNb).
4932 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4933 % HEAD SIMPLIFICATION
4934 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4936 % now we check the head matchings (guard may have been simplified meanwhile)
4937 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4938 <=>
4939 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4940 simplify_heads(M,GuardList,G,B,NewM,NewB),
4941 NewM \== [],
4942 extract_arguments(Head1,VH1),
4943 extract_arguments(Head2,VH2),
4944 extract_arguments(H,VH),
4945 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4946 substitute_arguments(Head1,H1,NewH1),
4947 substitute_arguments(Head2,H2,NewH2),
4948 append(NewB,NewB_,NewBody),
4949 list2conj(NewBody,BodyMatchings),
4950 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4951 (Head1 \== NewH1 ; Head2 \== NewH2 )
4952 |
4953 rule(RuleNb,NewRule).
4955 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4956 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4957 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4959 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4960 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4961 ( NH == M ->
4962 H2_ = M,
4963 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4964 ;
4965 (M = functor(X,F,A), NH == X ->
4966 length(A_args,A),
4967 (var(H2) ->
4968 NewB1 = [],
4969 H2_ =.. [F|A_args]
4970 ;
4971 H2 =.. [F|OrigArgs],
4972 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4973 H2_ =.. [F|A_args_]
4974 ),
4975 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4976 append(NewB1,NewB2,NewB)
4977 ;
4978 H2_ = H2,
4979 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4980 )
4981 ).
4983 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4984 ( NH == M ->
4985 H1_ = M,
4986 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4987 ;
4988 (M = functor(X,F,A), NH == X ->
4989 length(A_args,A),
4990 (var(H1) ->
4991 NewB1 = [],
4992 H1_ =.. [F|A_args]
4993 ;
4994 H1 =.. [F|OrigArgs],
4995 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4996 H1_ =.. [F|A_args_]
4997 ),
4998 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4999 append(NewB1,NewB2,NewB)
5000 ;
5001 H1_ = H1,
5002 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
5003 )
5004 ).
5006 use_same_args([],[],[],_,_,[]).
5007 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5008 var(OA),!,
5009 Out = OA,
5010 use_same_args(ROA,RNA,ROut,G,Body,NewB).
5011 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5012 nonvar(OA),!,
5013 ( common_variables(OA,Body) ->
5014 NewB = [NA = OA|NextB]
5015 ;
5016 NewB = NextB
5017 ),
5018 Out = NA,
5019 use_same_args(ROA,RNA,ROut,G,Body,NextB).
5022 simplify_heads([],_GuardList,_G,_Body,[],[]).
5023 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
5024 M = (A = B),
5025 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
5026 guard_entailment:entails_guard(GuardList,(A=B)) ->
5027 ( common_variables(B,G-RM-GuardList) ->
5028 NewB = NextB,
5029 NewM = NextM
5030 ;
5031 ( common_variables(B,Body) ->
5032 NewB = [A = B|NextB]
5033 ;
5034 NewB = NextB
5035 ),
5036 NewM = [A|NextM]
5037 )
5038 ;
5039 ( nonvar(B), functor(B,BFu,BAr),
5040 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
5041 NewB = NextB,
5042 ( common_variables(B,G-RM-GuardList) ->
5043 NewM = NextM
5044 ;
5045 NewM = [functor(A,BFu,BAr)|NextM]
5046 )
5047 ;
5048 NewM = NextM,
5049 NewB = NextB
5050 )
5051 ),
5052 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
5054 common_variables(B,G) :-
5055 term_variables(B,BVars),
5056 term_variables(G,GVars),
5057 intersect_eq(BVars,GVars,L),
5058 L \== [].
5061 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
5062 set_all_passive(_) <=> true.
5066 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5067 % OCCURRENCE SUBSUMPTION
5068 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5070 :- chr_constraint
5071 first_occ_in_rule/4,
5072 next_occ_in_rule/6.
5074 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
5075 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
5077 :- chr_constraint multiple_occ_constraints_checked/1.
5078 :- chr_option(mode,multiple_occ_constraints_checked(+)).
5080 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
5081 occurrence(C,O,RuleNb,ID,_),
5082 occurrence(C,O2,RuleNb,ID2,_),
5083 rule(RuleNb,Rule)
5084 \
5085 multiple_occ_constraints_checked(Done)
5086 <=>
5087 O < O2,
5088 chr_pp_flag(occurrence_subsumption,on),
5089 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
5090 H1 \== [],
5091 \+ tree_set_memberchk(C,Done)
5092 |
5093 first_occ_in_rule(RuleNb,C,O,ID),
5094 tree_set_add(Done,C,NDone),
5095 multiple_occ_constraints_checked(NDone).
5097 % Find first occurrence of constraint =C= in rule =RuleNb=
5098 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
5099 <=>
5100 O < O2
5101 |
5102 first_occ_in_rule(RuleNb,C,O,ID).
5104 first_occ_in_rule(RuleNb,C,O,ID_o1)
5105 <=>
5106 C = F/A,
5107 functor(FreshHead,F,A),
5108 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
5110 % Skip passive occurrences.
5111 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
5112 <=>
5113 O2 is O+1
5114 |
5115 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
5117 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)
5118 <=>
5119 O2 is O+1,
5120 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
5121 |
5122 append(H1,H2,Heads),
5123 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5124 ( ExtraCond == [chr_pp_void_info] ->
5125 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5126 ;
5127 append(ExtraCond,Cond,NewCond),
5128 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5129 copy_term(GuardList,FGuardList),
5130 variable_replacement(GuardList,FGuardList,GLRepl),
5131 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5132 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5133 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5134 append(NewCond,GuardList2,BigCond),
5135 append(BigCond,GuardList3,BigCond2),
5136 copy_with_variable_replacement(M,M2,Repl),
5137 copy_with_variable_replacement(M,M3,Repl2),
5138 append(M3,BigCond2,BigCond3),
5139 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5140 list2conj(CheckCond,OccSubsum),
5141 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5142 ( OccSubsum \= chr_pp_void_info ->
5143 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5144 passive(RuleNb,ID_o2)
5145 ;
5146 true
5147 )
5148 ;
5149 true
5150 ),!,
5151 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5152 ).
5155 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5156 <=>
5157 true.
5159 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5160 <=>
5161 true.
5163 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5164 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5165 append(ID2,ID1,IDs),
5166 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5167 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5168 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5169 copy_with_variable_replacement(G,FG,Repl),
5170 extract_explicit_matchings(FG,FG2),
5171 negate_b(FG2,NotFG),
5172 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5173 ( subsumes(FH,FH2) ->
5174 FailCond = [(NotFG;FMPCond)]
5175 ;
5176 % in this case, not much can be done
5177 % e.g. c(f(...)), c(g(...)) <=> ...
5178 FailCond = [chr_pp_void_info]
5179 ).
5181 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5182 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5183 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5184 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5185 Cond = (chr_pp_not_in_store(H);Cond1),
5186 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5188 extract_explicit_matchings((A,B),D) :- !,
5189 ( extract_explicit_matchings(A) ->
5190 extract_explicit_matchings(B,D)
5191 ;
5192 D = (A,E),
5193 extract_explicit_matchings(B,E)
5194 ).
5195 extract_explicit_matchings(A,D) :- !,
5196 ( extract_explicit_matchings(A) ->
5197 D = true
5198 ;
5199 D = A
5200 ).
5202 extract_explicit_matchings(A=B) :-
5203 var(A), var(B), !, A=B.
5204 extract_explicit_matchings(A==B) :-
5205 var(A), var(B), !, A=B.
5207 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5208 % TYPE INFORMATION
5209 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5211 :- chr_constraint
5212 type_definition/2,
5213 type_alias/2,
5214 constraint_type/2,
5215 get_type_definition/2,
5216 get_constraint_type/2.
5219 :- chr_option(mode,type_definition(?,?)).
5220 :- chr_option(mode,get_type_definition(?,?)).
5221 :- chr_option(mode,type_alias(?,?)).
5222 :- chr_option(mode,constraint_type(+,+)).
5223 :- chr_option(mode,get_constraint_type(+,-)).
5225 assert_constraint_type(Constraint,ArgTypes) :-
5226 ( ground(ArgTypes) ->
5227 constraint_type(Constraint,ArgTypes)
5228 ;
5229 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5230 ).
5232 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5233 % Consistency checks of type aliases
5235 type_alias(T1,T2) <=>
5236 var(T1)
5237 |
5238 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5240 type_alias(T1,T2) <=>
5241 var(T2)
5242 |
5243 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5245 type_alias(T,T2) <=>
5246 functor(T,F,A),
5247 functor(T2,F,A),
5248 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5249 |
5250 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5252 type_alias(T1,A1), type_alias(T2,A2) <=>
5253 functor(T1,F,A),
5254 functor(T2,F,A),
5255 \+ (T1\=T2)
5256 |
5257 copy_term_nat(T1,T1_),
5258 copy_term_nat(T2,T2_),
5259 T1_ = T2_,
5260 chr_error(type_error,
5261 '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_]).
5263 type_alias(T,B) \ type_alias(X,T2) <=>
5264 functor(T,F,A),
5265 functor(T2,F,A),
5266 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5267 subsumes(T1,T3)
5268 |
5269 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5270 type_alias(X2,D1).
5272 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5273 % Consistency checks of type definitions
5275 type_definition(T1,_), type_definition(T2,_)
5276 <=>
5277 functor(T1,F,A), functor(T2,F,A)
5278 |
5279 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5281 type_definition(T1,_), type_alias(T2,_)
5282 <=>
5283 functor(T1,F,A), functor(T2,F,A)
5284 |
5285 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5287 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5288 %% get_type_definition(+Type,-Definition) is semidet.
5289 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5291 get_type_definition(T,Def)
5292 <=>
5293 \+ ground(T)
5294 |
5295 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5297 type_alias(T,D) \ get_type_definition(T2,Def)
5298 <=>
5299 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5300 copy_term_nat((T,D),(T1,D1)),T1=T2
5301 |
5302 ( get_type_definition(D1,Def) ->
5303 true
5304 ;
5305 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5306 ).
5308 type_definition(T,D) \ get_type_definition(T2,Def)
5309 <=>
5310 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5311 copy_term_nat((T,D),(T1,D1)),T1=T2
5312 |
5313 Def = D1.
5315 get_type_definition(Type,Def)
5316 <=>
5317 atomic_builtin_type(Type,_,_)
5318 |
5319 Def = [Type].
5321 get_type_definition(Type,Def)
5322 <=>
5323 compound_builtin_type(Type,_,_,_)
5324 |
5325 Def = [Type].
5327 get_type_definition(X,Y) <=> fail.
5329 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5330 %% get_type_definition_det(+Type,-Definition) is det.
5331 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5332 get_type_definition_det(Type,Definition) :-
5333 ( get_type_definition(Type,Definition) ->
5334 true
5335 ;
5336 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5337 ).
5339 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5340 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5341 %
5342 % Return argument types of =ConstraintSymbol=, but fails if none where
5343 % declared.
5344 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5345 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5346 get_constraint_type(_,_) <=> fail.
5348 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5349 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5350 %
5351 % Like =get_constraint_type/2=, but returns list of =any= types when
5352 % no types are declared.
5353 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5354 get_constraint_type_det(ConstraintSymbol,Types) :-
5355 ( get_constraint_type(ConstraintSymbol,Types) ->
5356 true
5357 ;
5358 ConstraintSymbol = _ / N,
5359 replicate(N,any,Types)
5360 ).
5361 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5362 %% unalias_type(+Alias,-Type) is det.
5363 %
5364 % Follows alias chain until base type is reached.
5365 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5366 :- chr_constraint unalias_type/2.
5368 unalias_var @
5369 unalias_type(Alias,BaseType)
5370 <=>
5371 var(Alias)
5372 |
5373 BaseType = Alias.
5375 unalias_alias @
5376 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5377 <=>
5378 nonvar(AliasProtoType),
5379 nonvar(Alias),
5380 functor(AliasProtoType,F,A),
5381 functor(Alias,F,A),
5382 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5383 Alias = AliasInstance
5384 |
5385 unalias_type(Type,BaseType).
5387 unalias_type_definition @
5388 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5389 <=>
5390 nonvar(ProtoType),
5391 nonvar(Alias),
5392 functor(ProtoType,F,A),
5393 functor(Alias,F,A)
5394 |
5395 BaseType = Alias.
5397 unalias_atomic_builtin @
5398 unalias_type(Alias,BaseType)
5399 <=>
5400 atomic_builtin_type(Alias,_,_)
5401 |
5402 BaseType = Alias.
5404 unalias_compound_builtin @
5405 unalias_type(Alias,BaseType)
5406 <=>
5407 compound_builtin_type(Alias,_,_,_)
5408 |
5409 BaseType = Alias.
5411 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5412 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5413 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5414 :- chr_constraint types_modes_condition/3.
5415 :- chr_option(mode,types_modes_condition(+,+,?)).
5416 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5418 types_modes_condition([],[],T) <=> T=true.
5420 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5421 <=>
5422 functor(Head,F,A)
5423 |
5424 Head =.. [_|Args],
5425 Condition = (ModesCondition, TypesCondition, RestCondition),
5426 modes_condition(Modes,Args,ModesCondition),
5427 get_constraint_type_det(F/A,Types),
5428 UnrollHead =.. [_|RealArgs],
5429 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5430 types_modes_condition(Heads,UnrollHeads,RestCondition).
5432 types_modes_condition([Head|_],_,_)
5433 <=>
5434 functor(Head,F,A),
5435 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5438 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5439 %% modes_condition(+Modes,+Args,-Condition) is det.
5440 %
5441 % Return =Condition= on =Args= that checks =Modes=.
5442 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5443 modes_condition([],[],true).
5444 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5445 ( Mode == (+) ->
5446 Condition = ( ground(Arg) , RCondition )
5447 ; Mode == (-) ->
5448 Condition = ( var(Arg) , RCondition )
5449 ;
5450 Condition = RCondition
5451 ),
5452 modes_condition(Modes,Args,RCondition).
5454 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5455 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5456 %
5457 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5458 % =UnrollArgs= controls the depth of type definition unrolling.
5459 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5460 types_condition([],[],[],[],true).
5461 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5462 ( Mode == (-) ->
5463 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5464 ;
5465 get_type_definition_det(Type,Def),
5466 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5467 ( Mode == (+) ->
5468 TypeConditionList = TypeConditionList1
5469 ;
5470 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5471 )
5472 ),
5473 list2disj(TypeConditionList,DisjTypeConditionList),
5474 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5476 type_condition([],_,_,_,[]).
5477 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5478 ( var(DefCase) ->
5479 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5480 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5481 true
5482 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5483 true
5484 ;
5485 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5486 ),
5487 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5489 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5490 :- chr_type atomic_builtin_type ---> any
5491 ; number
5492 ; float
5493 ; int
5494 ; natural
5495 ; dense_int
5496 ; chr_identifier
5497 ; chr_identifier(any)
5498 ; /* all possible values are given
5499 */
5500 chr_enum(list(any))
5501 ; /* all values of interest are given
5502 for the other values a handler is provided */
5503 chr_enum(list(any),any)
5504 ; /* all possible values appear in rule heads;
5505 to distinguish between multiple chr_constants
5506 we have a key*/
5507 chr_constants(any)
5508 ; /* all relevant values appear in rule heads;
5509 for other values a handler is provided */
5510 chr_constants(any,any).
5511 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5513 ast_atomic_builtin_type(Type,AstTerm,Goal) :-
5514 ast_term_to_term(AstTerm,Term),
5515 atomic_builtin_type(Type,Term,Goal).
5517 ast_compound_builtin_type(Type,AstTerm,Goal) :-
5518 ast_term_to_term(AstTerm,Term),
5519 compound_builtin_type(Type,Term,_,Goal).
5521 atomic_builtin_type(any,_Arg,true).
5522 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5523 atomic_builtin_type(int,Arg,integer(Arg)).
5524 atomic_builtin_type(number,Arg,number(Arg)).
5525 atomic_builtin_type(float,Arg,float(Arg)).
5526 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5527 atomic_builtin_type(chr_identifier,_Arg,true).
5529 compound_builtin_type(chr_constants(_),_Arg,true,true).
5530 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5531 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5532 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5533 once(( member(Constant,Constants),
5534 unifiable(Arg,Constant,_)
5535 )
5536 )
5537 ).
5538 compound_builtin_type(chr_enum(_,_),Arg,true,true).
5540 is_chr_constants_type(chr_constants(Key),Key,no).
5541 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5543 is_chr_enum_type(chr_enum(Constants), Constants, no).
5544 is_chr_enum_type(chr_enum(Constants,Handler), Constants, yes(Handler)).
5546 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5547 ( nonvar(DefCase) ->
5548 functor(DefCase,F,A),
5549 ( A == 0 ->
5550 Condition = (Arg = DefCase)
5551 ; var(UnrollArg) ->
5552 Condition = functor(Arg,F,A)
5553 ; functor(UnrollArg,F,A) ->
5554 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5555 DefCase =.. [_|ArgTypes],
5556 UnrollArg =.. [_|UnrollArgs],
5557 functor(Template,F,A),
5558 Template =.. [_|TemplateArgs],
5559 replicate(A,Mode,ArgModes),
5560 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5561 ;
5562 Condition = functor(Arg,F,A)
5563 )
5564 ;
5565 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5566 ).
5569 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5570 % STATIC TYPE CHECKING
5571 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5572 % Checks head constraints and CHR constraint calls in bodies.
5573 %
5574 % TODO:
5575 % - type clashes involving built-in types
5576 % - Prolog built-ins in guard and body
5577 % - indicate position in terms in error messages
5578 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5579 :- chr_constraint
5580 static_type_check/2.
5582 % 1. Check the declared types
5584 constraint_type(Constraint,ArgTypes), static_type_check(_,_)
5585 ==>
5586 forall(
5587 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5588 ( get_type_definition(Type,_) ->
5589 true
5590 ;
5591 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5592 )
5593 ).
5595 % 2. Check the rules
5597 :- chr_type type_error_src ---> head(any) ; body(any).
5599 static_type_check(PragmaRules,AstRules)
5600 <=>
5601 maplist(static_type_check_rule,PragmaRules,AstRules).
5603 static_type_check_rule(PragmaRule,AstRule) :-
5604 AstRule = ast_rule(AstHead,_AstGuard,_Guard,AstBody,_Body),
5605 (
5606 catch(
5607 ( ast_static_type_check_head(AstHead),
5608 ast_static_type_check_body(AstBody)
5609 ),
5610 type_error(Error),
5611 ( Error = invalid_functor(Src,Term,Type) ->
5612 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5613 [chr_translate:format_src(Src),format_rule(PragmaRule),Term,Type])
5614 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5615 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5616 [Var,format_rule(PragmaRule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5617 )
5618 ),
5619 fail % cleanup constraints
5620 ;
5621 true
5622 ).
5624 %------------------------------------------------------------------------------%
5625 % Static Type Checking: Head Constraints {{{
5626 ast_static_type_check_head(simplification(AstConstraints)) :-
5627 maplist(ast_static_type_check_head_constraint,AstConstraints).
5628 ast_static_type_check_head(propagation(AstConstraints)) :-
5629 maplist(ast_static_type_check_head_constraint,AstConstraints).
5630 ast_static_type_check_head(simpagation(AstConstraints1,AstConstraints2)) :-
5631 maplist(ast_static_type_check_head_constraint,AstConstraints1),
5632 maplist(ast_static_type_check_head_constraint,AstConstraints2).
5634 ast_static_type_check_head_constraint(AstConstraint) :-
5635 AstConstraint = chr_constraint(Symbol,Arguments,_),
5636 get_constraint_type_det(Symbol,Types),
5637 maplist(ast_static_type_check_term(head(Head)),Arguments,Types).
5638 % }}}
5639 %------------------------------------------------------------------------------%
5640 % Static Type Checking: Terms {{{
5641 :- chr_constraint ast_static_type_check_term/3.
5642 :- chr_option(mode,ast_static_type_check_term(?,?,?)).
5643 :- chr_option(type_declaration,ast_static_type_check_term(type_error_src,any,any)).
5645 ast_static_type_check_term(_,_,any)
5646 <=>
5647 true.
5649 ast_static_type_check_term(Src,var(Id,Var),Type)
5650 <=>
5651 ast_static_type_check_var(Id,var(Id,Var),Type,Src).
5653 ast_static_type_check_term(Src,Term,Type)
5654 <=>
5655 ast_atomic_builtin_type(Type,Term,Goal)
5656 |
5657 ( call(Goal) ->
5658 true
5659 ;
5660 throw(type_error(invalid_functor(Src,Term,Type)))
5661 ).
5662 ast_static_type_check_term(Src,Term,Type)
5663 <=>
5664 ast_compound_builtin_type(Type,Term,Goal)
5665 |
5666 ( call(Goal) ->
5667 true
5668 ;
5669 throw(type_error(invalid_functor(Src,Term,Type)))
5670 ).
5671 type_alias(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5672 <=>
5673 functor(Type,F,A),
5674 functor(AType,F,A)
5675 |
5676 copy_term_nat(AType-ADef,Type-Def),
5677 ast_static_type_check_term(Src,Term,Def).
5679 type_definition(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5680 <=>
5681 functor(Type,F,A),
5682 functor(AType,F,A)
5683 |
5684 copy_term_nat(AType-ADef,Type-Variants),
5685 ast_functor(Term,TF,TA),
5686 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5687 ast_args(Term,Args),
5688 Variant =.. [_|Types],
5689 maplist(ast_static_type_check_term(Src),Args,Types)
5690 ;
5691 throw(type_error(invalid_functor(Src,Term,Type)))
5692 ).
5694 ast_static_type_check_term(Src,Term,Type)
5695 <=>
5696 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5697 % }}}
5698 %------------------------------------------------------------------------------%
5699 % Static Type Checking: Variables {{{
5701 :- chr_constraint ast_static_type_check_var/4.
5702 :- chr_option(mode,ast_static_type_check_var(+,?,?,?)).
5703 :- chr_option(type_declaration,ast_static_type_check_var(var_id,any,any,type_error_src)).
5705 type_alias(AType,ADef) \ ast_static_type_check_var(VarId,Var,Type,Src)
5706 <=>
5707 functor(AType,F,A),
5708 functor(Type,F,A)
5709 |
5710 copy_term_nat(AType-ADef,Type-Def),
5711 ast_static_type_check_var(VarId,Var,Def,Src).
5713 ast_static_type_check_var(VarId,Var,Type,Src)
5714 <=>
5715 atomic_builtin_type(Type,_,_)
5716 |
5717 ast_static_atomic_builtin_type_check_var(VarId,Var,Type,Src).
5719 ast_static_type_check_var(VarId,Var,Type,Src)
5720 <=>
5721 compound_builtin_type(Type,_,_,_)
5722 |
5723 true.
5726 ast_static_type_check_var(VarId,Var,Type1,Src1), ast_static_type_check_var(VarId,_Var,Type2,Src2)
5727 <=>
5728 Type1 \== Type2
5729 |
5730 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5732 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5733 :- chr_constraint ast_static_atomic_builtin_type_check_var/4.
5734 :- chr_option(mode,ast_static_atomic_builtin_type_check_var(+,?,+,?)).
5735 :- chr_option(type_declaration,ast_static_atomic_builtin_type_check_var(var_id,any,atomic_builtin_type,type_error_src)).
5737 ast_static_atomic_builtin_type_check_var(_,_,any,_) <=> true.
5738 ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_)
5739 <=>
5740 true.
5741 ast_static_atomic_builtin_type_check_var(VarId,_,float,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5742 <=>
5743 true.
5744 ast_static_atomic_builtin_type_check_var(VarId,_,int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5745 <=>
5746 true.
5747 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5748 <=>
5749 true.
5750 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5751 <=>
5752 true.
5753 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5754 <=>
5755 true.
5756 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5757 <=>
5758 true.
5759 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,natural,_)
5760 <=>
5761 true.
5762 ast_static_atomic_builtin_type_check_var(VarId,Var,Type1,Src1), ast_static_atomic_builtin_type_check_var(VarId,_Var,Type2,Src2)
5763 <=>
5764 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5765 % }}}
5766 %------------------------------------------------------------------------------%
5767 % Static Type Checking: Bodies {{{
5768 ast_static_type_check_body([]).
5769 ast_static_type_check_body([Goal|Goals]) :-
5770 ast_symbol(Goal,Symbol),
5771 get_constraint_type_det(Symbol,Types),
5772 ast_args(Goal,Args),
5773 maplist(ast_static_type_check_term(body(Goal)),Args,Types),
5774 ast_static_type_check_body(Goals).
5776 % }}}
5777 %------------------------------------------------------------------------------%
5779 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5780 %% format_src(+type_error_src) is det.
5781 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5782 format_src(head(Head)) :- format('head ~w',[Head]).
5783 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5785 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5786 % Dynamic type checking
5787 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5789 :- chr_constraint
5790 dynamic_type_check/0,
5791 dynamic_type_check_clauses/1,
5792 get_dynamic_type_check_clauses/1.
5794 generate_dynamic_type_check_clauses(Clauses) :-
5795 ( chr_pp_flag(debugable,on) ->
5796 dynamic_type_check,
5797 get_dynamic_type_check_clauses(Clauses0),
5798 append(Clauses0,
5799 [('$dynamic_type_check'(Type,Term) :-
5800 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5801 )],
5802 Clauses)
5803 ;
5804 Clauses = []
5805 ).
5807 type_definition(T,D), dynamic_type_check
5808 ==>
5809 copy_term_nat(T-D,Type-Definition),
5810 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5811 dynamic_type_check_clauses(DynamicChecks).
5812 type_alias(A,B), dynamic_type_check
5813 ==>
5814 copy_term_nat(A-B,Alias-Body),
5815 dynamic_type_check_alias_clause(Alias,Body,Clause),
5816 dynamic_type_check_clauses([Clause]).
5818 dynamic_type_check <=>
5819 findall(
5820 ('$dynamic_type_check'(Type,Term) :- Goal),
5821 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5822 BuiltinChecks
5823 ),
5824 dynamic_type_check_clauses(BuiltinChecks).
5826 dynamic_type_check_clause(T,DC,Clause) :-
5827 copy_term(T-DC,Type-DefinitionClause),
5828 functor(DefinitionClause,F,A),
5829 functor(Term,F,A),
5830 DefinitionClause =.. [_|DCArgs],
5831 Term =.. [_|TermArgs],
5832 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5833 list2conj(RecursiveCallList,RecursiveCalls),
5834 Clause = (
5835 '$dynamic_type_check'(Type,Term) :-
5836 RecursiveCalls
5837 ).
5839 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5840 Clause = (
5841 '$dynamic_type_check'(Alias,Term) :-
5842 '$dynamic_type_check'(Body,Term)
5843 ).
5845 dynamic_type_check_call(Type,Term,Call) :-
5846 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5847 % Call = when(nonvar(Term),Goal)
5848 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5849 % Call = when(nonvar(Term),Goal)
5850 % ;
5851 ( Type == any ->
5852 Call = true
5853 ;
5854 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5855 )
5856 % )
5857 .
5859 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5860 <=>
5861 append(C1,C2,C),
5862 dynamic_type_check_clauses(C).
5864 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5865 <=>
5866 Q = C.
5867 get_dynamic_type_check_clauses(Q)
5868 <=>
5869 Q = [].
5871 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5872 % Atomic Types
5873 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5874 % Some optimizations can be applied for atomic types...
5875 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5877 atomic_types_suspended_constraint(C) :-
5878 C = _/N,
5879 get_constraint_type(C,ArgTypes),
5880 get_constraint_mode(C,ArgModes),
5881 numlist(1,N,Indexes),
5882 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5884 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5885 ( is_indexed_argument(C,Index) ->
5886 ( Mode == (?) ->
5887 atomic_type(Type)
5888 ;
5889 true
5890 )
5891 ;
5892 true
5893 ).
5895 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5896 %% atomic_type(+Type) is semidet.
5897 %
5898 % Succeeds when all values of =Type= are atomic.
5899 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5900 :- chr_constraint atomic_type/1.
5902 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5904 type_definition(TypePat,Def) \ atomic_type(Type)
5905 <=>
5906 functor(Type,F,A), functor(TypePat,F,A)
5907 |
5908 maplist(atomic,Def).
5910 type_alias(TypePat,Alias) \ atomic_type(Type)
5911 <=>
5912 functor(Type,F,A), functor(TypePat,F,A)
5913 |
5914 atomic(Alias),
5915 copy_term_nat(TypePat-Alias,Type-NType),
5916 atomic_type(NType).
5918 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5919 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5920 %
5921 % Succeeds when all values of =Type= are atomic
5922 % and the atom values are finitely enumerable.
5923 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5924 :- chr_constraint enumerated_atomic_type/2.
5926 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5928 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5929 <=>
5930 functor(Type,F,A), functor(TypePat,F,A)
5931 |
5932 maplist(atomic,Def),
5933 Atoms = Def.
5935 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5936 <=>
5937 functor(Type,F,A), functor(TypePat,F,A)
5938 |
5939 atomic(Alias),
5940 copy_term_nat(TypePat-Alias,Type-NType),
5941 enumerated_atomic_type(NType,Atoms).
5943 enumerated_atomic_type(_,_)
5944 <=>
5945 fail.
5946 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5948 :- chr_constraint
5949 stored/3, % constraint,occurrence,(yes/no/maybe)
5950 stored_completing/3,
5951 stored_complete/3,
5952 is_stored/1,
5953 is_finally_stored/1,
5954 check_all_passive/2.
5956 :- chr_option(mode,stored(+,+,+)).
5957 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5958 :- chr_type storedinfo ---> yes ; no ; maybe.
5959 :- chr_option(mode,stored_complete(+,+,+)).
5960 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5961 :- chr_option(mode,guard_list(+,+,+,+)).
5962 :- chr_option(mode,check_all_passive(+,+)).
5963 :- chr_option(type_declaration,check_all_passive(any,list)).
5965 % change yes in maybe when yes becomes passive
5966 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5967 stored(C,O,yes), stored_complete(C,RO,Yesses)
5968 <=> O < RO | NYesses is Yesses - 1,
5969 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5970 % change yes in maybe when not observed
5971 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5972 <=> O < RO |
5973 NYesses is Yesses - 1,
5974 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5976 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5977 ==> RO =< MO2 | % C2 is never stored
5978 passive(RuleNb,ID).
5983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5985 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5986 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5987 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5989 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5990 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5991 check_all_passive(RuleNb,IDs2).
5993 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5994 check_all_passive(RuleNb,IDs).
5996 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5997 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5999 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6001 % collect the storage information
6002 stored(C,O,yes) \ stored_completing(C,O,Yesses)
6003 <=> NO is O + 1, NYesses is Yesses + 1,
6004 stored_completing(C,NO,NYesses).
6005 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
6006 <=> NO is O + 1,
6007 stored_completing(C,NO,Yesses).
6009 stored(C,O,no) \ stored_completing(C,O,Yesses)
6010 <=> stored_complete(C,O,Yesses).
6011 stored_completing(C,O,Yesses)
6012 <=> stored_complete(C,O,Yesses).
6014 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
6015 O2 > O | passive(RuleNb,Id).
6017 % decide whether a constraint is stored
6018 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
6019 <=> RO =< MO | fail.
6020 is_stored(C) <=> true.
6022 % decide whether a constraint is suspends after occurrences
6023 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
6024 <=> RO =< MO | fail.
6025 is_finally_stored(C) <=> true.
6027 storage_analysis(Constraints) :-
6028 ( chr_pp_flag(storage_analysis,on) ->
6029 check_constraint_storages(Constraints)
6030 ;
6031 true
6032 ).
6034 check_constraint_storages(Symbols) :- maplist(check_constraint_storage,Symbols).
6036 check_constraint_storage(C) :-
6037 get_max_occurrence(C,MO),
6038 check_occurrences_storage(C,1,MO).
6040 check_occurrences_storage(C,O,MO) :-
6041 ( O > MO ->
6042 stored_completing(C,1,0)
6043 ;
6044 check_occurrence_storage(C,O),
6045 NO is O + 1,
6046 check_occurrences_storage(C,NO,MO)
6047 ).
6049 check_occurrence_storage(C,O) :-
6050 get_occurrence(C,O,RuleNb,ID,OccType),
6051 ( is_passive(RuleNb,ID) ->
6052 stored(C,O,maybe)
6053 ;
6054 get_rule(RuleNb,PragmaRule),
6055 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
6056 ( OccType == simplification, select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6057 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
6058 ; OccType == propagation, select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6059 check_storage_head2(Head2,O,Heads1,Body)
6060 )
6061 ).
6063 check_storage_head1(Head,O,H1,H2,G) :-
6064 functor(Head,F,A),
6065 C = F/A,
6066 ( H1 == [Head],
6067 H2 == [],
6068 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
6069 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
6070 Head =.. [_|L],
6071 no_matching(L,[]) ->
6072 stored(C,O,no)
6073 ;
6074 stored(C,O,maybe)
6075 ).
6077 no_matching([],_).
6078 no_matching([X|Xs],Prev) :-
6079 var(X),
6080 \+ memberchk_eq(X,Prev),
6081 no_matching(Xs,[X|Prev]).
6083 check_storage_head2(Head,O,H1,B) :-
6084 functor(Head,F,A),
6085 C = F/A,
6086 ( %(
6087 ( H1 \== [], B == true )
6088 %;
6089 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
6090 %)
6091 ->
6092 stored(C,O,maybe)
6093 ;
6094 stored(C,O,yes)
6095 ).
6097 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6099 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6100 %% ____ _ ____ _ _ _ _
6101 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
6102 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
6103 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
6104 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
6105 %% |_|
6107 constraints_code(Constraints,Clauses) :-
6108 (chr_pp_flag(reduced_indexing,on),
6109 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
6110 none_suspended_on_variables
6111 ;
6112 true
6113 ),
6114 constraints_code1(Constraints,Clauses,[]).
6116 %===============================================================================
6117 :- chr_constraint constraints_code1/3.
6118 :- chr_option(mode,constraints_code1(+,+,+)).
6119 :- chr_option(type_declaration,constraints_code1(list,any,any)).
6120 %-------------------------------------------------------------------------------
6121 constraints_code1([],L,T) <=> L = T.
6122 constraints_code1([C|RCs],L,T)
6123 <=>
6124 constraint_code(C,L,T1),
6125 constraints_code1(RCs,T1,T).
6126 %===============================================================================
6127 :- chr_constraint constraint_code/3.
6128 :- chr_option(mode,constraint_code(+,+,+)).
6129 %-------------------------------------------------------------------------------
6130 %% Generate code for a single CHR constraint
6131 constraint_code(Constraint, L, T)
6132 <=> true
6133 | ( (chr_pp_flag(debugable,on) ;
6134 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
6135 ( may_trigger(Constraint) ;
6136 get_allocation_occurrence(Constraint,AO),
6137 get_max_occurrence(Constraint,MO), MO >= AO ) )
6138 ->
6139 constraint_prelude(Constraint,Clause),
6140 add_dummy_location(Clause,LocatedClause),
6141 L = [LocatedClause | L1]
6142 ;
6143 L = L1
6144 ),
6145 Id = [0],
6146 occurrences_code(Constraint,1,Id,NId,L1,L2),
6147 gen_cond_attach_clause(Constraint,NId,L2,T).
6149 %===============================================================================
6150 %% Generate prelude predicate for a constraint.
6151 %% f(...) :- f/a_0(...,Susp).
6152 constraint_prelude(F/A, Clause) :-
6153 vars_susp(A,Vars,Susp,VarsSusp),
6154 Head =.. [ F | Vars],
6155 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6156 build_head(F,A,[0],VarsSusp,Delegate),
6157 ( chr_pp_flag(debugable,on) ->
6158 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6159 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6160 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6161 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6163 ( get_constraint_type(F/A,ArgTypeList) ->
6164 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6165 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6166 ;
6167 DynamicTypeChecks = true
6168 ),
6170 Clause =
6171 ( Head :-
6172 DynamicTypeChecks,
6173 InsertGoal,
6174 InsertCall,
6175 AttachCall,
6176 Inactive,
6177 'chr debug_event'(insert(Head#Susp)),
6178 (
6179 'chr debug_event'(call(Susp)),
6180 Delegate
6181 ;
6182 'chr debug_event'(fail(Susp)), !,
6183 fail
6184 ),
6185 (
6186 'chr debug_event'(exit(Susp))
6187 ;
6188 'chr debug_event'(redo(Susp)),
6189 fail
6190 )
6191 )
6192 ; get_allocation_occurrence(F/A,0) ->
6193 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6194 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6195 Clause = ( Head :- Goal, Inactive, Delegate )
6196 ;
6197 Clause = ( Head :- Delegate )
6198 ).
6200 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6201 ( may_trigger(F/A) ->
6202 build_head(F,A,[0],VarsSusp,Delegate),
6203 ( chr_pp_flag(debugable,off) ->
6204 Goal = Delegate
6205 ;
6206 get_target_module(Mod),
6207 Goal = Mod:Delegate
6208 )
6209 ;
6210 Goal = true
6211 ).
6213 %===============================================================================
6214 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6215 :- chr_option(mode,has_active_occurrence(+)).
6216 :- chr_option(mode,has_active_occurrence(+,+)).
6218 :- chr_constraint memo_has_active_occurrence/1.
6219 :- chr_option(mode,memo_has_active_occurrence(+)).
6220 %-------------------------------------------------------------------------------
6221 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6222 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6224 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6225 O > MO | fail.
6226 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6227 has_active_occurrence(C,O) <=>
6228 NO is O + 1,
6229 has_active_occurrence(C,NO).
6230 has_active_occurrence(C,O) <=> true.
6231 %===============================================================================
6233 gen_cond_attach_clause(F/A,Id,L,T) :-
6234 ( is_finally_stored(F/A) ->
6235 get_allocation_occurrence(F/A,AllocationOccurrence),
6236 get_max_occurrence(F/A,MaxOccurrence),
6237 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6238 ( only_ground_indexed_arguments(F/A) ->
6239 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6240 ;
6241 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6242 )
6243 ; vars_susp(A,Args,Susp,AllArgs),
6244 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6245 ),
6246 build_head(F,A,Id,AllArgs,Head),
6247 Clause = ( Head :- Body ),
6248 add_dummy_location(Clause,LocatedClause),
6249 L = [LocatedClause | T]
6250 ;
6251 L = T
6252 ).
6254 :- chr_constraint use_auxiliary_predicate/1.
6255 :- chr_option(mode,use_auxiliary_predicate(+)).
6257 :- chr_constraint use_auxiliary_predicate/2.
6258 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6260 :- chr_constraint is_used_auxiliary_predicate/1.
6261 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6263 :- chr_constraint is_used_auxiliary_predicate/2.
6264 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6267 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6269 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6271 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6273 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6275 is_used_auxiliary_predicate(P) <=> fail.
6277 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6278 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6280 is_used_auxiliary_predicate(P,C) <=> fail.
6282 %------------------------------------------------------------------------------%
6283 % Only generate import statements for actually used modules.
6284 %------------------------------------------------------------------------------%
6286 :- chr_constraint use_auxiliary_module/1.
6287 :- chr_option(mode,use_auxiliary_module(+)).
6289 :- chr_constraint is_used_auxiliary_module/1.
6290 :- chr_option(mode,is_used_auxiliary_module(+)).
6293 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6295 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6297 is_used_auxiliary_module(P) <=> fail.
6299 % only called for constraints with
6300 % at least one
6301 % non-ground indexed argument
6302 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6303 vars_susp(A,Args,Susp,AllArgs),
6304 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6305 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6306 Attach = true
6307 ;
6308 attach_constraint_atom(F/A,Vars,Susp,Attach)
6309 ),
6310 FTerm =.. [F|Args],
6311 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6312 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6313 ( may_trigger(F/A) ->
6314 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6315 Goal =
6316 (
6317 ( var(Susp) ->
6318 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6319 InsertCall,
6320 Attach
6321 ;
6322 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6323 )
6324 )
6325 ;
6326 Goal =
6327 (
6328 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6329 InsertCall,
6330 Attach
6331 )
6332 ).
6334 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6335 vars_susp(A,Args,Susp,AllArgs),
6336 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6337 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6338 attach_constraint_atom(F/A,Vars,Susp,Attach)
6339 ;
6340 Attach = true
6341 ),
6342 FTerm =.. [F|Args],
6343 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6344 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6345 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6346 Goal =
6347 (
6348 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6349 InsertCall
6350 )
6351 ;
6352 Goal =
6353 (
6354 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6355 InsertCall,
6356 Attach
6357 )
6358 ).
6360 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6361 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6362 attach_constraint_atom(FA,Vars,Susp,Attach)
6363 ;
6364 Attach = true
6365 ),
6366 insert_constraint_goal(FA,Susp,Args,InsertCall),
6367 ( chr_pp_flag(late_allocation,on) ->
6368 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6369 ;
6370 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6371 ).
6373 %-------------------------------------------------------------------------------
6374 :- chr_constraint occurrences_code/6.
6375 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6376 %-------------------------------------------------------------------------------
6377 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6378 <=> O > MO
6379 | NId = Id, L = T.
6380 occurrences_code(C,O,Id,NId,L,T)
6381 <=>
6382 occurrence_code(C,O,Id,Id1,L,L1),
6383 NO is O + 1,
6384 occurrences_code(C,NO,Id1,NId,L1,T).
6385 %-------------------------------------------------------------------------------
6386 :- chr_constraint occurrence_code/6.
6387 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6388 %-------------------------------------------------------------------------------
6389 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6390 <=>
6391 ( named_history(RuleNb,_,_) ->
6392 does_use_history(C,O)
6393 ;
6394 true
6395 ),
6396 NId = Id,
6397 L = T.
6398 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6399 <=> true |
6400 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6401 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6402 NId = Id,
6403 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6404 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6406 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6407 ( should_skip_to_next_id(C,O) ->
6408 inc_id(Id,NId),
6409 ( unconditional_occurrence(C,O) ->
6410 L1 = T
6411 ;
6412 gen_alloc_inc_clause(C,O,Id,L1,T)
6413 )
6414 ;
6415 NId = Id,
6416 L1 = T
6417 )
6418 ).
6420 occurrence_code(C,O,_,_,_,_)
6421 <=>
6422 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6423 %-------------------------------------------------------------------------------
6425 %% Generate code based on one removed head of a CHR rule
6426 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6427 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6428 Rule = rule(_,Head2,_,_),
6429 ( Head2 == [] ->
6430 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6431 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6432 ;
6433 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6434 ).
6436 %% Generate code based on one persistent head of a CHR rule
6437 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6438 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6439 Rule = rule(Head1,_,_,_),
6440 ( Head1 == [] ->
6441 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6442 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6443 ;
6444 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6445 ).
6447 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6448 vars_susp(A,Vars,Susp,VarsSusp),
6449 build_head(F,A,Id,VarsSusp,Head),
6450 inc_id(Id,IncId),
6451 build_head(F,A,IncId,VarsSusp,CallHead),
6452 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6453 Clause =
6454 (
6455 Head :-
6456 ConditionalAlloc,
6457 CallHead
6458 ),
6459 add_dummy_location(Clause,LocatedClause),
6460 L = [LocatedClause|T].
6462 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6463 get_allocation_occurrence(FA,AO),
6464 get_occurrence_code_id(FA,AO,AId),
6465 get_occurrence_code_id(FA,O,Id),
6466 ( chr_pp_flag(debugable,off), Id == AId ->
6467 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6468 ( may_trigger(FA) ->
6469 Goal = (var(Susp) -> Goal0 ; true)
6470 ;
6471 Goal = Goal0
6472 )
6473 ;
6474 Goal = true
6475 ).
6477 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6478 get_allocation_occurrence(FA,AO),
6479 ( chr_pp_flag(debugable,off), O < AO ->
6480 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6481 ( may_trigger(FA) ->
6482 Goal = (var(Susp) -> Goal0 ; true)
6483 ;
6484 Goal = Goal0
6485 )
6486 ;
6487 Goal = true
6488 ).
6490 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6492 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6493 %
6494 % Reorders guard goals with respect to partner constraint retrieval goals and
6495 % active constraint. Returns combined partner retrieval + guard goal.
6497 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6498 ( chr_pp_flag(guard_via_reschedule,on) ->
6499 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6500 list2conj(ScheduleSkeleton,GoalSkeleton)
6501 ;
6502 length(Retrievals,RL), length(LookupSkeleton,RL),
6503 length(GuardList,GL), length(GuardListSkeleton,GL),
6504 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6505 list2conj(GoalListSkeleton,GoalSkeleton)
6506 ).
6507 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6508 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6509 initialize_unit_dictionary(ActiveHead,Dict),
6510 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6511 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6512 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6513 dependency_reorder(Units,NUnits),
6514 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6515 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6516 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6518 wrappedunits2lists([],[],[],[]).
6519 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6520 Ss = [GoalCopy|TSs],
6521 ( WrappedGoal = lookup(Goal) ->
6522 Ls = [GoalCopy|TLs],
6523 Gs = TGs
6524 ; WrappedGoal = guard(Goal) ->
6525 Gs = [N-GoalCopy|TGs],
6526 Ls = TLs
6527 ),
6528 wrappedunits2lists(Units,TGs,TLs,TSs).
6530 guard_splitting(Rule,SplitGuardList) :-
6531 Rule = rule(H1,H2,Guard,_),
6532 append(H1,H2,Heads),
6533 conj2list(Guard,GuardList),
6534 term_variables(Heads,HeadVars),
6535 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6536 append(GuardPrefix,[RestGuard],SplitGuardList),
6537 term_variables(RestGuardList,GuardVars1),
6538 % variables that are declared to be ground don't need to be locked
6539 ground_vars(Heads,GroundVars),
6540 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6541 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6542 maplist(chr_lock,GuardVars,Locks),
6543 maplist(chr_unlock,GuardVars,Unlocks),
6544 list2conj(Locks,LockPhase),
6545 list2conj(Unlocks,UnlockPhase),
6546 list2conj(RestGuardList,RestGuard1),
6547 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6549 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6550 Rule = rule(_,_,_,Body),
6551 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6552 my_term_copy(Body,VarDict2,BodyCopy).
6555 split_off_simple_guard_new([],_,[],[]).
6556 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6557 ( simple_guard_new(G,VarDict) ->
6558 S = [G|Ss],
6559 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6560 ;
6561 S = [],
6562 C = [G|Gs]
6563 ).
6565 % simple guard: cheap and benign (does not bind variables)
6566 simple_guard_new(G,Vars) :-
6567 builtin_binds_b(G,BoundVars),
6568 not(( member(V,BoundVars),
6569 memberchk_eq(V,Vars)
6570 )).
6572 dependency_reorder(Units,NUnits) :-
6573 dependency_reorder(Units,[],NUnits).
6575 dependency_reorder([],Acc,Result) :-
6576 reverse(Acc,Result).
6578 dependency_reorder([Unit|Units],Acc,Result) :-
6579 Unit = unit(_GID,_Goal,Type,GIDs),
6580 ( Type == fixed ->
6581 NAcc = [Unit|Acc]
6582 ;
6583 dependency_insert(Acc,Unit,GIDs,NAcc)
6584 ),
6585 dependency_reorder(Units,NAcc,Result).
6587 dependency_insert([],Unit,_,[Unit]).
6588 dependency_insert([X|Xs],Unit,GIDs,L) :-
6589 X = unit(GID,_,_,_),
6590 ( memberchk(GID,GIDs) ->
6591 L = [Unit,X|Xs]
6592 ;
6593 L = [X | T],
6594 dependency_insert(Xs,Unit,GIDs,T)
6595 ).
6597 build_units(Retrievals,Guard,InitialDict,Units) :-
6598 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6599 build_guard_units(Guard,N,Dict,Tail).
6601 build_retrieval_units([],N,N,Dict,Dict,L,L).
6602 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6603 term_variables(U,Vs),
6604 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6605 L = [unit(N,U,fixed,GIDs)|L1],
6606 N1 is N + 1,
6607 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6609 initialize_unit_dictionary(Term,Dict) :-
6610 term_variables(Term,Vars),
6611 pair_all_with(Vars,0,Dict).
6613 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6614 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6615 ( lookup_eq(Dict,V,GID) ->
6616 ( (GID == This ; memberchk(GID,GIDs) ) ->
6617 GIDs1 = GIDs
6618 ;
6619 GIDs1 = [GID|GIDs]
6620 ),
6621 Dict1 = Dict
6622 ;
6623 Dict1 = [V - This|Dict],
6624 GIDs1 = GIDs
6625 ),
6626 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6628 build_guard_units(Guard,N,Dict,Units) :-
6629 ( Guard = [Goal] ->
6630 Units = [unit(N,Goal,fixed,[])]
6631 ; Guard = [Goal|Goals] ->
6632 term_variables(Goal,Vs),
6633 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6634 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6635 N1 is N + 1,
6636 build_guard_units(Goals,N1,NDict,RUnits)
6637 ).
6639 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6640 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6641 ( lookup_eq(Dict,V,GID) ->
6642 ( (GID == This ; memberchk(GID,GIDs) ) ->
6643 GIDs1 = GIDs
6644 ;
6645 GIDs1 = [GID|GIDs]
6646 ),
6647 Dict1 = [V - This|Dict]
6648 ;
6649 Dict1 = [V - This|Dict],
6650 GIDs1 = GIDs
6651 ),
6652 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6654 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6657 %% ____ _ ____ _ _
6658 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6659 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6660 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6661 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6662 %%
6663 %% _ _ _ ___ __
6664 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6665 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6666 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6667 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6668 %% |_|
6669 :- chr_constraint
6670 functional_dependency/4,
6671 get_functional_dependency/4.
6673 :- chr_option(mode,functional_dependency(+,+,?,?)).
6674 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6676 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6677 <=>
6678 RuleNb > 1, AO > O
6679 |
6680 functional_dependency(C,1,Pattern,Key).
6682 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6683 <=>
6684 RuleNb2 >= RuleNb1
6685 |
6686 QPattern = Pattern, QKey = Key.
6687 get_functional_dependency(_,_,_,_)
6688 <=>
6689 fail.
6691 functional_dependency_analysis(Rules) :-
6692 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6693 functional_dependency_analysis_main(Rules)
6694 ;
6695 true
6696 ).
6698 functional_dependency_analysis_main([]).
6699 functional_dependency_analysis_main([PRule|PRules]) :-
6700 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6701 functional_dependency(C,RuleNb,Pattern,Key)
6702 ;
6703 true
6704 ),
6705 functional_dependency_analysis_main(PRules).
6707 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6708 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6709 Rule = rule(H1,H2,Guard,_),
6710 ( H1 = [C1],
6711 H2 = [C2] ->
6712 true
6713 ; H1 = [C1,C2],
6714 H2 == [] ->
6715 true
6716 ),
6717 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6718 term_variables(C1,Vs),
6719 \+ (
6720 member(V1,Vs),
6721 lookup_eq(List,V1,V2),
6722 memberchk_eq(V2,Vs)
6723 ),
6724 select_pragma_unique_variables(Vs,List,Key1),
6725 copy_term_nat(C1-Key1,Pattern-Key),
6726 functor(C1,F,A).
6728 select_pragma_unique_variables([],_,[]).
6729 select_pragma_unique_variables([V|Vs],List,L) :-
6730 ( lookup_eq(List,V,_) ->
6731 L = T
6732 ;
6733 L = [V|T]
6734 ),
6735 select_pragma_unique_variables(Vs,List,T).
6737 % depends on functional dependency analysis
6738 % and shape of rule: C1 \ C2 <=> true.
6739 set_semantics_rules(Rules) :-
6740 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6741 set_semantics_rules_main(Rules)
6742 ;
6743 true
6744 ).
6746 set_semantics_rules_main([]).
6747 set_semantics_rules_main([R|Rs]) :-
6748 set_semantics_rule_main(R),
6749 set_semantics_rules_main(Rs).
6751 set_semantics_rule_main(PragmaRule) :-
6752 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6753 ( Rule = rule([C1],[C2],true,_),
6754 IDs = ids([ID1],[ID2]),
6755 \+ is_passive(RuleNb,ID1),
6756 functor(C1,F,A),
6757 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6758 copy_term_nat(Pattern-Key,C1-Key1),
6759 copy_term_nat(Pattern-Key,C2-Key2),
6760 Key1 == Key2 ->
6761 passive(RuleNb,ID2)
6762 ;
6763 true
6764 ).
6766 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6767 \+ any_passive_head(RuleNb),
6768 variable_replacement(C1-C2,C2-C1,List),
6769 copy_with_variable_replacement(G,OtherG,List),
6770 negate_b(G,NotG),
6771 once(entails_b(NotG,OtherG)).
6773 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6774 % where C1 and C2 are symmteric constraints
6775 symmetry_analysis(Rules) :-
6776 ( chr_pp_flag(check_unnecessary_active,off) ->
6777 true
6778 ;
6779 symmetry_analysis_main(Rules)
6780 ).
6782 symmetry_analysis_main([]).
6783 symmetry_analysis_main([R|Rs]) :-
6784 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6785 Rule = rule(H1,H2,_,_),
6786 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6787 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6788 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6789 ;
6790 true
6791 ),
6792 symmetry_analysis_main(Rs).
6794 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6795 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6796 ( \+ is_passive(RuleNb,ID),
6797 member2(PreHs,PreIDs,PreH-PreID),
6798 \+ is_passive(RuleNb,PreID),
6799 variable_replacement(PreH,H,List),
6800 copy_with_variable_replacement(Rule,Rule2,List),
6801 identical_guarded_rules(Rule,Rule2) ->
6802 passive(RuleNb,ID)
6803 ;
6804 true
6805 ),
6806 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6808 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6809 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6810 ( \+ is_passive(RuleNb,ID),
6811 member2(PreHs,PreIDs,PreH-PreID),
6812 \+ is_passive(RuleNb,PreID),
6813 variable_replacement(PreH,H,List),
6814 copy_with_variable_replacement(Rule,Rule2,List),
6815 identical_rules(Rule,Rule2) ->
6816 passive(RuleNb,ID)
6817 ;
6818 true
6819 ),
6820 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6822 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6824 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6825 %% ____ _ _ _ __ _ _ _
6826 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6827 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6828 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6829 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6830 %% |_|
6831 %% {{{
6833 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,Symbol,O,Id,L,T) :-
6834 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6835 head_info1(Head,Symbol,_Vars,Susp,HeadVars,HeadPairs),
6836 build_head(Symbol,Id,HeadVars,ClauseHead),
6837 get_constraint_mode(Symbol,Mode),
6838 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6841 guard_splitting(Rule,GuardList0),
6842 ( is_stored_in_guard(Symbol, RuleNb) ->
6843 GuardList = [Hole1|GuardList0]
6844 ;
6845 GuardList = GuardList0
6846 ),
6847 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6849 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6851 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6853 ( is_stored_in_guard(Symbol, RuleNb) ->
6854 gen_occ_allocation_in_guard(Symbol,O,Vars,Susp,Allocation),
6855 gen_uncond_attach_goal(Symbol,Susp,Vars,Attachment,_),
6856 GuardCopyList = [Hole1Copy|_],
6857 Hole1Copy = (Allocation, Attachment)
6858 ;
6859 true
6860 ),
6863 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6864 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6866 ( chr_pp_flag(debugable,on) ->
6867 Rule = rule(_,_,Guard,Body),
6868 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6869 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6870 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6871 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6872 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6873 ;
6874 Cut = ActualCut
6875 ),
6876 actual_cut(Symbol,O,ActualCut),
6877 Clause = ( ClauseHead :-
6878 FirstMatching,
6879 RescheduledTest,
6880 Cut,
6881 SuspsDetachments,
6882 SuspDetachment,
6883 BodyCopy
6884 ),
6885 add_location(Clause,RuleNb,LocatedClause),
6886 L = [LocatedClause | T].
6888 actual_cut(Symbol,Occurrence,ActualCut) :-
6889 ( unconditional_occurrence(Symbol,Occurrence),
6890 chr_pp_flag(late_allocation,on) ->
6891 ActualCut = true
6892 ;
6893 ActualCut = (!)
6894 ).
6895 % }}}
6897 add_location(Clause,RuleNb,NClause) :-
6898 ( chr_pp_flag(line_numbers,on) ->
6899 get_chr_source_file(File),
6900 get_line_number(RuleNb,LineNb),
6901 NClause = '$source_location'(File,LineNb):Clause
6902 ;
6903 NClause = Clause
6904 ).
6906 add_dummy_location(Clause,NClause) :-
6907 ( chr_pp_flag(line_numbers,on) ->
6908 get_chr_source_file(File),
6909 NClause = '$source_location'(File,1):Clause
6910 ;
6911 NClause = Clause
6912 ).
6913 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6914 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6915 %
6916 % Return goal matching newly introduced variables with variables in
6917 % previously looked-up heads.
6918 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6919 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6920 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6922 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6923 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6924 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6925 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6926 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6927 list2conj(GoalList,Goal).
6929 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6930 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6931 ( Mode == (+) ->
6932 term_variables(Arg,GroundVars0,GroundVars),
6933 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6934 ;
6935 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6936 ).
6937 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6938 ( var(Arg) ->
6939 ( lookup_eq(VarDict,Arg,OtherVar) ->
6940 ( Mode = (+) ->
6941 ( memberchk_eq(Arg,GroundVars) ->
6942 GoalList = [Var = OtherVar | RestGoalList],
6943 GroundVars1 = GroundVars
6944 ;
6945 GoalList = [Var == OtherVar | RestGoalList],
6946 GroundVars1 = [Arg|GroundVars]
6947 )
6948 ;
6949 GoalList = [Var == OtherVar | RestGoalList],
6950 GroundVars1 = GroundVars
6951 ),
6952 VarDict1 = VarDict
6953 ;
6954 VarDict1 = [Arg-Var | VarDict],
6955 GoalList = RestGoalList,
6956 ( Mode = (+) ->
6957 GroundVars1 = [Arg|GroundVars]
6958 ;
6959 GroundVars1 = GroundVars
6960 )
6961 ),
6962 Pairs = Rest,
6963 RestModes = Modes
6964 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6965 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6966 GoalList = [Goal|RestGoalList],
6967 VarDict = VarDict1,
6968 GroundVars1 = GroundVars,
6969 Pairs = Rest,
6970 RestModes = Modes
6971 ; atomic(Arg) ->
6972 ( Mode = (+) ->
6973 GoalList = [ Var = Arg | RestGoalList]
6974 ;
6975 GoalList = [ Var == Arg | RestGoalList]
6976 ),
6977 VarDict = VarDict1,
6978 GroundVars1 = GroundVars,
6979 Pairs = Rest,
6980 RestModes = Modes
6981 ; Mode == (+), is_ground(GroundVars,Arg) ->
6982 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6983 GoalList = [ Var = ArgCopy | RestGoalList],
6984 VarDict = VarDict1,
6985 GroundVars1 = GroundVars,
6986 Pairs = Rest,
6987 RestModes = Modes
6988 ; Mode == (?), is_ground(GroundVars,Arg) ->
6989 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6990 GoalList = [ Var == ArgCopy | RestGoalList],
6991 VarDict = VarDict1,
6992 GroundVars1 = GroundVars,
6993 Pairs = Rest,
6994 RestModes = Modes
6995 ; Arg =.. [_|Args],
6996 functor(Arg,Fct,N),
6997 functor(Term,Fct,N),
6998 Term =.. [_|Vars],
6999 ( Mode = (+) ->
7000 GoalList = [ Var = Term | RestGoalList ]
7001 ;
7002 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
7003 ),
7004 pairup(Args,Vars,NewPairs),
7005 append(NewPairs,Rest,Pairs),
7006 replicate(N,Mode,NewModes),
7007 append(NewModes,Modes,RestModes),
7008 VarDict1 = VarDict,
7009 GroundVars1 = GroundVars
7010 ),
7011 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
7013 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7014 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
7015 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7016 add_heads_types([],VarTypes,VarTypes).
7017 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
7018 add_head_types(Head,VarTypes,VarTypes1),
7019 add_heads_types(Heads,VarTypes1,NVarTypes).
7021 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7022 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
7023 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7024 add_head_types(Head,VarTypes,NVarTypes) :-
7025 functor(Head,F,A),
7026 get_constraint_type_det(F/A,ArgTypes),
7027 Head =.. [_|Args],
7028 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
7030 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7031 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
7032 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7033 add_args_types([],[],VarTypes,VarTypes).
7034 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
7035 add_arg_types(Arg,Type,VarTypes,VarTypes1),
7036 add_args_types(Args,Types,VarTypes1,NVarTypes).
7038 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7039 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
7040 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7041 % OPTIMIZATION: don't add if `any'
7042 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
7043 ( Type == any ->
7044 NVarTypes = VarTypes
7045 ; var(Term) ->
7046 ( lookup_eq(VarTypes,Term,_) ->
7047 NVarTypes = VarTypes
7048 ;
7049 NVarTypes = [Term-Type|VarTypes]
7050 )
7051 ; % nonvar
7052 NVarTypes = VarTypes % approximate with any
7053 ).
7057 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7058 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
7059 %
7060 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7061 add_heads_ground_variables([],GroundVars,GroundVars).
7062 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
7063 add_head_ground_variables(Head,GroundVars,GroundVars1),
7064 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
7066 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7067 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
7068 %
7069 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7070 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
7071 functor(Head,F,A),
7072 get_constraint_mode(F/A,ArgModes),
7073 Head =.. [_|Args],
7074 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
7077 add_arg_ground_variables([],[],GroundVars,GroundVars).
7078 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
7079 ( Mode == (+) ->
7080 term_variables(Arg,Vars),
7081 add_var_ground_variables(Vars,GroundVars,GroundVars1)
7082 ;
7083 GroundVars = GroundVars1
7084 ),
7085 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
7087 add_var_ground_variables([],GroundVars,GroundVars).
7088 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
7089 ( memberchk_eq(Var,GroundVars) ->
7090 GroundVars1 = GroundVars
7091 ;
7092 GroundVars1 = [Var|GroundVars]
7093 ),
7094 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
7095 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7096 %% is_ground(+GroundVars,+Term) is semidet.
7097 %
7098 % Determine whether =Term= is always ground.
7099 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7100 is_ground(GroundVars,Term) :-
7101 ( ground(Term) ->
7102 true
7103 ; compound(Term) ->
7104 Term =.. [_|Args],
7105 maplist(is_ground(GroundVars),Args)
7106 ;
7107 memberchk_eq(Term,GroundVars)
7108 ).
7110 %% check_ground(+GroundVars,+Term,-Goal) is det.
7111 %
7112 % Return runtime check to see whether =Term= is ground.
7113 check_ground(GroundVars,Term,Goal) :-
7114 term_variables(Term,Variables),
7115 check_ground_variables(Variables,GroundVars,Goal).
7117 check_ground_variables([],_,true).
7118 check_ground_variables([Var|Vars],GroundVars,Goal) :-
7119 ( memberchk_eq(Var,GroundVars) ->
7120 check_ground_variables(Vars,GroundVars,Goal)
7121 ;
7122 Goal = (ground(Var), RGoal),
7123 check_ground_variables(Vars,GroundVars,RGoal)
7124 ).
7126 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
7127 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
7129 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
7130 ( Heads = [_|_] ->
7131 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
7132 ;
7133 GoalList = [],
7134 Susps = [],
7135 VarDict = NVarDict,
7136 GroundVars = NGroundVars
7137 ).
7139 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
7140 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
7141 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
7142 functor(H,F,A),
7143 head_info(H,A,Vars,_,_,Pairs),
7144 get_store_type(F/A,StoreType),
7145 ( StoreType == default ->
7146 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
7147 delay_phase_end(validate_store_type_assumptions,
7148 ( static_suspension_term(F/A,Suspension),
7149 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
7150 get_static_suspension_field(F/A,Suspension,state,active,GetState)
7151 )
7152 ),
7153 % create_get_mutable_ref(active,State,GetMutable),
7154 get_constraint_mode(F/A,Mode),
7155 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7156 NPairs = Pairs,
7157 sbag_member_call(Susp,VarSusps,Sbag),
7158 ExistentialLookup = (
7159 ViaGoal,
7160 Sbag,
7161 Susp = Suspension, % not inlined
7162 GetState
7163 ),
7164 inline_matching_goal(MatchingGoal,MatchingGoal2)
7165 ;
7166 delay_phase_end(validate_store_type_assumptions,
7167 ( static_suspension_term(F/A,Suspension),
7168 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7169 )
7170 ),
7171 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7172 get_constraint_mode(F/A,Mode),
7173 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7174 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7175 filter_append(NPairs,VarDict1,DA_), % order important here
7176 translate(GroundVars1,DA_,GroundVarsA),
7177 translate(GroundVars1,VarDict1,GroundVarsB),
7178 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB)
7179 ),
7180 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7181 Goal =
7182 (
7183 ExistentialLookup,
7184 DiffSuspGoals,
7185 MatchingGoal2
7186 ),
7187 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7189 inline_matching_goal(G1,G2) :-
7190 inline_matching_goal(G1,G2,[],[]).
7192 inline_matching_goal(A==B,true,GVA,GVB) :-
7193 memberchk_eq(A,GVA),
7194 memberchk_eq(B,GVB),
7195 A=B, !.
7196 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7197 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7198 inline_matching_goal(A,A2,GVA,GVB),
7199 inline_matching_goal(B,B2,GVA,GVB).
7200 inline_matching_goal(X,X,_,_).
7203 filter_mode([],_,_,[]).
7204 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7205 ( Var == V ->
7206 Modes = [M|MT],
7207 filter_mode(Rest,R,Ms,MT)
7208 ;
7209 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7210 ).
7212 filter_append([],VarDict,VarDict).
7213 filter_append([X|Xs],VarDict,NVarDict) :-
7214 ( X = silent(_) ->
7215 filter_append(Xs,VarDict,NVarDict)
7216 ;
7217 NVarDict = [X|NVarDict0],
7218 filter_append(Xs,VarDict,NVarDict0)
7219 ).
7221 check_unique_keys([],_).
7222 check_unique_keys([V|Vs],Dict) :-
7223 lookup_eq(Dict,V,_),
7224 check_unique_keys(Vs,Dict).
7226 % Generates tests to ensure the found constraint differs from previously found constraints
7227 % TODO: detect more cases where constraints need be different
7228 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7229 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7230 list2conj(DiffSuspGoalList,DiffSuspGoals).
7232 different_from_other_susps_(_,[],_,_,[]) :- !.
7233 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7234 ( functor(Head,F,A), functor(PreHead,F,A),
7235 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7236 \+ \+ PreHeadCopy = HeadCopy ->
7238 List = [Susp \== PreSusp | Tail]
7239 ;
7240 List = Tail
7241 ),
7242 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7244 % passive_head_via(in,in,in,in,out,out,out) :-
7245 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7246 functor(Head,F,A),
7247 get_constraint_index(F/A,Pos),
7248 /* which static variables may contain runtime variables */
7249 common_variables(Head,PrevHeads,CommonVars0),
7250 ground_vars([Head],GroundVars),
7251 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7252 /********************************************************/
7253 global_list_store_name(F/A,Name),
7254 GlobalGoal = nb_getval(Name,AllSusps),
7255 get_constraint_mode(F/A,ArgModes),
7256 ( Vars == [] ->
7257 Goal = GlobalGoal
7258 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7259 translate([CommonVar],VarDict,[Var]),
7260 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7261 Goal = AttrGoal
7262 ;
7263 translate(CommonVars,VarDict,Vars),
7264 add_heads_types(PrevHeads,[],TypeDict),
7265 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7266 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7267 Goal =
7268 ( ViaGoal ->
7269 AttrGoal
7270 ;
7271 GlobalGoal
7272 )
7273 ).
7275 common_variables(T,Ts,Vs) :-
7276 term_variables(T,V1),
7277 term_variables(Ts,V2),
7278 intersect_eq(V1,V2,Vs).
7280 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7281 via_goal(Vars,TypeDict,ViaGoal,Var),
7282 get_target_module(Mod),
7283 AttrGoal =
7284 ( get_attr(Var,Mod,TSusps),
7285 TSuspsEqSusps % TSusps = Susps
7286 ),
7287 get_max_constraint_index(N),
7288 ( N == 1 ->
7289 TSuspsEqSusps = true, % TSusps = Susps
7290 AllSusps = TSusps
7291 ;
7292 get_constraint_index(FA,Pos),
7293 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7294 ).
7295 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7296 ( Vars = [] ->
7297 ViaGoal = fail
7298 ; Vars = [A] ->
7299 lookup_type(TypeDict,A,Type),
7300 ( atomic_type(Type) ->
7301 ViaGoal = var(A),
7302 A = Var
7303 ;
7304 ViaGoal = 'chr newvia_1'(A,Var)
7305 )
7306 ; Vars = [A,B] ->
7307 ViaGoal = 'chr newvia_2'(A,B,Var)
7308 ;
7309 ViaGoal = 'chr newvia'(Vars,Var)
7310 ).
7311 lookup_type(TypeDict,Var,Type) :-
7312 ( lookup_eq(TypeDict,Var,Type) ->
7313 true
7314 ;
7315 Type = any % default type
7316 ).
7317 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7318 get_target_module(Mod),
7319 AttrGoal =
7320 ( get_attr(Var,Mod,TSusps),
7321 TSuspsEqSusps % TSusps = Susps
7322 ),
7323 get_max_constraint_index(N),
7324 ( N == 1 ->
7325 TSuspsEqSusps = true, % TSusps = Susps
7326 AllSusps = TSusps
7327 ;
7328 get_constraint_index(FA,Pos),
7329 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7330 ).
7332 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7333 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7334 list2conj(GuardCopyList,GuardCopy).
7336 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7337 Rule = rule(_,H,Guard,Body),
7338 conj2list(Guard,GuardList),
7339 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7340 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7342 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7343 term_variables(RestGuardList,GuardVars),
7344 term_variables(RestGuardListCopyCore,GuardCopyVars),
7345 % variables that are declared to be ground don't need to be locked
7346 ground_vars(H,GroundVars),
7347 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7348 ( chr_pp_flag(guard_locks,off) ->
7349 Locks = [],
7350 Unlocks = []
7351 ;
7352 bagof(Lock - Unlock,
7353 X ^ Y ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7354 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7355 memberchk_eq(Y,GuardCopyVars), % redundant check? or multiple entries for X possible?
7356 chr_lock(Y,Lock),
7357 chr_unlock(Y,Unlock)
7358 ),
7359 LocksUnlocks) ->
7360 once(pairup(Locks,Unlocks,LocksUnlocks))
7361 ;
7362 Locks = [],
7363 Unlocks = []
7364 ),
7365 list2conj(Locks,LockPhase),
7366 list2conj(Unlocks,UnlockPhase),
7367 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7368 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7369 my_term_copy(Body,VarDict2,BodyCopy).
7372 split_off_simple_guard([],_,[],[]).
7373 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7374 ( simple_guard(G,VarDict) ->
7375 S = [G|Ss],
7376 split_off_simple_guard(Gs,VarDict,Ss,C)
7377 ;
7378 S = [],
7379 C = [G|Gs]
7380 ).
7382 % simple guard: cheap and benign (does not bind variables)
7383 simple_guard(G,VarDict) :-
7384 binds_b(G,Vars),
7385 \+ (( member(V,Vars),
7386 lookup_eq(VarDict,V,_)
7387 )).
7389 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7390 functor(Head,F,A),
7391 C = F/A,
7392 ( is_stored(C) ->
7393 (
7394 (
7395 Id == [0], chr_pp_flag(store_in_guards, off)
7396 ;
7397 ( get_allocation_occurrence(C,AO),
7398 get_max_occurrence(C,MO),
7399 MO < AO )
7400 ),
7401 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7402 SuspDetachment = true
7403 ;
7404 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7405 ( chr_pp_flag(late_allocation,on) ->
7406 SuspDetachment =
7407 ( var(Susp) ->
7408 true
7409 ;
7410 UnCondSuspDetachment
7411 )
7412 ;
7413 SuspDetachment = UnCondSuspDetachment
7414 )
7415 )
7416 ;
7417 SuspDetachment = true
7418 ).
7420 partner_constraint_detachments([],[],_,true).
7421 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7422 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7423 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7425 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7426 functor(Head,F,A),
7427 C = F/A,
7428 ( is_stored(C) ->
7429 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7430 ( chr_pp_flag(debugable,on) ->
7431 DebugEvent = 'chr debug_event'(remove(Susp))
7432 ;
7433 DebugEvent = true
7434 ),
7435 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7436 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7437 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7438 detach_constraint_atom(C,Vars,Susp,Detach)
7439 ;
7440 Detach = true
7441 )
7442 ;
7443 SuspDetachment = true
7444 ).
7446 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7448 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7449 %% ____ _ _ _ _
7450 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7451 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7452 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7453 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7454 %% |_| |___/
7455 %% {{{
7457 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7458 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7459 Rule = rule(_Heads,Heads2,Guard,Body),
7461 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7462 get_constraint_mode(F/A,Mode),
7463 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7465 build_head(F,A,Id,HeadVars,ClauseHead),
7467 append(RestHeads,Heads2,Heads),
7468 append(OtherIDs,Heads2IDs,IDs),
7469 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7471 guard_splitting(Rule,GuardList0),
7472 ( is_stored_in_guard(F/A, RuleNb) ->
7473 GuardList = [Hole1|GuardList0]
7474 ;
7475 GuardList = GuardList0
7476 ),
7477 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7479 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7480 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7482 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7484 ( is_stored_in_guard(F/A, RuleNb) ->
7485 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7486 GuardCopyList = [Hole1Copy|_],
7487 Hole1Copy = Attachment
7488 ;
7489 true
7490 ),
7492 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7493 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7494 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7496 ( chr_pp_flag(debugable,on) ->
7497 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7498 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7499 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7500 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7501 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7502 instrument_goal((!),DebugTry,DebugApply,Cut)
7503 ;
7504 Cut = (!)
7505 ),
7507 Clause = ( ClauseHead :-
7508 FirstMatching,
7509 RescheduledTest,
7510 Cut,
7511 SuspsDetachments,
7512 SuspDetachment,
7513 BodyCopy
7514 ),
7515 add_location(Clause,RuleNb,LocatedClause),
7516 L = [LocatedClause | T].
7518 % }}}
7520 split_by_ids([],[],_,[],[]).
7521 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7522 ( memberchk_eq(I,I1s) ->
7523 S1s = [S | R1s],
7524 S2s = R2s
7525 ;
7526 S1s = R1s,
7527 S2s = [S | R2s]
7528 ),
7529 split_by_ids(Is,Ss,I1s,R1s,R2s).
7531 split_by_ids([],[],_,[],[],[],[]).
7532 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7533 ( memberchk_eq(I,I1s) ->
7534 S1s = [S | R1s],
7535 SI1s = [I|RSI1s],
7536 S2s = R2s,
7537 SI2s = RSI2s
7538 ;
7539 S1s = R1s,
7540 SI1s = RSI1s,
7541 S2s = [S | R2s],
7542 SI2s = [I|RSI2s]
7543 ),
7544 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7545 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7549 %% ____ _ _ _ ____
7550 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7551 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7552 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7553 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7554 %% |_| |___/
7556 %% Genereate prelude + worker predicate
7557 %% prelude calls worker
7558 %% worker iterates over one type of removed constraints
7559 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7560 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7561 Rule = rule(Heads1,_,Guard,Body),
7562 append(Heads1,RestHeads2,Heads),
7563 append(IDs1,RestIDs,IDs),
7564 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7565 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7566 extend_id(Id,Id1),
7567 ( memberchk_eq(NID,IDs2) ->
7568 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7569 ;
7570 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7571 ),
7572 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7573 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7575 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7576 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7577 Heads = [Head|RHeads],
7578 inc_id(Id,Id1),
7579 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7580 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7581 ( memberchk_eq(ID,IDs2) ->
7582 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7583 ;
7584 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7585 ).
7587 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7588 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7589 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7590 build_head(F,A,Id1,VarsSusp,ClauseHead),
7591 get_constraint_mode(F/A,Mode),
7592 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7594 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7596 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7598 extend_id(Id1,DelegateId),
7599 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7600 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7601 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7603 PreludeClause =
7604 ( ClauseHead :-
7605 FirstMatching,
7606 ModConstraintsGoal,
7607 !,
7608 ConstraintAllocationGoal,
7609 Delegate
7610 ),
7611 add_dummy_location(PreludeClause,LocatedPreludeClause),
7612 L = [LocatedPreludeClause|T].
7614 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7615 Term =.. [_|Args],
7616 delegate_variables(Term,Terms,VarDict,Args,Vars).
7618 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7619 term_variables(PrevTerms,PrevVars),
7620 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7622 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7623 term_variables(Term,V1),
7624 term_variables(Terms,V2),
7625 intersect_eq(V1,V2,V3),
7626 list_difference_eq(V3,PrevVars,V4),
7627 translate(V4,VarDict,Vars).
7630 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7631 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7632 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7633 Rule = rule(_,_,Guard,Body),
7634 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7636 gen_var(OtherSusp),
7637 gen_var(OtherSusps),
7639 functor(CurrentHead,OtherF,OtherA),
7640 gen_vars(OtherA,OtherVars),
7641 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7642 get_constraint_mode(OtherF/OtherA,Mode),
7643 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7645 delay_phase_end(validate_store_type_assumptions,
7646 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7647 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7648 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7649 )
7650 ),
7651 % create_get_mutable_ref(active,State,GetMutable),
7652 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7653 CurrentSuspTest = (
7654 OtherSusp = OtherSuspension,
7655 GetState,
7656 DiffSuspGoals,
7657 FirstMatching
7658 ),
7660 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7661 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7663 guard_splitting(Rule,GuardList0),
7664 ( is_stored_in_guard(F/A, RuleNb) ->
7665 GuardList = [Hole1|GuardList0]
7666 ;
7667 GuardList = GuardList0
7668 ),
7669 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7671 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7672 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7673 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7675 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7677 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7678 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7679 RecursiveVars2 = [[]|PreVarsAndSusps],
7680 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7682 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7683 ( is_stored_in_guard(F/A, RuleNb) ->
7684 GuardCopyList = [GuardAttachment|_] % once( ) ??
7685 ;
7686 true
7687 ),
7689 ( is_observed(F/A,O) ->
7690 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7691 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7692 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7693 ;
7694 Attachment = true,
7695 ConditionalRecursiveCall = RecursiveCall,
7696 ConditionalRecursiveCall2 = RecursiveCall2
7697 ),
7699 ( chr_pp_flag(debugable,on) ->
7700 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7701 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7702 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7703 ;
7704 DebugTry = true,
7705 DebugApply = true
7706 ),
7708 ( is_stored_in_guard(F/A, RuleNb) ->
7709 GuardAttachment = Attachment,
7710 BodyAttachment = true
7711 ;
7712 GuardAttachment = true,
7713 BodyAttachment = Attachment % will be true if not observed at all
7714 ),
7716 ( member(unique(ID1,UniqueKeys), Pragmas),
7717 check_unique_keys(UniqueKeys,VarDict) ->
7718 Clause =
7719 ( ClauseHead :-
7720 ( CurrentSuspTest ->
7721 ( RescheduledTest,
7722 DebugTry ->
7723 DebugApply,
7724 Susps1Detachments,
7725 BodyAttachment,
7726 BodyCopy,
7727 ConditionalRecursiveCall2
7728 ;
7729 RecursiveCall2
7730 )
7731 ;
7732 RecursiveCall
7733 )
7734 )
7735 ;
7736 Clause =
7737 ( ClauseHead :-
7738 ( CurrentSuspTest,
7739 RescheduledTest,
7740 DebugTry ->
7741 DebugApply,
7742 Susps1Detachments,
7743 BodyAttachment,
7744 BodyCopy,
7745 ConditionalRecursiveCall
7746 ;
7747 RecursiveCall
7748 )
7749 )
7750 ),
7751 add_location(Clause,RuleNb,LocatedClause),
7752 L = [LocatedClause | T].
7754 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7755 ( may_trigger(FA) ->
7756 does_use_field(FA,generation),
7757 delay_phase_end(validate_store_type_assumptions,
7758 ( static_suspension_term(FA,Suspension),
7759 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7760 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7761 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7762 )
7763 )
7764 ;
7765 delay_phase_end(validate_store_type_assumptions,
7766 ( static_suspension_term(FA,Suspension),
7767 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7768 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7769 )
7770 ),
7771 GetGeneration = true
7772 ),
7773 ConditionalCall =
7774 ( Susp = Suspension,
7775 GetState,
7776 GetGeneration ->
7777 UpdateState,
7778 Call
7779 ;
7780 true
7781 ).
7783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7786 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7787 %% ____ _ _
7788 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7789 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7790 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7791 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7792 %% |_| |___/
7794 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7795 ( RestHeads == [] ->
7796 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7797 ;
7798 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7799 ).
7800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7801 %% Single headed propagation
7802 %% everything in a single clause
7803 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7804 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7805 build_head(F,A,Id,VarsSusp,ClauseHead),
7807 inc_id(Id,NextId),
7808 build_head(F,A,NextId,VarsSusp,NextHead),
7810 get_constraint_mode(F/A,Mode),
7811 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7812 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7814 % - recursive call -
7815 RecursiveCall = NextHead,
7817 actual_cut(F/A,O,ActualCut),
7819 Rule = rule(_,_,Guard,Body),
7820 ( chr_pp_flag(debugable,on) ->
7821 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7822 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7823 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7824 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7825 ;
7826 Cut = ActualCut
7827 ),
7828 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7829 use_auxiliary_predicate(novel_production),
7830 use_auxiliary_predicate(extend_history),
7831 does_use_history(F/A,O),
7832 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7834 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7835 ( HistoryIDs == [] ->
7836 empty_named_history_novel_production(HistoryName,NovelProduction),
7837 empty_named_history_extend_history(HistoryName,ExtendHistory)
7838 ;
7839 Tuple = HistoryName
7840 )
7841 ;
7842 Tuple = RuleNb
7843 ),
7845 ( var(NovelProduction) ->
7846 NovelProduction = '$novel_production'(Susp,Tuple),
7847 ExtendHistory = '$extend_history'(Susp,Tuple)
7848 ;
7849 true
7850 ),
7852 ( is_observed(F/A,O) ->
7853 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7854 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7855 ;
7856 Attachment = true,
7857 ConditionalRecursiveCall = RecursiveCall
7858 )
7859 ;
7860 Allocation = true,
7861 NovelProduction = true,
7862 ExtendHistory = true,
7864 ( is_observed(F/A,O) ->
7865 get_allocation_occurrence(F/A,AllocO),
7866 ( O == AllocO ->
7867 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7868 Generation = 0
7869 ; % more room for improvement?
7870 Attachment = (Attachment1, Attachment2),
7871 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7872 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7873 ),
7874 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7875 ;
7876 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7877 ConditionalRecursiveCall = RecursiveCall
7878 )
7879 ),
7881 ( is_stored_in_guard(F/A, RuleNb) ->
7882 GuardAttachment = Attachment,
7883 BodyAttachment = true
7884 ;
7885 GuardAttachment = true,
7886 BodyAttachment = Attachment % will be true if not observed at all
7887 ),
7889 Clause = (
7890 ClauseHead :-
7891 HeadMatching,
7892 Allocation,
7893 NovelProduction,
7894 GuardAttachment,
7895 GuardCopy,
7896 Cut,
7897 ExtendHistory,
7898 BodyAttachment,
7899 BodyCopy,
7900 ConditionalRecursiveCall
7901 ),
7902 add_location(Clause,RuleNb,LocatedClause),
7903 ProgramList = [LocatedClause | ProgramTail].
7905 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7906 %% multi headed propagation
7907 %% prelude + predicates to accumulate the necessary combinations of suspended
7908 %% constraints + predicate to execute the body
7909 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7910 RestHeads = [First|Rest],
7911 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7912 extend_id(Id,ExtendedId),
7913 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7915 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7916 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7917 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7918 build_head(F,A,Id,VarsSusp,PreludeHead),
7919 get_constraint_mode(F/A,Mode),
7920 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7921 Rule = rule(_,_,Guard,Body),
7922 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7924 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7926 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7928 extend_id(Id,NestedId),
7929 append([Susps|VarsSusp],ExtraVars,NestedVars),
7930 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7931 NestedCall = NestedHead,
7933 Prelude = (
7934 PreludeHead :-
7935 FirstMatching,
7936 FirstSuspGoal,
7937 !,
7938 CondAllocation,
7939 NestedCall
7940 ),
7941 add_dummy_location(Prelude,LocatedPrelude),
7942 L = [LocatedPrelude|T].
7944 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7945 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7946 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7947 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7949 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7950 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7951 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7952 inc_id(Id,IncId),
7953 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7955 %check_fd_lookup_condition(_,_,_,_) :- fail.
7956 check_fd_lookup_condition(F,A,_,_) :-
7957 get_store_type(F/A,global_singleton), !.
7958 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7959 \+ may_trigger(F/A),
7960 get_functional_dependency(F/A,1,P,K),
7961 copy_term(P-K,CurrentHead-Key),
7962 term_variables(PreHeads,PreVars),
7963 intersect_eq(Key,PreVars,Key),!.
7965 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7966 Rule = rule(_,H2,Guard,Body),
7967 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7968 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7969 init(AllSusps,RestSusps),
7970 last(AllSusps,Susp),
7971 gen_var(OtherSusp),
7972 gen_var(OtherSusps),
7973 functor(CurrentHead,OtherF,OtherA),
7974 gen_vars(OtherA,OtherVars),
7975 delay_phase_end(validate_store_type_assumptions,
7976 ( static_suspension_term(OtherF/OtherA,Suspension),
7977 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7978 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7979 )
7980 ),
7981 % create_get_mutable_ref(active,State,GetMutable),
7982 CurrentSuspTest = (
7983 OtherSusp = Suspension,
7984 GetState
7985 ),
7986 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7987 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7988 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7989 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7990 RecursiveVars = PreVarsAndSusps1
7991 ;
7992 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7993 PrevId0 = Id
7994 ),
7995 ( PrevId0 = [_] ->
7996 PrevId = PrevId0
7997 ;
7998 PrevId = [O|PrevId0]
7999 ),
8000 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8001 RecursiveCall = RecursiveHead,
8002 CurrentHead =.. [_|OtherArgs],
8003 pairup(OtherArgs,OtherVars,OtherPairs),
8004 get_constraint_mode(OtherF/OtherA,Mode),
8005 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
8007 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
8008 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
8009 get_occurrence(F/A,O,_,ID),
8011 ( is_observed(F/A,O) ->
8012 init(FirstVarsSusp,FirstVars),
8013 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
8014 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
8015 ;
8016 Attachment = true,
8017 ConditionalRecursiveCall = RecursiveCall
8018 ),
8019 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
8020 NovelProduction = true,
8021 ExtendHistory = true
8022 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
8023 NovelProduction = true,
8024 ExtendHistory = true
8025 ;
8026 get_occurrence(F/A,O,_,ID),
8027 use_auxiliary_predicate(novel_production),
8028 use_auxiliary_predicate(extend_history),
8029 does_use_history(F/A,O),
8030 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
8031 ( HistoryIDs == [] ->
8032 empty_named_history_novel_production(HistoryName,NovelProduction),
8033 empty_named_history_extend_history(HistoryName,ExtendHistory)
8034 ;
8035 reverse([OtherSusp|RestSusps],NamedSusps),
8036 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
8037 HistorySusps = [HistorySusp|_],
8039 ( length(HistoryIDs, 1) ->
8040 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
8041 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
8042 ;
8043 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
8044 Tuple =.. [t,HistoryName|HistorySusps]
8045 )
8046 )
8047 ;
8048 HistorySusp = Susp,
8049 maplist(extract_symbol,H2,ConstraintSymbols),
8050 sort([ID|RestIDs],HistoryIDs),
8051 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
8052 Tuple =.. [t,RuleNb|HistorySusps]
8053 ),
8055 ( var(NovelProduction) ->
8056 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
8057 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
8058 NovelProduction = ( TupleVar = Tuple, NovelProductions )
8059 ;
8060 true
8061 )
8062 ),
8065 ( chr_pp_flag(debugable,on) ->
8066 Rule = rule(_,_,Guard,Body),
8067 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
8068 get_occurrence(F/A,O,_,ID),
8069 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
8070 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
8071 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
8072 ;
8073 DebugTry = true,
8074 DebugApply = true
8075 ),
8077 ( is_stored_in_guard(F/A, RuleNb) ->
8078 GuardAttachment = Attachment,
8079 BodyAttachment = true
8080 ;
8081 GuardAttachment = true,
8082 BodyAttachment = Attachment % will be true if not observed at all
8083 ),
8085 Clause = (
8086 ClauseHead :-
8087 ( CurrentSuspTest,
8088 DiffSuspGoals,
8089 Matching,
8090 NovelProduction,
8091 GuardAttachment,
8092 GuardCopy,
8093 DebugTry ->
8094 DebugApply,
8095 ExtendHistory,
8096 BodyAttachment,
8097 BodyCopy,
8098 ConditionalRecursiveCall
8099 ; RecursiveCall
8100 )
8101 ),
8102 add_location(Clause,RuleNb,LocatedClause),
8103 L = [LocatedClause|T].
8105 extract_symbol(Head,F/A) :-
8106 functor(Head,F,A).
8108 novel_production_calls([],[],[],_,_,true).
8109 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
8110 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
8111 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
8112 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
8114 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
8115 reverse(ReversedRestSusps,RestSusps),
8116 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
8118 named_history_susps([],_,_,[]).
8119 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
8120 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
8121 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
8125 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
8126 !,
8127 functor(Head,F,A),
8128 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
8129 get_constraint_mode(F/A,Mode),
8130 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
8131 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
8132 append(VarsSusp,ExtraVars,HeadVars).
8133 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
8134 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
8135 functor(Head,F,A),
8136 gen_var(Susps),
8137 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8138 get_constraint_mode(F/A,Mode),
8139 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8140 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8141 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
8143 % returns
8144 % VarDict for the copies of variables in the original heads
8145 % VarsSuspsList list of lists of arguments for the successive heads
8146 % FirstVarsSusp top level arguments
8147 % SuspList list of all suspensions
8148 % Iterators list of all iterators
8149 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
8150 !,
8151 functor(Head,F,A),
8152 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
8153 get_constraint_mode(F/A,Mode),
8154 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
8155 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
8156 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
8157 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
8158 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
8159 functor(Head,F,A),
8160 gen_var(Susps),
8161 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8162 get_constraint_mode(F/A,Mode),
8163 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8164 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8165 append(HeadVars,[Susp,Susps],Vars).
8167 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8168 !,
8169 functor(Head,F,A),
8170 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8171 get_constraint_mode(F/A,Mode),
8172 head_arg_matches(Pairs,Mode,[],_,VarDict),
8173 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8174 append(VarsSusp,ExtraVars,HeadVars).
8175 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8176 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8177 functor(Head,F,A),
8178 gen_var(Susps),
8179 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8180 get_constraint_mode(F/A,Mode),
8181 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8182 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8183 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8185 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8187 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8188 %% ____ _ _ _ _
8189 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8190 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8191 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8192 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8193 %%
8194 %% ____ _ _ _
8195 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8196 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8197 %% | _ < __/ |_| | | | __/\ V / (_| | |
8198 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8199 %%
8200 %% ____ _ _
8201 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8202 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8203 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8204 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8205 %% |___/
8207 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8208 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8209 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8210 ;
8211 NRestHeads = RestHeads,
8212 NRestIDs = RestIDs
8213 ).
8215 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8216 term_variables(Head,Vars),
8217 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8218 copy_term_nat(InitialData,InitialDataCopy),
8219 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8220 InitialDataCopy = InitialData,
8221 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8222 reverse(RNRestHeads,NRestHeads),
8223 reverse(RNRestIDs,NRestIDs).
8225 final_data(Entry) :-
8226 Entry = entry(_,_,_,_,[],_).
8228 expand_data(Entry,NEntry,Cost) :-
8229 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8230 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8231 term_variables([Head1|Vars],Vars1),
8232 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8233 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8235 % Assigns score to head based on known variables and heads to lookup
8236 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8237 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8238 functor(Head,F,A),
8239 get_store_type(F/A,StoreType),
8240 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8241 % }}}
8243 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8244 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8245 term_variables(Head,HeadVars0),
8246 term_variables(RestHeads,RestVars),
8247 ground_vars([Head],GroundVars),
8248 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8249 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8250 NScore is min(CScore,Score).
8251 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8252 ( CScore =< 100 ->
8253 Score = CScore
8254 ;
8255 order_score_indexes(Indexes,Head,KnownVars,Score)
8256 ).
8257 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8258 ( CScore =< 100 ->
8259 Score = CScore
8260 ;
8261 order_score_indexes(Indexes,Head,KnownVars,Score)
8262 ).
8263 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8264 term_variables(Head,HeadVars),
8265 term_variables(RestHeads,RestVars),
8266 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8267 Score is Score_ * 200,
8268 NScore is min(CScore,Score).
8269 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8270 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8271 Score = 1. % guaranteed O(1)
8272 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8273 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8274 multi_order_score([],_,_,_,_,_,Score,Score).
8275 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8276 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8277 ; Score1 = Score0
8278 ),
8279 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8281 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8282 arg(Index,Head,Arg),
8283 memberchk_eq(Arg,KnownVars),
8284 Score is min(CScore,10).
8285 order_score(type_indexed_identifier_store(Index,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8286 arg(Index,Head,Arg),
8287 memberchk_eq(Arg,KnownVars),
8288 Score is min(CScore,10).
8289 % }}}
8292 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8293 order_score_indexes(Indexes,Head,Vars,Score) :-
8294 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8295 numbervars(VarsCopy,0,_),
8296 order_score_indexes(Indexes,HeadCopy,Score).
8298 order_score_indexes([I|Is],Head,Score) :-
8299 args(I,Head,Args),
8300 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8301 Score = 100
8302 ;
8303 order_score_indexes(Is,Head,Score)
8304 ).
8305 % }}}
8307 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8309 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8310 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8311 ( K-R-O == 0-0-0 ->
8312 Score = 0
8313 ; K > 0 ->
8314 Score is max(10 - K,0)
8315 ; R > 0 ->
8316 Score is max(10 - R,1) * 100
8317 ;
8318 Score is max(10-O,1) * 1000
8319 ).
8320 order_score_count_vars([],_,_,0-0-0).
8321 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8322 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8323 ( memberchk_eq(V,KnownVars) ->
8324 NK is K + 1,
8325 NR = R, NO = O
8326 ; memberchk_eq(V,RestVars) ->
8327 NR is R + 1,
8328 NK = K, NO = O
8329 ;
8330 NO is O + 1,
8331 NK = K, NR = R
8332 ).
8334 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8335 %% ___ _ _ _
8336 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8337 %% | || '_ \| | | '_ \| | '_ \ / _` |
8338 %% | || | | | | | | | | | | | | (_| |
8339 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8340 %% |___/
8342 %% SWI begin
8343 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8344 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8345 %% SWI end
8347 %% SICStus begin
8348 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8349 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8350 %% SICStus end
8352 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8354 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8355 %% _ _ _ _ _ _ _
8356 %% | | | | |_(_) (_) |_ _ _
8357 %% | | | | __| | | | __| | | |
8358 %% | |_| | |_| | | | |_| |_| |
8359 %% \___/ \__|_|_|_|\__|\__, |
8360 %% |___/
8362 % Create a fresh variable.
8363 gen_var(_).
8365 % Create =N= fresh variables.
8366 gen_vars(N,Xs) :-
8367 length(Xs,N).
8369 ast_head_info1(AstHead,Vars,Susp,VarsSusp,HeadPairs) :-
8370 AstHead = chr_constraint(_/A,Args,_),
8371 vars_susp(A,Vars,Susp,VarsSusp),
8372 pairup(Args,Vars,HeadPairs).
8374 head_info1(Head,_/A,Vars,Susp,VarsSusp,HeadPairs) :-
8375 vars_susp(A,Vars,Susp,VarsSusp),
8376 Head =.. [_|Args],
8377 pairup(Args,Vars,HeadPairs).
8379 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8380 vars_susp(A,Vars,Susp,VarsSusp),
8381 Head =.. [_|Args],
8382 pairup(Args,Vars,HeadPairs).
8384 inc_id([N|Ns],[O|Ns]) :-
8385 O is N + 1.
8386 dec_id([N|Ns],[M|Ns]) :-
8387 M is N - 1.
8389 extend_id(Id,[0|Id]).
8391 next_id([_,N|Ns],[O|Ns]) :-
8392 O is N + 1.
8394 % return clause Head
8395 % for F/A constraint symbol, predicate identifier Id and arguments Head
8396 build_head(F/A,Id,Args,Head) :-
8397 build_head(F,A,Id,Args,Head).
8398 build_head(F,A,Id,Args,Head) :-
8399 buildName(F,A,Id,Name),
8400 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8401 ( may_trigger(F/A) ;
8402 get_allocation_occurrence(F/A,AO),
8403 get_max_occurrence(F/A,MO),
8404 MO >= AO ) ) ->
8405 Head =.. [Name|Args]
8406 ;
8407 init(Args,ArgsWOSusp), % XXX not entirely correct!
8408 Head =.. [Name|ArgsWOSusp]
8409 ).
8411 % return predicate name Result
8412 % for Fct/Aty constraint symbol and predicate identifier List
8413 buildName(Fct,Aty,List,Result) :-
8414 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8415 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8416 MO >= AO ) ; List \= [0])) ) ) ->
8417 atom_concat(Fct, '___' ,FctSlash),
8418 atomic_concat(FctSlash,Aty,FctSlashAty),
8419 buildName_(List,FctSlashAty,Result)
8420 ;
8421 Result = Fct
8422 ).
8424 buildName_([],Name,Name).
8425 buildName_([N|Ns],Name,Result) :-
8426 buildName_(Ns,Name,Name1),
8427 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8428 atomic_concat(NameDash,N,Result).
8430 vars_susp(A,Vars,Susp,VarsSusp) :-
8431 length(Vars,A),
8432 append(Vars,[Susp],VarsSusp).
8434 or_pattern(Pos,Pat) :-
8435 Pow is Pos - 1,
8436 Pat is 1 << Pow. % was 2 ** X
8438 and_pattern(Pos,Pat) :-
8439 X is Pos - 1,
8440 Y is 1 << X, % was 2 ** X
8441 Pat is (-1)*(Y + 1).
8443 make_name(Prefix,F/A,Name) :-
8444 atom_concat_list([Prefix,F,'___',A],Name).
8446 %===============================================================================
8447 % Attribute for attributed variables
8449 make_attr(N,Mask,SuspsList,Attr) :-
8450 length(SuspsList,N),
8451 Attr =.. [v,Mask|SuspsList].
8453 get_all_suspensions2(N,Attr,SuspensionsList) :-
8454 chr_pp_flag(dynattr,off), !,
8455 make_attr(N,_,SuspensionsList,Attr).
8457 % NEW
8458 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8459 % writeln(get_all_suspensions2),
8460 length(SuspensionsList,N),
8461 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8464 % NEW
8465 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8466 % writeln(normalize_attr),
8467 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8469 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8470 chr_pp_flag(dynattr,off),
8471 !, % chr_pp_flag(experiment,off), !,
8472 make_attr(N,_,SuspsList,Attr),
8473 nth1(Position,SuspsList,Suspensions).
8475 % get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8476 % chr_pp_flag(dynattr,off),
8477 % chr_pp_flag(experiment,on), !,
8478 % Position1 is Position + 1,
8479 % Goal = arg(Position1,TAttr,Suspensions).
8481 % NEW
8482 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8483 % writeln(get_suspensions),
8484 Goal =
8485 ( memberchk(Position-Suspensions,TAttr) ->
8486 true
8487 ;
8488 Suspensions = []
8489 ).
8491 %-------------------------------------------------------------------------------
8492 % +N: number of constraint symbols
8493 % +Suspension: source-level variable, for suspension
8494 % +Position: constraint symbol number
8495 % -Attr: source-level term, for new attribute
8496 singleton_attr(N,Suspension,Position,Attr) :-
8497 chr_pp_flag(dynattr,off), !,
8498 or_pattern(Position,Pattern),
8499 make_attr(N,Pattern,SuspsList,Attr),
8500 nth1(Position,SuspsList,[Suspension]),
8501 chr_delete(SuspsList,[Suspension],RestSuspsList),
8502 set_elems(RestSuspsList,[]).
8504 % NEW
8505 singleton_attr(N,Suspension,Position,Attr) :-
8506 % writeln(singleton_attr),
8507 Attr = [Position-[Suspension]].
8509 %-------------------------------------------------------------------------------
8510 % +N: number of constraint symbols
8511 % +Suspension: source-level variable, for suspension
8512 % +Position: constraint symbol number
8513 % +TAttr: source-level variable, for old attribute
8514 % -Goal: goal for creating new attribute
8515 % -NTAttr: source-level variable, for new attribute
8516 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8517 chr_pp_flag(dynattr,off), !,
8518 make_attr(N,Mask,SuspsList,Attr),
8519 or_pattern(Position,Pattern),
8520 nth1(Position,SuspsList,Susps),
8521 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8522 make_attr(N,Mask,SuspsList1,NewAttr1),
8523 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8524 make_attr(N,NewMask,SuspsList2,NewAttr2),
8525 Goal = (
8526 TAttr = Attr,
8527 ( Mask /\ Pattern =:= Pattern ->
8528 NTAttr = NewAttr1
8529 ;
8530 NewMask is Mask \/ Pattern,
8531 NTAttr = NewAttr2
8532 )
8533 ), !.
8535 % NEW
8536 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8537 % writeln(add_attr),
8538 Goal =
8539 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8540 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8541 ;
8542 NTAttr = [Position-[Suspension]|TAttr]
8543 ).
8545 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8546 chr_pp_flag(dynattr,off),
8547 chr_pp_flag(experiment,off), !,
8548 or_pattern(Position,Pattern),
8549 and_pattern(Position,DelPattern),
8550 make_attr(N,Mask,SuspsList,Attr),
8551 nth1(Position,SuspsList,Susps),
8552 substitute_eq(Susps,SuspsList,[],SuspsList1),
8553 make_attr(N,NewMask,SuspsList1,Attr1),
8554 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8555 make_attr(N,Mask,SuspsList2,Attr2),
8556 get_target_module(Mod),
8557 Goal = (
8558 TAttr = Attr,
8559 ( Mask /\ Pattern =:= Pattern ->
8560 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8561 ( NewSusps == [] ->
8562 NewMask is Mask /\ DelPattern,
8563 ( NewMask == 0 ->
8564 del_attr(Var,Mod)
8565 ;
8566 put_attr(Var,Mod,Attr1)
8567 )
8568 ;
8569 put_attr(Var,Mod,Attr2)
8570 )
8571 ;
8572 true
8573 )
8574 ), !.
8575 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8576 chr_pp_flag(dynattr,off),
8577 chr_pp_flag(experiment,on), !,
8578 or_pattern(Position,Pattern),
8579 and_pattern(Position,DelPattern),
8580 Position1 is Position + 1,
8581 get_target_module(Mod),
8582 Goal = (
8583 arg(1,TAttr,Mask),
8584 ( Mask /\ Pattern =:= Pattern ->
8585 arg(Position1,TAttr,Susps),
8586 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8587 ( NewSusps == [] ->
8588 NewMask is Mask /\ DelPattern,
8589 ( NewMask == 0 ->
8590 del_attr(Var,Mod)
8591 ;
8592 setarg(1,TAttr,NewMask),
8593 setarg(Position1,TAttr,NewSusps)
8594 )
8595 ;
8596 setarg(Position1,TAttr,NewSusps)
8597 )
8598 ;
8599 true
8600 )
8601 ), !.
8603 % NEW
8604 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8605 % writeln(rem_attr),
8606 get_target_module(Mod),
8607 Goal =
8608 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8609 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8610 ( NSuspensions == [] ->
8611 ( RAttr == [] ->
8612 del_attr(Var,Mod)
8613 ;
8614 put_attr(Var,Mod,RAttr)
8615 )
8616 ;
8617 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8618 )
8619 ;
8620 true
8621 ).
8623 %-------------------------------------------------------------------------------
8624 % +N: number of constraint symbols
8625 % +TAttr1: source-level variable, for attribute
8626 % +TAttr2: source-level variable, for other attribute
8627 % -Goal: goal for merging the two attributes
8628 % -Attr: source-level term, for merged attribute
8629 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8630 chr_pp_flag(dynattr,off), !,
8631 make_attr(N,Mask1,SuspsList1,Attr1),
8632 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8633 Goal = (
8634 TAttr1 = Attr1,
8635 Goal2
8636 ).
8638 % NEW
8639 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8640 % writeln(merge_attributes),
8641 Goal = (
8642 sort(TAttr1,Sorted1),
8643 sort(TAttr2,Sorted2),
8644 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8645 ).
8648 %-------------------------------------------------------------------------------
8649 % +N: number of constraint symbols
8650 % +Mask1: ...
8651 % +SuspsList1: static term, for suspensions list
8652 % +TAttr2: source-level variable, for other attribute
8653 % -Goal: goal for merging the two attributes
8654 % -Attr: source-level term, for merged attribute
8655 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8656 make_attr(N,Mask2,SuspsList2,Attr2),
8657 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8658 list2conj(Gs,SortGoals),
8659 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8660 make_attr(N,Mask,SuspsList,Attr),
8661 Goal = (
8662 TAttr2 = Attr2,
8663 SortGoals,
8664 Mask is Mask1 \/ Mask2
8665 ).
8668 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8669 % Storetype dependent lookup
8671 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8672 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8673 %% -Goal,-SuspensionList) is det.
8674 %
8675 % Create a universal lookup goal for given head.
8676 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8677 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8678 functor(Head,F,A),
8679 get_store_type(F/A,StoreType),
8680 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8682 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8683 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8684 %% -Goal,-SuspensionList) is det.
8685 %
8686 % Create a universal lookup goal for given head.
8687 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8688 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8689 functor(Head,F,A),
8690 get_store_type(F/A,StoreType),
8691 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8693 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8694 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8695 %% +GroundVars,-Goal,-SuspensionList) is det.
8696 %
8697 % Create a universal lookup goal for given head.
8698 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8699 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8700 functor(Head,F,A),
8701 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8702 update_store_type(F/A,default).
8703 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8704 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8705 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8706 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8707 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8708 functor(Head,F,A),
8709 global_ground_store_name(F/A,StoreName),
8710 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8711 update_store_type(F/A,global_ground).
8712 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8713 arg(VarIndex,Head,OVar),
8714 arg(KeyIndex,Head,OKey),
8715 translate([OVar,OKey],VarDict,[Var,Key]),
8716 get_target_module(Module),
8717 Goal = (
8718 get_attr(Var,Module,AssocStore),
8719 lookup_assoc_store(AssocStore,Key,AllSusps)
8720 ).
8721 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8722 functor(Head,F,A),
8723 global_singleton_store_name(F/A,StoreName),
8724 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8725 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8726 update_store_type(F/A,global_singleton).
8727 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8728 once((
8729 member(ST,StoreTypes),
8730 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8731 )).
8732 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8733 functor(Head,F,A),
8734 arg(Index,Head,Var),
8735 translate([Var],VarDict,[KeyVar]),
8736 delay_phase_end(validate_store_type_assumptions,
8737 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8738 ),
8739 update_store_type(F/A,identifier_store(Index)),
8740 get_identifier_index(F/A,Index,_).
8741 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8742 functor(Head,F,A),
8743 arg(Index,Head,Var),
8744 ( var(Var) ->
8745 translate([Var],VarDict,[KeyVar]),
8746 Goal = StructGoal
8747 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8748 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8749 Goal = (LookupGoal,StructGoal)
8750 ),
8751 delay_phase_end(validate_store_type_assumptions,
8752 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8753 ),
8754 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8755 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8757 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8758 get_identifier_size(ISize),
8759 functor(Struct,struct,ISize),
8760 get_identifier_index(C,Index,IIndex),
8761 arg(IIndex,Struct,AllSusps),
8762 Goal = (KeyVar = Struct).
8764 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8765 type_indexed_identifier_structure(IndexType,Struct),
8766 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8767 arg(IIndex,Struct,AllSusps),
8768 Goal = (KeyVar = Struct).
8770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8771 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8772 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8773 %
8774 % Create a universal hash lookup goal for given head.
8775 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8776 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8777 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8778 ( KeyArgCopies = [KeyCopy] ->
8779 true
8780 ;
8781 KeyCopy =.. [k|KeyArgCopies]
8782 ),
8783 functor(Head,F,A),
8784 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8786 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8787 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8789 Goal = (GroundCheck,LookupGoal),
8791 ( HashType == inthash ->
8792 update_store_type(F/A,multi_inthash([Index]))
8793 ;
8794 update_store_type(F/A,multi_hash([Index]))
8795 ).
8797 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8798 member(Index,Indexes),
8799 args(Index,Head,KeyArgs),
8800 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8801 !.
8803 % check whether we can copy the given terms
8804 % with the given dictionary, and, if so, do so
8805 key_in_scope([],VarDict,[]).
8806 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8807 term_variables(Arg,Vars),
8808 translate(Vars,VarDict,VarCopies),
8809 copy_term(Arg/Vars,ArgCopy/VarCopies),
8810 key_in_scope(Args,VarDict,ArgCopies).
8812 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8813 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8814 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8815 %% +VarArgDict,-NewVarArgDict) is det.
8816 %
8817 % Create existential lookup goal for given head.
8818 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8819 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8820 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8821 sbag_member_call(Susp,AllSusps,Sbag),
8822 functor(Head,F,A),
8823 delay_phase_end(validate_store_type_assumptions,
8824 ( static_suspension_term(F/A,SuspTerm),
8825 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8826 )
8827 ),
8828 Goal = (
8829 UniversalGoal,
8830 Sbag,
8831 Susp = SuspTerm,
8832 GetState
8833 ).
8834 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8835 functor(Head,F,A),
8836 global_singleton_store_name(F/A,StoreName),
8837 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8838 Goal = (
8839 GetStoreGoal, % nb_getval(StoreName,Susp),
8840 Susp \== [],
8841 Susp = SuspTerm
8842 ),
8843 update_store_type(F/A,global_singleton).
8844 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8845 once((
8846 member(ST,StoreTypes),
8847 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8848 )).
8849 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8850 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8851 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8852 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8853 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8854 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8855 hash_index_filter(Pairs,[Index],NPairs),
8857 functor(Head,F,A),
8858 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8859 Sbag = (AllSusps = [Susp])
8860 ;
8861 sbag_member_call(Susp,AllSusps,Sbag)
8862 ),
8863 delay_phase_end(validate_store_type_assumptions,
8864 ( static_suspension_term(F/A,SuspTerm),
8865 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8866 )
8867 ),
8868 Goal = (
8869 LookupGoal,
8870 Sbag,
8871 Susp = SuspTerm, % not inlined
8872 GetState
8873 ).
8874 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8875 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8876 hash_index_filter(Pairs,[Index],NPairs),
8878 functor(Head,F,A),
8879 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8880 Sbag = (AllSusps = [Susp])
8881 ;
8882 sbag_member_call(Susp,AllSusps,Sbag)
8883 ),
8884 delay_phase_end(validate_store_type_assumptions,
8885 ( static_suspension_term(F/A,SuspTerm),
8886 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8887 )
8888 ),
8889 Goal = (
8890 LookupGoal,
8891 Sbag,
8892 Susp = SuspTerm, % not inlined
8893 GetState
8894 ).
8895 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8896 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8897 sbag_member_call(Susp,Susps,Sbag),
8898 functor(Head,F,A),
8899 delay_phase_end(validate_store_type_assumptions,
8900 ( static_suspension_term(F/A,SuspTerm),
8901 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8902 )
8903 ),
8904 Goal = (
8905 UGoal,
8906 Sbag,
8907 Susp = SuspTerm, % not inlined
8908 GetState
8909 ).
8911 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8912 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8913 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8914 %% +VarArgDict,-NewVarArgDict) is det.
8915 %
8916 % Create existential hash lookup goal for given head.
8917 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8918 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8919 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8921 hash_index_filter(Pairs,Index,NPairs),
8923 functor(Head,F,A),
8924 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8925 Sbag = (AllSusps = [Susp])
8926 ;
8927 sbag_member_call(Susp,AllSusps,Sbag)
8928 ),
8929 delay_phase_end(validate_store_type_assumptions,
8930 ( static_suspension_term(F/A,SuspTerm),
8931 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8932 )
8933 ),
8934 Goal = (
8935 LookupGoal,
8936 Sbag,
8937 Susp = SuspTerm, % not inlined
8938 GetState
8939 ).
8941 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8942 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8943 %
8944 % Filter out pairs already covered by given hash index.
8945 % makes them 'silent'
8946 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8947 hash_index_filter(Pairs,Index,NPairs) :-
8948 hash_index_filter(Pairs,Index,1,NPairs).
8950 hash_index_filter([],_,_,[]).
8951 hash_index_filter([P|Ps],Index,N,NPairs) :-
8952 ( Index = [I|Is] ->
8953 NN is N + 1,
8954 ( I > N ->
8955 NPairs = [P|NPs],
8956 hash_index_filter(Ps,[I|Is],NN,NPs)
8957 ; I == N ->
8958 NPairs = [silent(P)|NPs],
8959 hash_index_filter(Ps,Is,NN,NPs)
8960 )
8961 ;
8962 NPairs = [P|Ps]
8963 ).
8965 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8966 %------------------------------------------------------------------------------%
8967 %% assume_constraint_stores(+ConstraintSymbols) is det.
8968 %
8969 % Compute all constraint store types that are possible for the given
8970 % =ConstraintSymbols=.
8971 %------------------------------------------------------------------------------%
8972 assume_constraint_stores([]).
8973 assume_constraint_stores([C|Cs]) :-
8974 ( chr_pp_flag(debugable,off),
8975 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8976 is_stored(C),
8977 get_store_type(C,default) ->
8978 get_indexed_arguments(C,AllIndexedArgs),
8979 get_constraint_mode(C,Modes),
8980 aggregate_all(bag(Index)-count,
8981 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8982 IndexedArgs-NbIndexedArgs),
8983 % Construct Index Combinations
8984 ( NbIndexedArgs > 10 ->
8985 findall([Index],member(Index,IndexedArgs),Indexes)
8986 ;
8987 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8988 predsort(longer_list,UnsortedIndexes,Indexes)
8989 ),
8990 % EXPERIMENTAL HEURISTIC
8991 % findall(Index, (
8992 % member(Arg1,IndexedArgs),
8993 % member(Arg2,IndexedArgs),
8994 % Arg1 =< Arg2,
8995 % sort([Arg1,Arg2], Index)
8996 % ), UnsortedIndexes),
8997 % predsort(longer_list,UnsortedIndexes,Indexes),
8998 % Choose Index Type
8999 ( get_functional_dependency(C,1,Pattern,Key),
9000 all_distinct_var_args(Pattern), Key == [] ->
9001 assumed_store_type(C,global_singleton)
9002 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
9003 get_constraint_type_det(C,ArgTypes),
9004 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
9006 ( IntHashIndexes = [] ->
9007 Stores = Stores1
9008 ;
9009 Stores = [multi_inthash(IntHashIndexes)|Stores1]
9010 ),
9011 ( HashIndexes = [] ->
9012 Stores1 = Stores2
9013 ;
9014 Stores1 = [multi_hash(HashIndexes)|Stores2]
9015 ),
9016 ( IdentifierIndexes = [] ->
9017 Stores2 = Stores3
9018 ;
9019 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
9020 append(WrappedIdentifierIndexes,Stores3,Stores2)
9021 ),
9022 append(CompoundIdentifierIndexes,Stores4,Stores3),
9023 ( only_ground_indexed_arguments(C)
9024 -> Stores4 = [global_ground]
9025 ; Stores4 = [default]
9026 ),
9027 assumed_store_type(C,multi_store(Stores))
9028 ; true
9029 )
9030 ;
9031 true
9032 ),
9033 assume_constraint_stores(Cs).
9035 %------------------------------------------------------------------------------%
9036 %% partition_indexes(+Indexes,+Types,
9037 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
9038 %------------------------------------------------------------------------------%
9039 partition_indexes([],_,[],[],[],[]).
9040 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
9041 ( Index = [I],
9042 nth1(I,Types,Type),
9043 unalias_type(Type,UnAliasedType),
9044 UnAliasedType == chr_identifier ->
9045 IdentifierIndexes = [I|RIdentifierIndexes],
9046 IntHashIndexes = RIntHashIndexes,
9047 HashIndexes = RHashIndexes,
9048 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9049 ; Index = [I],
9050 nth1(I,Types,Type),
9051 unalias_type(Type,UnAliasedType),
9052 nonvar(UnAliasedType),
9053 UnAliasedType = chr_identifier(IndexType) ->
9054 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
9055 IdentifierIndexes = RIdentifierIndexes,
9056 IntHashIndexes = RIntHashIndexes,
9057 HashIndexes = RHashIndexes
9058 ; Index = [I],
9059 nth1(I,Types,Type),
9060 unalias_type(Type,UnAliasedType),
9061 UnAliasedType == dense_int ->
9062 IntHashIndexes = [Index|RIntHashIndexes],
9063 HashIndexes = RHashIndexes,
9064 IdentifierIndexes = RIdentifierIndexes,
9065 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9066 ; member(I,Index),
9067 nth1(I,Types,Type),
9068 unalias_type(Type,UnAliasedType),
9069 nonvar(UnAliasedType),
9070 UnAliasedType = chr_identifier(_) ->
9071 % don't use chr_identifiers in hash indexes
9072 IntHashIndexes = RIntHashIndexes,
9073 HashIndexes = RHashIndexes,
9074 IdentifierIndexes = RIdentifierIndexes,
9075 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9076 ;
9077 IntHashIndexes = RIntHashIndexes,
9078 HashIndexes = [Index|RHashIndexes],
9079 IdentifierIndexes = RIdentifierIndexes,
9080 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9081 ),
9082 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
9084 longer_list(R,L1,L2) :-
9085 length(L1,N1),
9086 length(L2,N2),
9087 compare(Rt,N2,N1),
9088 ( Rt == (=) ->
9089 compare(R,L1,L2)
9090 ;
9091 R = Rt
9092 ).
9094 all_distinct_var_args(Term) :-
9095 copy_term_nat(Term,TermCopy),
9096 functor(Term,F,A),
9097 functor(Pattern,F,A),
9098 Pattern =@= TermCopy.
9100 get_indexed_arguments(C,IndexedArgs) :-
9101 C = F/A,
9102 get_indexed_arguments(1,A,C,IndexedArgs).
9104 get_indexed_arguments(I,N,C,L) :-
9105 ( I > N ->
9106 L = []
9107 ; ( is_indexed_argument(C,I) ->
9108 L = [I|T]
9109 ;
9110 L = T
9111 ),
9112 J is I + 1,
9113 get_indexed_arguments(J,N,C,T)
9114 ).
9116 validate_store_type_assumptions([]).
9117 validate_store_type_assumptions([C|Cs]) :-
9118 validate_store_type_assumption(C),
9119 validate_store_type_assumptions(Cs).
9121 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9122 % new code generation
9123 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
9124 Rule = rule(H1,_,Guard,Body),
9125 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9126 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
9127 flatten(VarsAndSuspsList,VarsAndSusps),
9128 Vars = [ [] | VarsAndSusps],
9129 build_head(F,A,[O|Id],Vars,Head),
9130 ( PrevId0 = [_] ->
9131 get_success_continuation_code_id(F/A,O,PredictedPrevId),
9132 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
9133 PrevId = [PredictedPrevId] % PrevId = PrevId0
9134 ;
9135 PrevId = [O|PrevId0]
9136 ),
9137 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9138 Clause = ( Head :- PredecessorCall),
9139 add_dummy_location(Clause,LocatedClause),
9140 L = [LocatedClause | T].
9141 % ( H1 == [],
9142 % functor(CurrentHead,CF,CA),
9143 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
9144 % L = T
9145 % ;
9146 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9147 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
9148 % flatten(VarsAndSuspsList,VarsAndSusps),
9149 % Vars = [ [] | VarsAndSusps],
9150 % build_head(F,A,Id,Vars,Head),
9151 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9152 % Clause = ( Head :- PredecessorCall),
9153 % L = [Clause | T]
9154 % ).
9156 % skips back intelligently over global_singleton lookups
9157 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
9158 ( Id = [0|_] ->
9159 % TOM: add partial success continuation optimization here!
9160 next_id(Id,PrevId),
9161 PrevVarsAndSusps = BaseCallArgs
9162 ;
9163 VarsAndSuspsList = [_|AllButFirstList],
9164 dec_id(Id,PrevId1),
9165 ( PrevHeads = [PrevHead|PrevHeads1],
9166 functor(PrevHead,F,A),
9167 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
9168 PrevIterators = [_|PrevIterators1],
9169 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
9170 ;
9171 PrevId = PrevId1,
9172 flatten(AllButFirstList,AllButFirst),
9173 PrevIterators = [PrevIterator|_],
9174 PrevVarsAndSusps = [PrevIterator|AllButFirst]
9175 )
9176 ).
9178 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
9179 Rule = rule(_,_,Guard,Body),
9180 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
9181 init(AllSusps,PreSusps),
9182 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
9183 gen_var(OtherSusps),
9184 functor(CurrentHead,OtherF,OtherA),
9185 gen_vars(OtherA,OtherVars),
9186 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
9187 get_constraint_mode(OtherF/OtherA,Mode),
9188 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
9190 delay_phase_end(validate_store_type_assumptions,
9191 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
9192 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
9193 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
9194 )
9195 ),
9197 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
9198 % create_get_mutable_ref(active,State,GetMutable),
9199 CurrentSuspTest = (
9200 OtherSusp = OtherSuspension,
9201 GetState,
9202 DiffSuspGoals,
9203 FirstMatching
9204 ),
9205 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
9206 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
9207 inc_id(Id,NestedId),
9208 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
9209 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
9210 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
9211 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
9212 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9214 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9215 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9216 RecursiveVars = PreVarsAndSusps1
9217 ;
9218 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9219 PrevId0 = Id
9220 ),
9221 ( PrevId0 = [_] ->
9222 PrevId = PrevId0
9223 ;
9224 PrevId = [O|PrevId0]
9225 ),
9226 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9228 Clause = (
9229 ClauseHead :-
9230 ( CurrentSuspTest,
9231 NextSuspGoal
9232 ->
9233 NestedHead
9234 ; RecursiveHead
9235 )
9236 ),
9237 add_dummy_location(Clause,LocatedClause),
9238 L = [LocatedClause|T].
9240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9242 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9243 % Observation Analysis
9244 %
9245 % CLASSIFICATION
9246 % Enabled
9247 %
9248 % Analysis based on Abstract Interpretation paper.
9249 %
9250 % TODO:
9251 % stronger analysis domain [research]
9253 :- chr_constraint
9254 initial_call_pattern/1,
9255 call_pattern/1,
9256 call_pattern_worker/1,
9257 final_answer_pattern/2,
9258 abstract_constraints/1,
9259 depends_on/2,
9260 depends_on_ap/4,
9261 depends_on_goal/2,
9262 ai_observed_internal/2,
9263 % ai_observed/2,
9264 ai_not_observed_internal/2,
9265 ai_not_observed/2,
9266 ai_is_observed/2,
9267 depends_on_as/3,
9268 ai_observation_gather_results/0.
9270 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9271 :- chr_type program_point == any.
9273 :- chr_option(mode,initial_call_pattern(+)).
9274 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9276 :- chr_option(mode,call_pattern(+)).
9277 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9279 :- chr_option(mode,call_pattern_worker(+)).
9280 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9282 :- chr_option(mode,final_answer_pattern(+,+)).
9283 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9285 :- chr_option(mode,abstract_constraints(+)).
9286 :- chr_option(type_declaration,abstract_constraints(list)).
9288 :- chr_option(mode,depends_on(+,+)).
9289 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9291 :- chr_option(mode,depends_on_as(+,+,+)).
9292 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9293 :- chr_option(mode,depends_on_goal(+,+)).
9294 :- chr_option(mode,ai_is_observed(+,+)).
9295 :- chr_option(mode,ai_not_observed(+,+)).
9296 % :- chr_option(mode,ai_observed(+,+)).
9297 :- chr_option(mode,ai_not_observed_internal(+,+)).
9298 :- chr_option(mode,ai_observed_internal(+,+)).
9301 abstract_constraints_fd @
9302 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9304 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9305 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9306 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9308 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9309 ai_is_observed(_,_) <=> true.
9311 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9312 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9313 ai_observation_gather_results <=> true.
9315 %------------------------------------------------------------------------------%
9316 % Main Analysis Entry
9317 %------------------------------------------------------------------------------%
9318 ai_observation_analysis(ACs) :-
9319 ( chr_pp_flag(ai_observation_analysis,on),
9320 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9321 list_to_ord_set(ACs,ACSet),
9322 abstract_constraints(ACSet),
9323 ai_observation_schedule_initial_calls(ACSet,ACSet),
9324 ai_observation_gather_results
9325 ;
9326 true
9327 ).
9329 ai_observation_schedule_initial_calls([],_).
9330 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9331 ai_observation_schedule_initial_call(AC,ACs),
9332 ai_observation_schedule_initial_calls(RACs,ACs).
9334 ai_observation_schedule_initial_call(AC,ACs) :-
9335 ai_observation_top(AC,CallPattern),
9336 % ai_observation_bot(AC,ACs,CallPattern),
9337 initial_call_pattern(CallPattern).
9339 ai_observation_schedule_new_calls([],AP).
9340 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9341 AP = odom(_,Set),
9342 initial_call_pattern(odom(AC,Set)),
9343 ai_observation_schedule_new_calls(ACs,AP).
9345 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9346 <=>
9347 ai_observation_leq(AP2,AP1)
9348 |
9349 true.
9351 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9353 initial_call_pattern(CP) ==> call_pattern(CP).
9355 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9356 ==>
9357 ai_observation_schedule_new_calls(ACs,AP)
9358 pragma
9359 passive(ID3).
9361 call_pattern(CP) \ call_pattern(CP) <=> true.
9363 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9364 final_answer_pattern(CP1,AP).
9366 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9368 call_pattern(CP) ==> call_pattern_worker(CP).
9370 %------------------------------------------------------------------------------%
9371 % Abstract Goal
9372 %------------------------------------------------------------------------------%
9374 % AbstractGoala
9375 %call_pattern(odom([],Set)) ==>
9376 % final_answer_pattern(odom([],Set),odom([],Set)).
9378 call_pattern_worker(odom([],Set)) <=>
9379 % writeln(' - AbstractGoal'(odom([],Set))),
9380 final_answer_pattern(odom([],Set),odom([],Set)).
9382 % AbstractGoalb
9383 call_pattern_worker(odom([G|Gs],Set)) <=>
9384 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9385 CP1 = odom(G,Set),
9386 depends_on_goal(odom([G|Gs],Set),CP1),
9387 call_pattern(CP1).
9389 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9390 <=> true pragma passive(ID).
9391 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9392 ==>
9393 CP1 = odom([_|Gs],_),
9394 AP2 = odom([],Set),
9395 CCP = odom(Gs,Set),
9396 call_pattern(CCP),
9397 depends_on(CP1,CCP).
9399 %------------------------------------------------------------------------------%
9400 % Abstract Disjunction
9401 %------------------------------------------------------------------------------%
9403 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9404 CP = odom((AG1;AG2),Set),
9405 InitialAnswerApproximation = odom([],Set),
9406 final_answer_pattern(CP,InitialAnswerApproximation),
9407 CP1 = odom(AG1,Set),
9408 CP2 = odom(AG2,Set),
9409 call_pattern(CP1),
9410 call_pattern(CP2),
9411 depends_on_as(CP,CP1,CP2).
9413 %------------------------------------------------------------------------------%
9414 % Abstract Solve
9415 %------------------------------------------------------------------------------%
9416 call_pattern_worker(odom(builtin,Set)) <=>
9417 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9418 ord_empty(EmptySet),
9419 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9421 %------------------------------------------------------------------------------%
9422 % Abstract Drop
9423 %------------------------------------------------------------------------------%
9424 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9425 <=>
9426 O > MO
9427 |
9428 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9429 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9430 pragma
9431 passive(ID2).
9433 %------------------------------------------------------------------------------%
9434 % Abstract Activate
9435 %------------------------------------------------------------------------------%
9436 call_pattern_worker(odom(AC,Set))
9437 <=>
9438 AC = _ / _
9439 |
9440 % writeln(' - AbstractActivate'(odom(AC,Set))),
9441 CP = odom(occ(AC,1),Set),
9442 call_pattern(CP),
9443 depends_on(odom(AC,Set),CP).
9445 %------------------------------------------------------------------------------%
9446 % Abstract Passive
9447 %------------------------------------------------------------------------------%
9448 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9449 <=>
9450 is_passive(RuleNb,ID)
9451 |
9452 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9453 % DEFAULT
9454 NO is O + 1,
9455 DCP = odom(occ(C,NO),Set),
9456 call_pattern(DCP),
9457 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9458 depends_on(odom(occ(C,O),Set),DCP)
9459 pragma
9460 passive(ID2).
9461 %------------------------------------------------------------------------------%
9462 % Abstract Simplify
9463 %------------------------------------------------------------------------------%
9465 % AbstractSimplify
9466 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9467 <=>
9468 \+ is_passive(RuleNb,ID)
9469 |
9470 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9471 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9472 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9473 ai_observation_memo_abstract_goal(RuleNb,AG),
9474 call_pattern(odom(AG,Set2)),
9475 % DEFAULT
9476 NO is O + 1,
9477 DCP = odom(occ(C,NO),Set),
9478 call_pattern(DCP),
9479 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9480 % DEADLOCK AVOIDANCE
9481 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9482 pragma
9483 passive(ID2).
9485 depends_on_as(CP,CPS,CPD),
9486 final_answer_pattern(CPS,APS),
9487 final_answer_pattern(CPD,APD) ==>
9488 ai_observation_lub(APS,APD,AP),
9489 final_answer_pattern(CP,AP).
9492 :- chr_constraint
9493 ai_observation_memo_simplification_rest_heads/3,
9494 ai_observation_memoed_simplification_rest_heads/3.
9496 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9497 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9499 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9500 <=>
9501 QRH = RH.
9502 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9503 <=>
9504 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9505 once(select2(ID,_,IDs1,H1,_,RestH1)),
9506 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9507 ai_observation_abstract_constraints(H2,ACs,AH2),
9508 append(ARestHeads,AH2,AbstractHeads),
9509 sort(AbstractHeads,QRH),
9510 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9511 pragma
9512 passive(ID1),
9513 passive(ID2),
9514 passive(ID3).
9516 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9518 %------------------------------------------------------------------------------%
9519 % Abstract Propagate
9520 %------------------------------------------------------------------------------%
9523 % AbstractPropagate
9524 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9525 <=>
9526 \+ is_passive(RuleNb,ID)
9527 |
9528 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9529 % observe partners
9530 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9531 ai_observation_observe_set(Set,AHs,Set2),
9532 ord_add_element(Set2,C,Set3),
9533 ai_observation_memo_abstract_goal(RuleNb,AG),
9534 call_pattern(odom(AG,Set3)),
9535 ( ord_memberchk(C,Set2) ->
9536 Delete = no
9537 ;
9538 Delete = yes
9539 ),
9540 % DEFAULT
9541 NO is O + 1,
9542 DCP = odom(occ(C,NO),Set),
9543 call_pattern(DCP),
9544 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9545 pragma
9546 passive(ID2).
9548 :- chr_constraint
9549 ai_observation_memo_propagation_rest_heads/3,
9550 ai_observation_memoed_propagation_rest_heads/3.
9552 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9553 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9555 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9556 <=>
9557 QRH = RH.
9558 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9559 <=>
9560 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9561 once(select2(ID,_,IDs2,H2,_,RestH2)),
9562 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9563 ai_observation_abstract_constraints(H1,ACs,AH1),
9564 append(ARestHeads,AH1,AbstractHeads),
9565 sort(AbstractHeads,QRH),
9566 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9567 pragma
9568 passive(ID1),
9569 passive(ID2),
9570 passive(ID3).
9572 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9574 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9575 final_answer_pattern(CP,APD).
9576 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9577 final_answer_pattern(CPD,APD) ==>
9578 true |
9579 CP = odom(occ(C,O),_),
9580 ( ai_observation_is_observed(APP,C) ->
9581 ai_observed_internal(C,O)
9582 ;
9583 ai_not_observed_internal(C,O)
9584 ),
9585 ( Delete == yes ->
9586 APP = odom([],Set0),
9587 ord_del_element(Set0,C,Set),
9588 NAPP = odom([],Set)
9589 ;
9590 NAPP = APP
9591 ),
9592 ai_observation_lub(NAPP,APD,AP),
9593 final_answer_pattern(CP,AP).
9595 %------------------------------------------------------------------------------%
9596 % Catch All
9597 %------------------------------------------------------------------------------%
9599 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9601 %------------------------------------------------------------------------------%
9602 % Auxiliary Predicates
9603 %------------------------------------------------------------------------------%
9605 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9606 ord_intersection(S1,S2,S3).
9608 ai_observation_bot(AG,AS,odom(AG,AS)).
9610 ai_observation_top(AG,odom(AG,EmptyS)) :-
9611 ord_empty(EmptyS).
9613 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9614 ord_subset(S2,S1).
9616 ai_observation_observe_set(S,ACSet,NS) :-
9617 ord_subtract(S,ACSet,NS).
9619 ai_observation_abstract_constraint(C,ACs,AC) :-
9620 functor(C,F,A),
9621 AC = F/A,
9622 memberchk(AC,ACs).
9624 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9625 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9627 %------------------------------------------------------------------------------%
9628 % Abstraction of Rule Bodies
9629 %------------------------------------------------------------------------------%
9631 :- chr_constraint
9632 ai_observation_memoed_abstract_goal/2,
9633 ai_observation_memo_abstract_goal/2.
9635 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9636 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9638 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9639 <=>
9640 QAG = AG
9641 pragma
9642 passive(ID1).
9644 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9645 <=>
9646 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9647 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9648 QAG = AG,
9649 ai_observation_memoed_abstract_goal(RuleNb,AG)
9650 pragma
9651 passive(ID1),
9652 passive(ID2).
9654 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9655 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9656 term_variables((H1,H2,Guard),HVars),
9657 append(H1,H2,Heads),
9658 % variables that are declared to be ground are safe,
9659 ground_vars(Heads,GroundVars),
9660 % so we remove them from the list of 'dangerous' head variables
9661 list_difference_eq(HVars,GroundVars,HV),
9662 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9663 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9664 % HV are 'dangerous' variables, all others are fresh and safe
9666 ground_vars([],[]).
9667 ground_vars([H|Hs],GroundVars) :-
9668 functor(H,F,A),
9669 get_constraint_mode(F/A,Mode),
9670 % TOM: fix this code!
9671 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9672 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9673 ground_vars(Hs,GroundVars2),
9674 append(GroundVars1,GroundVars2,GroundVars).
9676 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9677 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9678 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9679 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9680 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9681 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9682 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9683 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9684 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9685 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9686 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9687 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9688 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9689 % non-CHR constraint is safe if it only binds fresh variables
9690 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9691 builtin_binds_b(G,Vars),
9692 intersect_eq(Vars,HV,[]),
9693 !.
9694 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9695 AG = builtin. % default case if goal is not recognized/safe
9697 ai_observation_is_observed(odom(_,ACSet),AC) :-
9698 \+ ord_memberchk(AC,ACSet).
9700 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9701 unconditional_occurrence(C,O) :-
9702 get_occurrence(C,O,RuleNb,ID),
9703 get_rule(RuleNb,PRule),
9704 PRule = pragma(ORule,_,_,_,_),
9705 copy_term_nat(ORule,Rule),
9706 Rule = rule(H1,H2,Guard,_),
9707 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9708 once((
9709 H1 = [Head], H2 == []
9710 ;
9711 H2 = [Head], H1 == [], \+ may_trigger(C)
9712 )),
9713 all_distinct_var_args(Head).
9715 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9717 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9718 % Partial wake analysis
9719 %
9720 % In a Var = Var unification do not wake up constraints of both variables,
9721 % but rather only those of one variable.
9722 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9724 :- chr_constraint partial_wake_analysis/0.
9725 :- chr_constraint no_partial_wake/1.
9726 :- chr_option(mode,no_partial_wake(+)).
9727 :- chr_constraint wakes_partially/1.
9728 :- chr_option(mode,wakes_partially(+)).
9730 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9731 ==>
9732 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9733 ( is_passive(RuleNb,ID) ->
9734 true
9735 ; Type == simplification ->
9736 select(H,H1,RestH1),
9737 H =.. [_|Args],
9738 term_variables(Guard,Vars),
9739 partial_wake_args(Args,ArgModes,Vars,FA)
9740 ; % Type == propagation ->
9741 select(H,H2,RestH2),
9742 H =.. [_|Args],
9743 term_variables(Guard,Vars),
9744 partial_wake_args(Args,ArgModes,Vars,FA)
9745 ).
9747 partial_wake_args([],_,_,_).
9748 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9749 ( Mode \== (+) ->
9750 ( nonvar(Arg) ->
9751 no_partial_wake(C)
9752 ; memberchk_eq(Arg,Vars) ->
9753 no_partial_wake(C)
9754 ;
9755 true
9756 )
9757 ;
9758 true
9759 ),
9760 partial_wake_args(Args,Modes,Vars,C).
9762 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9764 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9766 wakes_partially(C) <=> true.
9769 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9770 % Generate rules that implement chr_show_store/1 functionality.
9771 %
9772 % CLASSIFICATION
9773 % Experimental
9774 % Unused
9775 %
9776 % Generates additional rules:
9777 %
9778 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9779 % ...
9780 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9781 % $show <=> true.
9783 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9784 ( chr_pp_flag(show,on) ->
9785 Constraints = ['$show'/0|Constraints0],
9786 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9787 inc_rule_count(RuleNb),
9788 Rule = pragma(
9789 rule(['$show'],[],true,true),
9790 ids([0],[]),
9791 [],
9792 no,
9793 RuleNb
9794 )
9795 ;
9796 Constraints = Constraints0,
9797 Rules = Rules0
9798 ).
9800 generate_show_rules([],Rules,Rules).
9801 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9802 functor(C,F,A),
9803 inc_rule_count(RuleNb),
9804 Rule = pragma(
9805 rule([],['$show',C],true,writeln(C)),
9806 ids([],[0,1]),
9807 [passive(1)],
9808 no,
9809 RuleNb
9810 ),
9811 generate_show_rules(Rest,Tail,Rules).
9813 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9814 % Custom supension term layout
9816 static_suspension_term(F/A,Suspension) :-
9817 suspension_term_base(F/A,Base),
9818 Arity is Base + A,
9819 functor(Suspension,suspension,Arity).
9821 has_suspension_field(FA,Field) :-
9822 suspension_term_base_fields(FA,Fields),
9823 memberchk(Field,Fields).
9825 suspension_term_base(FA,Base) :-
9826 suspension_term_base_fields(FA,Fields),
9827 length(Fields,Base).
9829 suspension_term_base_fields(FA,Fields) :-
9830 ( chr_pp_flag(debugable,on) ->
9831 % 1. ID
9832 % 2. State
9833 % 3. Propagation History
9834 % 4. Generation Number
9835 % 5. Continuation Goal
9836 % 6. Functor
9837 Fields = [id,state,history,generation,continuation,functor]
9838 ;
9839 ( uses_history(FA) ->
9840 Fields = [id,state,history|Fields2]
9841 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9842 Fields = [state|Fields2]
9843 ;
9844 Fields = [id,state|Fields2]
9845 ),
9846 ( only_ground_indexed_arguments(FA) ->
9847 get_store_type(FA,StoreType),
9848 basic_store_types(StoreType,BasicStoreTypes),
9849 ( memberchk(global_ground,BasicStoreTypes) ->
9850 % 1. ID
9851 % 2. State
9852 % 3. Propagation History
9853 % 4. Global List Prev
9854 Fields2 = [global_list_prev|Fields3]
9855 ;
9856 % 1. ID
9857 % 2. State
9858 % 3. Propagation History
9859 Fields2 = Fields3
9860 ),
9861 ( chr_pp_flag(ht_removal,on)
9862 -> ht_prev_fields(BasicStoreTypes,Fields3)
9863 ; Fields3 = []
9864 )
9865 ; may_trigger(FA) ->
9866 % 1. ID
9867 % 2. State
9868 % 3. Propagation History
9869 ( uses_field(FA,generation) ->
9870 % 4. Generation Number
9871 % 5. Global List Prev
9872 Fields2 = [generation,global_list_prev|Fields3]
9873 ;
9874 Fields2 = [global_list_prev|Fields3]
9875 ),
9876 ( chr_pp_flag(mixed_stores,on),
9877 chr_pp_flag(ht_removal,on)
9878 -> get_store_type(FA,StoreType),
9879 basic_store_types(StoreType,BasicStoreTypes),
9880 ht_prev_fields(BasicStoreTypes,Fields3)
9881 ; Fields3 = []
9882 )
9883 ;
9884 % 1. ID
9885 % 2. State
9886 % 3. Propagation History
9887 % 4. Global List Prev
9888 Fields2 = [global_list_prev|Fields3],
9889 ( chr_pp_flag(mixed_stores,on),
9890 chr_pp_flag(ht_removal,on)
9891 -> get_store_type(FA,StoreType),
9892 basic_store_types(StoreType,BasicStoreTypes),
9893 ht_prev_fields(BasicStoreTypes,Fields3)
9894 ; Fields3 = []
9895 )
9896 )
9897 ).
9899 ht_prev_fields(Stores,Prevs) :-
9900 ht_prev_fields_int(Stores,PrevsList),
9901 append(PrevsList,Prevs).
9902 ht_prev_fields_int([],[]).
9903 ht_prev_fields_int([H|T],Fields) :-
9904 ( H = multi_hash(Indexes)
9905 -> maplist(ht_prev_field,Indexes,FH),
9906 Fields = [FH|FT]
9907 ; Fields = FT
9908 ),
9909 ht_prev_fields_int(T,FT).
9911 ht_prev_field(Index,Field) :-
9912 concat_atom(['multi_hash_prev-'|Index],Field).
9914 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9915 suspension_term_base_fields(FA,Fields),
9916 nth1(Index,Fields,FieldName), !,
9917 arg(Index,StaticSuspension,Field).
9918 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9919 suspension_term_base(FA,Base),
9920 StaticSuspension =.. [_|Args],
9921 drop(Base,Args,Field).
9922 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9923 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9926 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9927 suspension_term_base_fields(FA,Fields),
9928 nth1(Index,Fields,FieldName), !,
9929 Goal = arg(Index,DynamicSuspension,Field).
9930 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9931 static_suspension_term(FA,StaticSuspension),
9932 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9933 Goal = (DynamicSuspension = StaticSuspension).
9934 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9935 suspension_term_base(FA,Base),
9936 Index is I + Base,
9937 Goal = arg(Index,DynamicSuspension,Field).
9938 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9939 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9942 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9943 suspension_term_base_fields(FA,Fields),
9944 nth1(Index,Fields,FieldName), !,
9945 Goal = setarg(Index,DynamicSuspension,Field).
9946 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9947 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9949 basic_store_types(multi_store(Types),Types) :- !.
9950 basic_store_types(Type,[Type]).
9952 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9953 %
9955 :- chr_constraint
9956 phase_end/1,
9957 delay_phase_end/2.
9959 :- chr_option(mode,phase_end(+)).
9960 :- chr_option(mode,delay_phase_end(+,?)).
9962 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9963 % phase_end(Phase) <=> true.
9966 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9967 :- chr_constraint
9968 does_use_history/2,
9969 uses_history/1,
9970 novel_production_call/4.
9972 :- chr_option(mode,uses_history(+)).
9973 :- chr_option(mode,does_use_history(+,+)).
9974 :- chr_option(mode,novel_production_call(+,+,?,?)).
9976 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9977 does_use_history(FA,_) \ uses_history(FA) <=> true.
9978 uses_history(_FA) <=> fail.
9980 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9981 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9983 :- chr_constraint
9984 does_use_field/2,
9985 uses_field/2.
9987 :- chr_option(mode,uses_field(+,+)).
9988 :- chr_option(mode,does_use_field(+,+)).
9990 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9991 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9992 uses_field(_FA,_Field) <=> fail.
9994 :- chr_constraint
9995 uses_state/2,
9996 if_used_state/5,
9997 used_states_known/0.
9999 :- chr_option(mode,uses_state(+,+)).
10000 :- chr_option(mode,if_used_state(+,+,?,?,?)).
10003 % states ::= not_stored_yet | passive | active | triggered | removed
10004 %
10005 % allocate CREATES not_stored_yet
10006 % remove CHECKS not_stored_yet
10007 % activate CHECKS not_stored_yet
10008 %
10009 % ==> no allocate THEN no not_stored_yet
10011 % recurs CREATES inactive
10012 % lookup CHECKS inactive
10014 % insert CREATES active
10015 % activate CREATES active
10016 % lookup CHECKS active
10017 % recurs CHECKS active
10019 % runsusp CREATES triggered
10020 % lookup CHECKS triggered
10021 %
10022 % ==> no runsusp THEN no triggered
10024 % remove CREATES removed
10025 % runsusp CHECKS removed
10026 % lookup CHECKS removed
10027 % recurs CHECKS removed
10028 %
10029 % ==> no remove THEN no removed
10031 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
10033 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
10035 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10036 <=> ResultGoal = Used.
10037 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10038 <=> ResultGoal = NotUsed.
10040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10041 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
10042 % (Feature for SSS)
10043 %
10044 % 1. Checking
10045 % ~~~~~~~~~~~
10046 %
10047 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10048 %
10049 % :- chr_option(declare_stored_constraints,on).
10050 %
10051 % the compiler will check for the storedness of constraints.
10052 %
10053 % By default, the compiler assumes that the programmer wants his constraints to
10054 % be never-stored. Hence, a warning will be issues when a constraint is actually
10055 % stored.
10056 %
10057 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
10058 % to a constraint declaration, i.e. writes
10059 %
10060 % :- chr_constraint c(...) # stored.
10061 %
10062 % In that case a warning is issued when the constraint is never-stored.
10063 %
10064 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
10065 % constraints are stored anyway.
10066 %
10067 %
10068 % 2. Rule Generation
10069 % ~~~~~~~~~~~~~~~~~~
10070 %
10071 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10072 %
10073 % :- chr_option(declare_stored_constraints,on).
10074 %
10075 % the compiler will generate default simplification rules for constraints.
10076 %
10077 % By default, no default rule is generated for a constraint. However, if the
10078 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
10079 %
10080 % :- chr_constraint c(...) # default(Goal).
10081 %
10082 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
10083 % the compiler generates a rule:
10084 %
10085 % c(_,...,_) <=> Goal.
10086 %
10087 % at the end of the program. If multiple default rules are generated, for several constraints,
10088 % then the order of the default rules is not specified.
10091 :- chr_constraint stored_assertion/1.
10092 :- chr_option(mode,stored_assertion(+)).
10093 :- chr_option(type_declaration,stored_assertion(constraint)).
10095 :- chr_constraint never_stored_default/2.
10096 :- chr_option(mode,never_stored_default(+,?)).
10097 :- chr_option(type_declaration,never_stored_default(constraint,any)).
10099 % Rule Generation
10100 % ~~~~~~~~~~~~~~~
10102 generate_never_stored_rules(Constraints,Rules) :-
10103 ( chr_pp_flag(declare_stored_constraints,on) ->
10104 never_stored_rules(Constraints,Rules)
10105 ;
10106 Rules = []
10107 ).
10109 :- chr_constraint never_stored_rules/2.
10110 :- chr_option(mode,never_stored_rules(+,?)).
10111 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
10113 never_stored_rules([],Rules) <=> Rules = [].
10114 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
10115 Constraint = F/A,
10116 functor(Head,F,A),
10117 inc_rule_count(RuleNb),
10118 Rule = pragma(
10119 rule([Head],[],true,Goal),
10120 ids([0],[]),
10121 [],
10122 no,
10123 RuleNb
10124 ),
10125 Rules = [Rule|Tail],
10126 never_stored_rules(Constraints,Tail).
10127 never_stored_rules([_|Constraints],Rules) <=>
10128 never_stored_rules(Constraints,Rules).
10130 % Checking
10131 % ~~~~~~~~
10133 check_storedness_assertions(Constraints) :-
10134 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
10135 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
10136 ;
10137 true
10138 ).
10141 :- chr_constraint check_storedness_assertion/1.
10142 :- chr_option(mode,check_storedness_assertion(+)).
10143 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
10145 check_storedness_assertion(Constraint), stored_assertion(Constraint)
10146 <=> ( is_stored(Constraint) ->
10147 true
10148 ;
10149 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
10150 ).
10151 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
10152 <=> ( is_finally_stored(Constraint) ->
10153 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10154 ; is_stored(Constraint) ->
10155 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10156 ;
10157 true
10158 ).
10159 % never-stored, no default goal
10160 check_storedness_assertion(Constraint)
10161 <=> ( is_finally_stored(Constraint) ->
10162 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10163 ; is_stored(Constraint) ->
10164 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10165 ;
10166 true
10167 ).
10169 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
10170 % success continuation analysis
10172 % TODO
10173 % also use for forward jumping improvement!
10174 % use Prolog indexing for generated code
10175 %
10176 % EXPORTED
10177 %
10178 % should_skip_to_next_id(C,O)
10179 %
10180 % get_occurrence_code_id(C,O,Id)
10181 %
10182 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
10184 continuation_analysis(ConstraintSymbols) :-
10185 maplist(analyse_continuations,ConstraintSymbols).
10187 analyse_continuations(C) :-
10188 % 1. compute success continuations of the
10189 % occurrences of constraint C
10190 continuation_analysis(C,1),
10191 % 2. determine for which occurrences
10192 % to skip to next code id
10193 get_max_occurrence(C,MO),
10194 LO is MO + 1,
10195 bulk_propagation(C,1,LO),
10196 % 3. determine code id for each occurrence
10197 set_occurrence_code_id(C,1,0).
10199 % 1. Compute the success continuations of constrait C
10200 %-------------------------------------------------------------------------------
10202 continuation_analysis(C,O) :-
10203 get_max_occurrence(C,MO),
10204 ( O > MO ->
10205 true
10206 ; O == MO ->
10207 NextO is O + 1,
10208 continuation_occurrence(C,O,NextO)
10209 ;
10210 constraint_continuation(C,O,MO,NextO),
10211 continuation_occurrence(C,O,NextO),
10212 NO is O + 1,
10213 continuation_analysis(C,NO)
10214 ).
10216 constraint_continuation(C,O,MO,NextO) :-
10217 ( get_occurrence_head(C,O,Head) ->
10218 NO is O + 1,
10219 ( between(NO,MO,NextO),
10220 get_occurrence_head(C,NextO,NextHead),
10221 unifiable(Head,NextHead,_) ->
10222 true
10223 ;
10224 NextO is MO + 1
10225 )
10226 ; % current occurrence is passive
10227 NextO = MO
10228 ).
10230 get_occurrence_head(C,O,Head) :-
10231 get_occurrence(C,O,RuleNb,Id),
10232 \+ is_passive(RuleNb,Id),
10233 get_rule(RuleNb,Rule),
10234 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10235 ( select2(Id,Head,Ids1,H1,_,_) -> true
10236 ; select2(Id,Head,Ids2,H2,_,_)
10237 ).
10239 :- chr_constraint continuation_occurrence/3.
10240 :- chr_option(mode,continuation_occurrence(+,+,+)).
10242 :- chr_constraint get_success_continuation_occurrence/3.
10243 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10245 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10246 <=>
10247 X = NO.
10249 get_success_continuation_occurrence(C,O,X)
10250 <=>
10251 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10253 % 2. figure out when to skip to next code id
10254 %-------------------------------------------------------------------------------
10255 % don't go beyond the last occurrence
10256 % we have to go to next id for storage here
10258 :- chr_constraint skip_to_next_id/2.
10259 :- chr_option(mode,skip_to_next_id(+,+)).
10261 :- chr_constraint should_skip_to_next_id/2.
10262 :- chr_option(mode,should_skip_to_next_id(+,+)).
10264 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10265 <=>
10266 true.
10268 should_skip_to_next_id(_,_)
10269 <=>
10270 fail.
10272 :- chr_constraint bulk_propagation/3.
10273 :- chr_option(mode,bulk_propagation(+,+,+)).
10275 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10276 <=>
10277 O >= MO
10278 |
10279 skip_to_next_id(C,O).
10280 % we have to go to the next id here because
10281 % a predecessor needs it
10282 bulk_propagation(C,O,LO)
10283 <=>
10284 LO =:= O + 1
10285 |
10286 skip_to_next_id(C,O),
10287 get_max_occurrence(C,MO),
10288 NLO is MO + 1,
10289 bulk_propagation(C,LO,NLO).
10290 % we have to go to the next id here because
10291 % we're running into a simplification rule
10292 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10293 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10294 <=>
10295 NO =:= O + 1
10296 |
10297 skip_to_next_id(C,O),
10298 get_max_occurrence(C,MO),
10299 NLO is MO + 1,
10300 bulk_propagation(C,NO,NLO).
10301 % we skip the next id here
10302 % and go to the next occurrence
10303 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10304 <=>
10305 NextO > O + 1
10306 |
10307 NLO is min(LO,NextO),
10308 NO is O + 1,
10309 bulk_propagation(C,NO,NLO).
10310 % default case
10311 % err on the safe side
10312 bulk_propagation(C,O,LO)
10313 <=>
10314 skip_to_next_id(C,O),
10315 get_max_occurrence(C,MO),
10316 NLO is MO + 1,
10317 NO is O + 1,
10318 bulk_propagation(C,NO,NLO).
10320 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10322 % if this occurrence is passive, but has to skip,
10323 % then the previous one must skip instead...
10324 % IMPROVE reasoning is conservative
10325 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10326 ==>
10327 O > 1
10328 |
10329 PO is O - 1,
10330 skip_to_next_id(C,PO).
10332 % 3. determine code id of each occurrence
10333 %-------------------------------------------------------------------------------
10335 :- chr_constraint set_occurrence_code_id/3.
10336 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10338 :- chr_constraint occurrence_code_id/3.
10339 :- chr_option(mode,occurrence_code_id(+,+,+)).
10341 % stop at the end
10342 set_occurrence_code_id(C,O,IdNb)
10343 <=>
10344 get_max_occurrence(C,MO),
10345 O > MO
10346 |
10347 occurrence_code_id(C,O,IdNb).
10349 % passive occurrences don't change the code id
10350 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10351 <=>
10352 occurrence_code_id(C,O,IdNb),
10353 NO is O + 1,
10354 set_occurrence_code_id(C,NO,IdNb).
10356 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10357 <=>
10358 occurrence_code_id(C,O,IdNb),
10359 NO is O + 1,
10360 set_occurrence_code_id(C,NO,IdNb).
10362 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10363 <=>
10364 occurrence_code_id(C,O,IdNb),
10365 NO is O + 1,
10366 NIdNb is IdNb + 1,
10367 set_occurrence_code_id(C,NO,NIdNb).
10369 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10370 <=>
10371 occurrence_code_id(C,O,IdNb),
10372 NO is O + 1,
10373 set_occurrence_code_id(C,NO,IdNb).
10375 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10377 :- chr_constraint get_occurrence_code_id/3.
10378 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10380 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10381 <=>
10382 X = IdNb.
10384 get_occurrence_code_id(C,O,X)
10385 <=>
10386 ( O == 0 ->
10387 true % X = 0
10388 ;
10389 format('no occurrence code for ~w!\n',[C:O])
10390 ).
10392 get_success_continuation_code_id(C,O,NextId) :-
10393 get_success_continuation_occurrence(C,O,NextO),
10394 get_occurrence_code_id(C,NextO,NextId).
10396 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10397 % COLLECT CONSTANTS FOR INLINING
10398 %
10399 % for SSS
10401 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10403 % collect_constants(+rules,+ast_rules,+constraint_symbols,+clauses) {{{
10404 collect_constants(Rules,AstRules,Constraints,Clauses0) :-
10405 ( not_restarted, chr_pp_flag(experiment,on) ->
10406 ( chr_pp_flag(sss,on) ->
10407 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10408 copy_term_nat(Clauses0,Clauses),
10409 flatten_clauses(Clauses,Dictionary,FlatClauses),
10410 install_new_declarations_and_restart(FlatClauses)
10411 ;
10412 maplist(collect_rule_constants(Constraints),AstRules),
10413 ( chr_pp_flag(verbose,on) ->
10414 print_chr_constants
10415 ;
10416 true
10417 ),
10418 ( chr_pp_flag(experiment,on) ->
10419 flattening_dictionary(Constraints,Dictionary),
10420 copy_term_nat(Clauses0,Clauses),
10421 flatten_clauses(Clauses,Dictionary,FlatClauses),
10422 install_new_declarations_and_restart(FlatClauses)
10423 ;
10424 true
10425 )
10426 )
10427 ;
10428 true
10429 ).
10431 :- chr_constraint chr_constants/1.
10432 :- chr_option(mode,chr_constants(+)).
10434 :- chr_constraint get_chr_constants/1.
10436 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10438 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10440 % collect_rule_constants(+constraint_symbols,+ast_rule) {{{
10441 collect_rule_constants(Constraints,AstRule) :-
10442 AstRule = ast_rule(AstHead,_,_,AstBody,_),
10443 collect_head_constants(AstHead),
10444 collect_body_constants(AstBody,Constraints).
10446 collect_head_constants(simplification(H1)) :-
10447 maplist(collect_constraint_constants,H1).
10448 collect_head_constants(propagation(H2)) :-
10449 maplist(collect_constraint_constants,H2).
10450 collect_head_constants(simpagation(H1,H2)) :-
10451 maplist(collect_constraint_constants,H1),
10452 maplist(collect_constraint_constants,H2).
10454 collect_body_constants(AstBody,Constraints) :-
10455 maplist(collect_goal_constants(Constraints),AstBody).
10457 collect_goal_constants(Constraints,Goal) :-
10458 ( ast_nonvar(Goal) ->
10459 ast_symbol(Goal,Symbol),
10460 ( memberchk(Symbol,Constraints) ->
10461 ast_term_to_term(Goal,Term),
10462 ast_args(Goal,Arguments),
10463 collect_constraint_constants(chr_constraint(Symbol,Arguments,Term))
10464 ; Symbol == (:)/2,
10465 ast_args(Goal,[Arg1,Goal2]),
10466 Arg1 = atomic(Mod),
10467 get_target_module(Module),
10468 Mod == Module,
10469 ast_nonvar(Goal2),
10470 ast_symbol(Goal2,Symbol2),
10471 memberchk(Symbol2,Constraints) ->
10472 ast_term_to_term(Goal2,Term2),
10473 ast_args(Goal2,Arguments2),
10474 collect_constraint_constants(chr_constraint(Symbol2,Arguments2,Term2))
10475 ;
10476 true
10477 )
10478 ;
10479 true
10480 ).
10482 collect_constraint_constants(Head) :-
10483 Head = chr_constraint(Symbol,Arguments,_),
10484 get_constraint_type_det(Symbol,Types),
10485 collect_all_arg_constants(Arguments,Types,[]).
10487 collect_all_arg_constants([],[],Constants) :-
10488 ( Constants \== [] ->
10489 add_chr_constants(Constants)
10490 ;
10491 true
10492 ).
10493 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10494 unalias_type(Type,NormalizedType),
10495 ( is_chr_constants_type(NormalizedType,Key,_) ->
10496 ( ast_ground(Arg) ->
10497 ast_term_to_term(Arg,Term),
10498 collect_all_arg_constants(Args,Types,[Key-Term|Constants0])
10499 ; % no useful information here
10500 true
10501 )
10502 ;
10503 collect_all_arg_constants(Args,Types,Constants0)
10504 ).
10506 add_chr_constants(Pairs) :-
10507 keysort(Pairs,SortedPairs),
10508 add_chr_constants_(SortedPairs).
10510 :- chr_constraint add_chr_constants_/1.
10511 :- chr_option(mode,add_chr_constants_(+)).
10513 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10514 sort([Constants|MoreConstants],NConstants),
10515 chr_constants(NConstants).
10517 add_chr_constants_(Constants) <=>
10518 chr_constants([Constants]).
10520 % }}}
10522 :- chr_constraint print_chr_constants/0. % {{{
10524 print_chr_constants, chr_constants(Constants) # Id ==>
10525 format('\t* chr_constants : ~w.\n',[Constants])
10526 pragma passive(Id).
10528 print_chr_constants <=>
10529 true.
10531 % }}}
10533 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10534 flattening_dictionary([],[]).
10535 flattening_dictionary([CS|CSs],Dictionary) :-
10536 ( flattening_dictionary_entry(CS,Entry) ->
10537 Dictionary = [Entry|Rest]
10538 ;
10539 Dictionary = Rest
10540 ),
10541 flattening_dictionary(CSs,Rest).
10543 flattening_dictionary_entry(CS,Entry) :-
10544 get_constraint_type_det(CS,Types),
10545 constant_positions(Types,1,Positions,Keys,Handler,MaybeEnum),
10546 ( Positions \== [] -> % there are chr_constant arguments
10547 pairup(Keys,Constants,Pairs0),
10548 keysort(Pairs0,Pairs),
10549 Entry = CS-Positions-Specs-Handler,
10550 get_chr_constants(ConstantsList),
10551 findall(Spec,
10552 ( member(Pairs,ConstantsList)
10553 , flat_spec(CS,Positions,Constants,Spec)
10554 ),
10555 Specs)
10556 ; MaybeEnum == yes ->
10557 enum_positions(Types,1,EnumPositions,ConstantsLists,EnumHandler),
10558 Entry = CS-EnumPositions-Specs-EnumHandler,
10559 findall(Spec,
10560 ( cartesian_product(Terms,ConstantsLists)
10561 , flat_spec(CS,EnumPositions,Terms,Spec)
10562 ),
10563 Specs)
10564 ).
10566 constant_positions([],_,[],[],no,no).
10567 constant_positions([Type|Types],I,Positions,Keys,Handler,MaybeEnum) :-
10568 unalias_type(Type,NormalizedType),
10569 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10570 compose_error_handlers(ErrorHandler,NHandler,Handler),
10571 Positions = [I|NPositions],
10572 Keys = [Key|NKeys],
10573 MaybeEnum = NMaybeEnum
10574 ;
10575 ( is_chr_enum_type(NormalizedType,_,_) ->
10576 MaybeEnum = yes
10577 ;
10578 MaybeEnum = NMaybeEnum
10579 ),
10580 NPositions = Positions,
10581 NKeys = Keys,
10582 NHandler = Handler
10583 ),
10584 J is I + 1,
10585 constant_positions(Types,J,NPositions,NKeys,NHandler,NMaybeEnum).
10587 compose_error_handlers(no,Handler,Handler).
10588 compose_error_handlers(yes(Handler),_,yes(Handler)).
10590 enum_positions([],_,[],[],no).
10591 enum_positions([Type|Types],I,Positions,ConstantsLists,Handler) :-
10592 unalias_type(Type,NormalizedType),
10593 ( is_chr_enum_type(NormalizedType,Constants,ErrorHandler) ->
10594 compose_error_handlers(ErrorHandler,NHandler,Handler),
10595 Positions = [I|NPositions],
10596 ConstantsLists = [Constants|NConstantsLists]
10597 ; Positions = NPositions,
10598 ConstantsLists = NConstantsLists,
10599 Handler = NHandler
10600 ),
10601 J is I + 1,
10602 enum_positions(Types,J,NPositions,NConstantsLists,NHandler).
10604 cartesian_product([],[]).
10605 cartesian_product([E|Es],[L|Ls]) :-
10606 member(E,L),
10607 cartesian_product(Es,Ls).
10609 flat_spec(C/N,Positions,Terms,Spec) :-
10610 Spec = Terms - Functor,
10611 term_to_atom(Terms,TermsAtom),
10612 term_to_atom(Positions,PositionsAtom),
10613 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10615 % }}}
10617 % }}}
10618 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10619 % RESTART AFTER FLATTENING {{{
10621 restart_after_flattening(Declarations,Declarations) :-
10622 nb_setval('$chr_restart_after_flattening',started).
10623 restart_after_flattening(_,Declarations) :-
10624 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10625 nb_setval('$chr_restart_after_flattening',restarted).
10627 not_restarted :-
10628 nb_getval('$chr_restart_after_flattening',started).
10630 install_new_declarations_and_restart(Declarations) :-
10631 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10632 fail. /* fails to choicepoint of restart_after_flattening */
10633 % }}}
10634 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10635 % FLATTENING {{{
10637 % DONE
10638 % -) generate dictionary from collected chr_constants
10639 % enable with :- chr_option(experiment,on).
10640 % -) issue constraint declarations for constraints not present in
10641 % dictionary
10642 % -) integrate with CHR compiler
10643 % -) pass Mike's test code (full syntactic support for current CHR code)
10644 % -) rewrite the body using the inliner
10645 %
10646 % TODO:
10647 % -) refined semantics correctness issue
10648 % -) incorporate chr_enum into dictionary generation
10649 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10651 flatten_clauses(Clauses,Dict,NClauses) :-
10652 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10653 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10655 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10656 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10657 dispatching_rules(Dict,NClauses1),
10658 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10659 flatten_rules(Clauses,Dict,NClauses3),
10660 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10662 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10663 % Declarations for non-flattened constraints
10665 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10666 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10667 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10668 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10669 flatten(DeclarationsList,Declarations).
10671 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10672 [(:- chr_constraint ConstraintSymbol),
10673 (:- chr_option(mode,ModeDeclPattern)),
10674 (:- chr_option(type_declaration,TypeDeclPattern))
10675 ]) :-
10676 ConstraintSymbol = Functor / Arity,
10677 % print optional mode declaration
10678 functor(ModeDeclPattern,Functor,Arity),
10679 ( memberchk(ModeDeclPattern,ModeDecls) ->
10680 true
10681 ;
10682 replicate(Arity,(?),Modes),
10683 ModeDeclPattern =.. [_|Modes]
10684 ),
10685 % print optional type declaration
10686 functor(TypeDeclPattern,Functor,Arity),
10687 ( memberchk(TypeDeclPattern,TypeDecls) ->
10688 true
10689 ;
10690 replicate(Arity,any,Types),
10691 TypeDeclPattern =.. [_|Types]
10692 ).
10693 % }}}
10694 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10695 % read clauses from file
10696 % CHR are returned
10697 % declared constaints are returned
10698 % type definitions are returned and printed
10699 % mode declarations are returned
10700 % other clauses are returned
10702 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10703 flatten_readcontent([],[],[],[],[],[],[]).
10704 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10705 % read(Clause),
10706 ( Clause == end_of_file ->
10707 Rules = [],
10708 ConstraintSymbols = [],
10709 ModeDecls = [],
10710 TypeDecls = [],
10711 TypeDefs = [],
10712 RestClauses = []
10713 ; crude_is_rule(Clause) ->
10714 Rules = [Clause|RestRules],
10715 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10716 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10717 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10718 append(SomeModeDecls,RestModeDecls,ModeDecls),
10719 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10720 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10721 ; is_mode_declaration(Clause,ModeDecl) ->
10722 ModeDecls = [ModeDecl|RestModeDecls],
10723 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10724 ; is_type_declaration(Clause,TypeDecl) ->
10725 TypeDecls = [TypeDecl|RestTypeDecls],
10726 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10727 ; is_type_definition(Clause,TypeDef) ->
10728 RestClauses = [Clause|NRestClauses],
10729 TypeDefs = [TypeDef|RestTypeDefs],
10730 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10731 ; ( Clause = (:- op(A,B,C)) ->
10732 % assert operators in order to read and print them out properly
10733 op(A,B,C)
10734 ;
10735 true
10736 ),
10737 RestClauses = [Clause|NRestClauses],
10738 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10739 ).
10741 crude_is_rule(_ @ _).
10742 crude_is_rule(_ pragma _).
10743 crude_is_rule(_ ==> _).
10744 crude_is_rule(_ <=> _).
10746 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10747 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10748 conj2list(Cs,Constraints0),
10749 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10751 pure_extract_type_mode([],[],[],[]).
10752 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10753 pure_extract_type_mode(R,R2,Modes,Types).
10754 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10755 functor(C,F,A),
10756 ConstraintSymbol = F/A,
10757 C =.. [_|Args],
10758 extract_types_and_modes(Args,ArgTypes,ArgModes),
10759 Mode =.. [F|ArgModes],
10760 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10761 Types = RTypes
10762 ;
10763 Types = [Type|RTypes],
10764 Type =.. [F|ArgTypes]
10765 ),
10766 pure_extract_type_mode(R,R2,Modes,RTypes).
10768 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10770 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10771 % }}}
10772 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10773 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10774 % including mode and type declarations
10776 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10777 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10778 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10779 flatten(ConstraintSpecs0,ConstraintSpecs).
10781 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10782 [(:- chr_constraint ConstraintSpec),
10783 (:- chr_option(mode,NewModeDecl)),
10784 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10785 member(C/N-I-SFs-_,Dict),
10786 arg_modes(C,N,ModeDecls,Modes),
10787 specialize_modes(Modes,I,SpecializedModes),
10788 arg_types(C,N,TypeDecls,Types),
10789 specialize_types(Types,I,SpecializedTypes),
10790 length(I,IndexSize),
10791 AN is N - IndexSize,
10792 member(_Term-F,SFs),
10793 ConstraintSpec = F/AN,
10794 NewModeDecl =.. [F|SpecializedModes],
10795 NewTypeDecl =.. [F|SpecializedTypes].
10797 arg_modes(C,N,ModeDecls,ArgModes) :-
10798 functor(ConstraintPattern,C,N),
10799 ( memberchk(ConstraintPattern,ModeDecls) ->
10800 ConstraintPattern =.. [_|ArgModes]
10801 ;
10802 replicate(N,?,ArgModes)
10803 ).
10805 specialize_modes(Modes,I,SpecializedModes) :-
10806 split_args(I,Modes,_,SpecializedModes).
10808 arg_types(C,N,TypeDecls,ArgTypes) :-
10809 functor(ConstraintPattern,C,N),
10810 ( memberchk(ConstraintPattern,TypeDecls) ->
10811 ConstraintPattern =.. [_|ArgTypes]
10812 ;
10813 replicate(N,any,ArgTypes)
10814 ).
10816 specialize_types(Types,I,SpecializedTypes) :-
10817 split_args(I,Types,_,SpecializedTypes).
10818 % }}}
10819 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10820 % DISPATCHING RULES
10821 %
10822 % dispatching_rules(+dict,-newrules)
10825 % {{{
10827 % This code generates a decision tree for calling the appropriate specialized
10828 % constraint based on the particular value of the argument the constraint
10829 % is being specialized on.
10830 %
10831 % In case an error handler is provided, the handler is called with the
10832 % unexpected constraint.
10834 dispatching_rules([],[]).
10835 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10836 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10837 dispatching_rules(Dict,RestDispatchingRules).
10839 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10840 ( increasing_numbers(I,1) ->
10841 /* index on first arguments */
10842 Rules0 = Rules,
10843 NCN = C/N
10844 ;
10845 /* reorder arguments for 1st argument indexing */
10846 functor(Head,C,N),
10847 Head =.. [_|Args],
10848 split_args(I,Args,GroundArgs,OtherArgs),
10849 append(GroundArgs,OtherArgs,ShuffledArgs),
10850 atom_concat(C,'_$shuffled',NC),
10851 Body =.. [NC|ShuffledArgs],
10852 [(Head :- Body)|Rules0] = Rules,
10853 NCN = NC / N
10854 ),
10855 Context = swap(C,I),
10856 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10858 increasing_numbers([],_).
10859 increasing_numbers([X|Ys],X) :-
10860 Y is X + 1,
10861 increasing_numbers(Ys,Y).
10863 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10864 length(I,IndexLength),
10865 once(pairup(TermLists,Functors,SFs)),
10866 maplist(head_tail,TermLists,Heads,Tails),
10867 Payload is N - IndexLength,
10868 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10869 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10871 dispatching_action(Functor,PayloadArgs,Goal) :-
10872 Goal =.. [Functor|PayloadArgs].
10874 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10875 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10877 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10878 % length MorePatterns == length Patterns == length Results
10879 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10880 MorePatterns = [List|_],
10881 length(List,N),
10882 aggregate_all(set(F/A),
10883 ( member(Pattern,Patterns),
10884 functor(Pattern,F,A)
10885 ),
10886 FAs),
10887 N1 is N + 1,
10888 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10890 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10891 ( MaybeErrorHandler = yes(ErrorHandler) ->
10892 Clauses0 = [ErrorClause|Clauses],
10893 ErrorClause = (Head :- Body),
10894 Arity is N + Payload,
10895 functor(Head,Symbol,Arity),
10896 reconstruct_original_term(Context,Head,Term),
10897 Body =.. [ErrorHandler,Term]
10898 ;
10899 Clauses0 = Clauses
10900 ).
10901 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10902 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10903 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10905 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10906 Clause = (Head :- Cut, Body),
10907 ( MaybeErrorHandler = yes(_) ->
10908 Cut = (!)
10909 ;
10910 Cut = true
10911 ),
10912 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10913 N1 is N + Payload,
10914 functor(Head,Symbol,N1),
10915 arg(1,Head,IndexPattern),
10916 Head =.. [_,_|RestArgs],
10917 length(PayloadArgs,Payload),
10918 once(append(Vs,PayloadArgs,RestArgs)),
10919 /* IndexPattern = F(...) */
10920 functor(IndexPattern,F,A),
10921 Context1 = index_functor(F,A,Context0),
10922 IndexPattern =.. [_|Args],
10923 append(Args,RestArgs,RecArgs),
10924 ( RecArgs == PayloadArgs ->
10925 /* nothing more to match on */
10926 List = Tail,
10927 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10928 MoreActions = [Action],
10929 call(Action,PayloadArgs,Body)
10930 ; /* more things to match on */
10931 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10932 ( MoreActions = [OneMoreAction] ->
10933 /* only one more thing to match on */
10934 MoreCases = [OneMoreCase],
10935 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10936 List = Tail,
10937 call(OneMoreAction,PayloadArgs,Body)
10938 ;
10939 /* more than one thing to match on */
10940 /* [ x1,..., xn]
10941 [xs1,...,xsn]
10942 */
10943 pairup(Cases,MoreCases,CasePairs),
10944 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10945 append(Args,Vs,[First|Rest]),
10946 First-Rest = CommonPatternPair,
10947 Context2 = gct([First|Rest],Context1),
10948 gensym(Prefix,RSymbol),
10949 append(DiffVars,PayloadArgs,RecCallVars),
10950 Body =.. [RSymbol|RecCallVars],
10951 findall(CH-CT,member([CH|CT],Differences),CPairs),
10952 once(pairup(CHs,CTs,CPairs)),
10953 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10954 )
10955 ).
10958 % split(list,int,before,at,after).
10960 split([X|Xs],I,Before,At,After) :-
10961 ( I == 1 ->
10962 Before = [],
10963 At = X,
10964 After = Xs
10965 ;
10966 J is I - 1,
10967 Before = [X|RBefore],
10968 split(Xs,J,RBefore,At,After)
10969 ).
10971 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10972 %
10973 % context ::= swap(functor,positions)
10974 % | index_functor(functor,arity,context)
10975 % | gct(Pattern,Context)
10977 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10978 functor(Term,_,Arity),
10979 functor(OriginalTerm,Functor,Arity),
10980 OriginalTerm =.. [_|OriginalArgs],
10981 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10982 Term =.. [_|Args],
10983 append(IndexArgs,OtherArgs,Args).
10984 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10985 Term0 =.. [Predicate|Args],
10986 split_at(Arity,Args,IndexArgs,RestArgs),
10987 Index =.. [Functor|IndexArgs],
10988 Term1 =.. [Predicate,Index|RestArgs],
10989 reconstruct_original_term(Context,Term1,OriginalTerm).
10990 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10991 copy_term_nat(PatternList,IndexTerms),
10992 term_variables(IndexTerms,Variables),
10993 Term0 =.. [Predicate|Args0],
10994 append(Variables,RestArgs,Args0),
10995 append(IndexTerms,RestArgs,Args1),
10996 Term1 =.. [Predicate|Args1],
10997 reconstruct_original_term(Context,Term1,OriginalTerm).
10998 % }}}
11000 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
11001 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
11002 %
11003 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
11004 %
11005 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
11007 % {{{
11008 flatten_rules(Rules,Dict,FlatRules) :-
11009 flatten_rules1(Rules,Dict,FlatRulesList),
11010 flatten(FlatRulesList,FlatRules).
11012 flatten_rules1([],_,[]).
11013 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
11014 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
11015 flatten_rules1(Rules,Dict,FlatRulesList).
11017 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
11018 flatten_rule(Rule,Dict,NRule).
11019 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
11020 flatten_rule(Rule,Dict,NRule).
11021 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
11022 flatten_heads(H,Dict,NH),
11023 flatten_body(B,Dict,NB).
11024 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
11025 flatten_heads((H1,H2),Dict,(NH1,NH2)),
11026 flatten_body(B,Dict,NB).
11027 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
11028 flatten_heads(H,Dict,NH),
11029 flatten_body(B,Dict,NB).
11031 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
11032 flatten_heads(H1,Dict,NH1),
11033 flatten_heads(H2,Dict,NH2).
11034 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
11035 flatten_heads(H,Dict,NH).
11036 flatten_heads(H,Dict,NH) :-
11037 ( functor(H,C,N),
11038 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
11039 H =.. [_|AllArgs],
11040 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
11041 member(GroundArgs-Name,SFs),
11042 NH =.. [Name|OtherArgs]
11043 ;
11044 NH = H
11045 ).
11047 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
11048 conj2list(Guard,Guards),
11049 maplist(flatten_goal(Dict),Guards,NGuards),
11050 list2conj(NGuards,NGuard),
11051 conj2list(Body,Goals),
11052 maplist(flatten_goal(Dict),Goals,NGoals),
11053 list2conj(NGoals,NBody).
11054 flatten_body(Body,Dict,NBody) :-
11055 conj2list(Body,Goals),
11056 maplist(flatten_goal(Dict),Goals,NGoals),
11057 list2conj(NGoals,NBody).
11059 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
11060 flatten_goal(Dict,Goal,NGoal) :-
11061 ( is_specializable_goal(Goal,Dict,ArgPositions)
11062 ->
11063 specialize_goal(Goal,ArgPositions,NGoal)
11064 ; Goal = Mod : TheGoal,
11065 get_target_module(Module),
11066 Mod == Module,
11067 nonvar(TheGoal),
11068 is_specializable_goal(TheGoal,Dict,ArgPositions)
11069 ->
11070 specialize_goal(TheGoal,ArgPositions,NTheGoal),
11071 NGoal = Mod : NTheGoal
11072 ; partial_eval(Goal,NGoal)
11073 ->
11074 true
11075 ;
11076 NGoal = Goal
11077 ).
11079 %-------------------------------------------------------------------------------%
11080 % Specialize body/guard goal
11081 %-------------------------------------------------------------------------------%
11082 is_specializable_goal(Goal,Dict,ArgPositions) :-
11083 functor(Goal,C,N),
11084 memberchk(C/N-ArgPositions-_-_,Dict),
11085 args(ArgPositions,Goal,Args),
11086 ground(Args).
11088 specialize_goal(Goal,ArgPositions,NGoal) :-
11089 functor(Goal,C,N),
11090 Goal =.. [_|Args],
11091 split_args(ArgPositions,Args,GroundTerms,Others),
11092 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
11093 NGoal =.. [Functor|Others].
11095 %-------------------------------------------------------------------------------%
11096 % Partially evaluate predicates
11097 %-------------------------------------------------------------------------------%
11099 % append([],Y,Z) >--> Y = Z
11100 % append(X,[],Z) >--> X = Z
11101 partial_eval(append(L1,L2,L3),NGoal) :-
11102 ( L1 == [] ->
11103 NGoal = (L3 = L2)
11104 ; L2 == [] ->
11105 NGoal = (L3 = L1)
11107 ).
11108 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
11109 % where flatten(L1,L1')
11110 partial_eval(flatten_path(L1,L2),NGoal) :-
11111 nonvar(L1),
11112 flatten(L1,FlatterL1),
11113 FlatterL1 \== L1 ->
11114 NGoal = flatten_path(FlatterL1,L2).
11117 % }}}
11119 % }}}
11120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11121 dump_code(Clauses) :-
11122 ( chr_pp_flag(dump,on) ->
11123 maplist(portray_clause,Clauses)
11124 ;
11125 true
11126 ).
11128 chr_banner :-
11129 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',[]).
11131 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11132 % LOCKING {{{
11134 chr_none_locked(Vars,Goal) :-
11135 chr_pp_flag(guard_locks,Flag),
11136 ( Flag == off ->
11137 Goal = true
11138 ; Flag == on ->
11139 Goal = 'chr none_locked'( Vars)
11140 ; Flag == error ->
11141 Goal = 'chr none_error_locked'( Vars)
11142 ).
11144 chr_not_locked(Var,Goal) :-
11145 chr_pp_flag(guard_locks,Flag),
11146 ( Flag == off ->
11147 Goal = true
11148 ; Flag == on ->
11149 Goal = 'chr not_locked'( Var)
11150 ; Flag == error ->
11151 Goal = 'chr not_error_locked'( Var)
11152 ).
11154 chr_lock(Var,Goal) :-
11155 chr_pp_flag(guard_locks,Flag),
11156 ( Flag == off ->
11157 Goal = true
11158 ; Flag == on ->
11159 Goal = 'chr lock'( Var)
11160 ; Flag == error ->
11161 Goal = 'chr error_lock'( Var)
11162 ).
11164 chr_unlock(Var,Goal) :-
11165 chr_pp_flag(guard_locks,Flag),
11166 ( Flag == off ->
11167 Goal = true
11168 ; Flag == on ->
11169 Goal = 'chr unlock'( Var)
11170 ; Flag == error ->
11171 Goal = 'chr unerror_lock'( Var)
11172 ).
11173 % }}}
11174 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11175 % AST representation
11176 % each AST representation caches the original term
11177 %
11178 % ast_term ::= atomic(Term)
11179 % | compound(Functor,Arity,list(ast_term),Term)
11180 % | var(int,Term)
11181 % -- unique integer identifier
11183 % Conversion Predicate {{{
11184 :- chr_type var_id == natural.
11186 term_to_ast_term(Term,AstTerm,VarEnv,NVarEnv) :-
11187 ( atomic(Term) ->
11188 AstTerm = atomic(Term),
11189 NVarEnv = VarEnv
11190 ; compound(Term) ->
11191 functor(Term,Functor,Arity),
11192 AstTerm = compound(Functor,Arity,AstTerms,Term),
11193 Term =.. [_|Args],
11194 maplist_dcg(chr_translate:term_to_ast_term,Args,AstTerms,VarEnv,NVarEnv)
11195 ; var(Term) ->
11196 var_to_ast_term(Term,VarEnv,AstTerm,NVarEnv)
11197 ).
11199 var_to_ast_term(Var,Env,AstTerm,NVarEnv) :-
11200 Env = VarDict - VarId,
11201 ( lookup_eq(VarDict,Var,AstTerm) ->
11202 NVarEnv = Env
11203 ;
11204 AstTerm = var(VarId,Var),
11205 NVarId is VarId + 1,
11206 NVarDict = [Var - AstTerm|VarDict],
11207 NVarEnv = NVarDict - NVarId
11208 ).
11210 % ast_constraint ::= chr_constraint(Symbol,Arguments,Constraint)
11211 chr_constraint_to_ast_constraint(CHRConstraint,AstConstraint,VarEnv,NVarEnv) :-
11212 AstConstraint = chr_constraint(Functor/Arity,AstTerms,CHRConstraint),
11213 functor(CHRConstraint,Functor,Arity),
11214 CHRConstraint =.. [_|Arguments],
11215 maplist_dcg(chr_translate:term_to_ast_term,Arguments,AstTerms,VarEnv,NVarEnv).
11217 % ast_head ::= simplification(list(chr_constraint))
11218 % | propagation(list(chr_constraint))
11219 % | simpagation(list(chr_constraint),list(chr_constraint))
11221 % head_id ::= int
11223 % ast_guard ::= list(ast_term)
11224 % ast_body ::= list(ast_term)
11226 % ast_rule ::= ast_rule(ast_head,ast_guard,guard,ast_body,body)
11228 rule_to_ast_rule(Rule,AstRule) :-
11229 AstRule = ast_rule(Head,AstGuard,Guard,AstBody,Body),
11230 Rule = rule(H1,H2,Guard,Body),
11231 EmptyVarEnv = []-1,
11232 ( H1 == [] ->
11233 Head = propagation(AstConstraints),
11234 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,AstConstraints,EmptyVarEnv,VarEnv1)
11235 ; H2 == [] ->
11236 Head = simplification(AstConstraints),
11237 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,AstConstraints,EmptyVarEnv,VarEnv1)
11238 ;
11239 Head = simpagation(RemovedAstConstraints,KeptAstConstraints),
11240 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,RemovedAstConstraints,EmptyVarEnv,VarEnv0),
11241 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,KeptAstConstraints,VarEnv0,VarEnv1)
11242 ),
11243 conj2list(Guard,GuardList),
11244 maplist_dcg(chr_translate:term_to_ast_term,GuardList,AstGuard,VarEnv1,VarEnv2),
11245 conj2list(Body,BodyList),
11246 maplist_dcg(chr_translate:term_to_ast_term,BodyList,AstBody,VarEnv2,_).
11248 pragma_rule_to_ast_rule(pragma(Rule,_,_,_,_),AstRule) :-
11249 rule_to_ast_rule(Rule,AstRule).
11251 check_rule_to_ast_rule(Rule) :-
11252 ( rule_to_ast_rule(Rule,AstRule) ->
11253 writeln(AstRule)
11254 ;
11255 writeln(failed(rule_to_ast_rule(Rule,AstRule)))
11256 ).
11258 % }}}
11260 % AST Utility Predicates {{{
11261 ast_term_to_term(var(_,Var),Var).
11262 ast_term_to_term(atomic(Atom),Atom).
11263 ast_term_to_term(compound(_,_,_,Compound),Compound).
11265 ast_nonvar(atomic(_)).
11266 ast_nonvar(compound(_,_,_,_)).
11268 ast_ground(atomic(_)).
11269 ast_ground(compound(_,_,Arguments,_)) :-
11270 maplist(ast_ground,Arguments).
11272 %------------------------------------------------------------------------------%
11273 % Check whether a term is ground, given a set of variables that are ground.
11274 %------------------------------------------------------------------------------%
11275 ast_is_ground(VarSet,AstTerm) :-
11276 ast_is_ground_(AstTerm,VarSet).
11278 ast_is_ground_(var(VarId,_),VarSet) :-
11279 tree_set_memberchk(VarId,VarSet).
11280 ast_is_ground_(atomic(_),_).
11281 ast_is_ground_(compound(_,_,Arguments,_),VarSet) :-
11282 maplist(ast_is_ground(VarSet),Arguments).
11283 %------------------------------------------------------------------------------%
11285 ast_functor(atomic(Atom),Atom,0).
11286 ast_functor(compound(Functor,Arity,_,_),Functor,Arity).
11288 ast_symbol(atomic(Atom),Atom/0).
11289 ast_symbol(compound(Functor,Arity,_,_),Functor/Arity).
11291 ast_args(atomic(_),[]).
11292 ast_args(compound(_,_,Arguments,_),Arguments).
11294 %------------------------------------------------------------------------------%
11295 % Add variables in a term to a given set.
11296 %------------------------------------------------------------------------------%
11297 ast_term_variables(atomic(_),Set,Set).
11298 ast_term_variables(compound(_,_,Args,_),Set,NSet) :-
11299 ast_term_list_variables(Args,Set,NSet).
11300 ast_term_variables(var(VarId,_),Set,NSet) :-
11301 tree_set_add(Set,VarId,NSet).
11303 ast_term_list_variables(Terms,Set,NSet) :-
11304 fold(Terms,chr_translate:ast_term_variables,Set,NSet).
11305 %------------------------------------------------------------------------------%
11307 ast_constraint_variables(chr_constraint(_,Args,_),Set,NSet) :-
11308 ast_term_list_variables(Args,Set,NSet).
11310 ast_constraint_list_variables(Constraints,Set,NSet) :-
11311 fold(Constraints,chr_translate:ast_constraint_variables,Set,NSet).
11313 ast_head_variables(simplification(H1),Set,NSet) :-
11314 ast_constraint_list_variables(H1,Set,NSet).
11315 ast_head_variables(propagation(H2),Set,NSet) :-
11316 ast_constraint_list_variables(H2,Set,NSet).
11317 ast_head_variables(simpagation(H1,H2),Set,NSet) :-
11318 ast_constraint_list_variables(H1,Set,Set1),
11319 ast_constraint_list_variables(H2,Set1,NSet).
11321 ast_var_memberchk(var(VarId,_),Set) :-
11322 tree_set_memberchk(VarId,Set).
11324 %------------------------------------------------------------------------------%
11325 % Return term based on AST-term with variables mapped.
11326 %------------------------------------------------------------------------------%
11327 ast_instantiate(Map,AstTerm,Term) :-
11328 ast_instantiate_(AstTerm,Map,Term).
11330 ast_instantiate_(var(VarId,_),Map,Term) :-
11331 get_assoc(VarId,Map,Term).
11332 ast_instantiate_(atomic(Atom),_,Atom).
11333 ast_instantiate_(compound(Functor,Arity,Arguments,_),Map,Term) :-
11334 functor(Term,Functor,Arity),
11335 Term =.. [_|Terms],
11336 maplist(ast_instantiate(Map),Arguments,Terms).
11337 %------------------------------------------------------------------------------%
11338 % }}}
11340 %------------------------------------------------------------------------------%
11341 % ast_head_arg_matches_(list(silent_pair(ast_term,var)
11342 % ,modes
11343 % ,map(var_id,...)
11344 % ,set(variables)
11345 % ,list(goal)
11346 % ,vardict
11347 % ,set(variables)
11348 % )
11349 %------------------------------------------------------------------------------%
11351 ast_head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
11352 ast_head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
11353 ( Mode == (+) ->
11354 ast_term_variables(Arg,GroundVars0,GroundVars),
11355 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
11356 ;
11357 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
11358 ).
11359 ast_head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
11360 ( Arg = var(VarId,_) ->
11361 ( get_assoc(VarId,VarDict,OtherVar) ->
11362 ( Mode = (+) ->
11363 ( tree_set_memberchk(VarId,GroundVars) ->
11364 GoalList = [Var = OtherVar | RestGoalList],
11365 GroundVars1 = GroundVars
11366 ;
11367 GoalList = [Var == OtherVar | RestGoalList],
11368 tree_set_add(GroundVars,VarId,GroundVars1)
11369 )
11370 ;
11371 GoalList = [Var == OtherVar | RestGoalList],
11372 GroundVars1 = GroundVars
11373 ),
11374 VarDict1 = VarDict
11375 ;
11376 put_assoc(VarId,VarDict,Var,VarDict1),
11377 GoalList = RestGoalList,
11378 ( Mode = (+) ->
11380 tree_set_add(GroundVars,VarId,GroundVars1)
11381 ;
11382 GroundVars1 = GroundVars
11383 )
11384 ),
11385 Pairs = Rest,
11386 RestModes = Modes
11387 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> % TODO
11388 identifier_label_atom(IndexType,Var,ActualArg,Goal),
11389 GoalList = [Goal|RestGoalList],
11390 VarDict = VarDict1,
11391 GroundVars1 = GroundVars,
11392 Pairs = Rest,
11393 RestModes = Modes
11394 ; Arg = atomic(Atom) ->
11395 ( Mode = (+) ->
11396 GoalList = [ Var = Atom | RestGoalList]
11397 ;
11398 GoalList = [ Var == Atom | RestGoalList]
11399 ),
11400 VarDict = VarDict1,
11401 GroundVars1 = GroundVars,
11402 Pairs = Rest,
11403 RestModes = Modes
11404 ; Mode == (+), ast_is_ground(GroundVars,Arg) ->
11405 ast_instantiate(VarDict,Arg,ArgInst),
11406 GoalList = [ Var = ArgInst | RestGoalList],
11407 VarDict = VarDict1,
11408 GroundVars1 = GroundVars,
11409 Pairs = Rest,
11410 RestModes = Modes
11411 ; Mode == (?), ast_is_ground(GroundVars,Arg) ->
11412 ast_instantiate(VarDict,Arg,ArgInst),
11413 GoalList = [ Var == ArgInst | RestGoalList],
11414 VarDict = VarDict1,
11415 GroundVars1 = GroundVars,
11416 Pairs = Rest,
11417 RestModes = Modes
11418 ; Arg = compound(Functor,Arity,Arguments,_),
11419 functor(Term,Functor,Arity),
11420 Term =.. [_|Vars],
11421 ( Mode = (+) ->
11422 GoalList = [ Var = Term | RestGoalList ]
11423 ;
11424 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
11425 ),
11426 pairup(Arguments,Vars,NewPairs),
11427 append(NewPairs,Rest,Pairs),
11428 replicate(N,Mode,NewModes),
11429 append(NewModes,Modes,RestModes),
11430 VarDict1 = VarDict,
11431 GroundVars1 = GroundVars
11432 ),
11433 ast_head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).