| blob | a50312f34db74494faea1ea916124549c49eabd6 |
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(+,+)).
341 :- chr_constraint is_passive/2.
342 :- chr_option(mode,is_passive(+,+)).
344 :- chr_constraint any_passive_head/1.
345 :- chr_option(mode,any_passive_head(+)).
347 :- chr_constraint new_occurrence/4.
348 :- chr_option(mode,new_occurrence(+,+,+,+)).
350 :- chr_constraint occurrence/5.
351 :- chr_option(mode,occurrence(+,+,+,+,+)).
352 :- chr_type occurrence_type ---> simplification ; propagation.
353 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
355 :- chr_constraint get_occurrence/4.
356 :- chr_option(mode,get_occurrence(+,+,-,-)).
358 :- chr_constraint get_occurrence_from_id/4.
359 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
361 :- chr_constraint max_occurrence/2.
362 :- chr_option(mode,max_occurrence(+,+)).
364 :- chr_constraint get_max_occurrence/2.
365 :- chr_option(mode,get_max_occurrence(+,-)).
367 :- chr_constraint allocation_occurrence/2.
368 :- chr_option(mode,allocation_occurrence(+,+)).
370 :- chr_constraint get_allocation_occurrence/2.
371 :- chr_option(mode,get_allocation_occurrence(+,-)).
373 :- chr_constraint rule/2.
374 :- chr_option(mode,rule(+,+)).
375 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
377 :- chr_constraint get_rule/2.
378 :- chr_option(mode,get_rule(+,-)).
379 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
381 :- chr_constraint least_occurrence/2.
382 :- chr_option(mode,least_occurrence(+,+)).
383 :- chr_option(type_declaration,least_occurrence(any,list)).
385 :- chr_constraint is_least_occurrence/1.
386 :- chr_option(mode,is_least_occurrence(+)).
389 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
390 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
391 is_indexed_argument(_,_) <=> fail.
393 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
395 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
396 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
397 Q = Mode.
398 get_constraint_mode(FA,Q) <=>
399 FA = _ / N,
400 replicate(N,(?),Q).
402 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
404 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
405 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
406 nth1(I,Mode,M),
407 M \== (+) |
408 is_stored(FA).
409 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
411 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
412 <=>
413 nth1(I,Mode,M),
414 M \== (+)
415 |
416 fail.
417 only_ground_indexed_arguments(_) <=>
418 true.
420 none_suspended_on_variables \ none_suspended_on_variables <=> true.
421 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
422 are_none_suspended_on_variables <=> fail.
423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
424 % STORE TYPES
425 %
426 % The functionality for inspecting and deciding on the different types of constraint
427 % store / indexes for constraints.
429 store_type(FA,StoreType)
430 ==> chr_pp_flag(verbose,on)
431 |
432 format('The indexes for ~w are:\n',[FA]),
433 format_storetype(StoreType).
434 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
436 format_storetype(multi_store(StoreTypes)) :- !,
437 maplist(format_storetype,StoreTypes).
438 format_storetype(atomic_constants(Index,Constants,_)) :-
439 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
440 format_storetype(ground_constants(Index,Constants,_)) :-
441 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
442 format_storetype(StoreType) :-
443 format('\t* ~w\n',[StoreType]).
446 % 1. Inspection
447 % ~~~~~~~~~~~~~
448 %
449 %
451 get_store_type_normal @
452 store_type(FA,Store) \ get_store_type(FA,Query)
453 <=> Query = Store.
455 get_store_type_assumed @
456 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
457 <=> Query = Store.
459 get_store_type_default @
460 get_store_type(_,Query)
461 <=> Query = default.
463 % 2. Store type registration
464 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
466 actual_store_types(C,STs) \ update_store_type(C,ST)
467 <=> memberchk(ST,STs) | true.
468 update_store_type(C,ST), actual_store_types(C,STs)
469 <=>
470 actual_store_types(C,[ST|STs]).
471 update_store_type(C,ST)
472 <=>
473 actual_store_types(C,[ST]).
475 % 3. Final decision on store types
476 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
479 <=>
480 true % chr_pp_flag(experiment,on)
481 |
482 delete(STs,multi_hash([Index]),STs0),
483 Index = [IndexPos],
484 ( get_constraint_arg_type(C,IndexPos,Type),
485 enumerated_atomic_type(Type,Atoms) ->
486 /* use the type constants rather than the collected keys */
487 Constants = Atoms,
488 Completeness = complete
489 ;
490 Constants = Keys,
491 Completeness = incomplete
492 ),
493 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
494 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
495 <=>
496 true % chr_pp_flag(experiment,on)
497 |
498 ( Index = [IndexPos],
499 get_constraint_arg_type(C,IndexPos,Type),
500 % ( fail , is_chr_constants_type(Type,Key,_) -> get_chr_constants(Key,Constants)
501 % ;
502 Type = chr_enum(Constants) % -> true
503 % )
504 ->
505 Completeness = complete
506 ;
507 Constants = Constants0,
508 Completeness = incomplete
509 ),
510 delete(STs,multi_hash([Index]),STs0),
511 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
513 get_constraint_arg_type(C,Pos,Type) :-
514 get_constraint_type(C,Types),
515 nth1(Pos,Types,Type0),
516 unalias_type(Type0,Type).
518 validate_store_type_assumption(C) \ actual_store_types(C,STs)
519 <=>
520 % chr_pp_flag(experiment,on),
521 memberchk(multi_hash([[Index]]),STs),
522 get_constraint_type(C,Types),
523 nth1(Index,Types,Type),
524 enumerated_atomic_type(Type,Atoms)
525 |
526 delete(STs,multi_hash([[Index]]),STs0),
527 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
528 validate_store_type_assumption(C) \ actual_store_types(C,STs)
529 <=>
530 memberchk(multi_hash([[Index]]),STs),
531 get_constraint_arg_type(C,Index,Type),
532 % (
533 Type = chr_enum(Constants) % -> true
534 % ; fail, is_chr_constants_type(Type,Key,_) -> get_chr_constants(Key,Constants)
535 % )
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,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
596 <=> QC = C, QON = ON.
597 get_occurrence_from_id(C,O,_,_)
598 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
600 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
601 % Late allocation
603 late_allocation_analysis(Cs) :-
604 ( chr_pp_flag(late_allocation,on) ->
605 maplist(late_allocation, Cs)
606 ;
607 true
608 ).
610 late_allocation(C) :- late_allocation(C,0).
611 late_allocation(C,O) :- allocation_occurrence(C,O), !.
612 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
614 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
616 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
618 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
619 \+ is_passive(RuleNb,Id),
620 Type == propagation,
621 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
622 true
623 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
624 is_observed(C,O)
625 ; is_least_occurrence(RuleNb) -> % propagation rule
626 is_observed(C,O)
627 ;
628 true
629 ).
631 stored_in_guard_before_next_kept_occurrence(C,O) :-
632 chr_pp_flag(store_in_guards, on),
633 NO is O + 1,
634 stored_in_guard_lookahead(C,NO).
636 :- chr_constraint stored_in_guard_lookahead/2.
637 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
639 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
640 NO is O + 1, stored_in_guard_lookahead(C,NO).
641 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
642 Type == simplification,
643 ( is_stored_in_guard(C,RuleNb) ->
644 true
645 ;
646 NO is O + 1, stored_in_guard_lookahead(C,NO)
647 ).
648 stored_in_guard_lookahead(_,_) <=> fail.
651 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
652 \ least_occurrence(RuleNb,[ID|IDs])
653 <=> AO >= O, \+ may_trigger(C) |
654 least_occurrence(RuleNb,IDs).
655 rule(RuleNb,Rule), passive(RuleNb,ID)
656 \ least_occurrence(RuleNb,[ID|IDs])
657 <=> least_occurrence(RuleNb,IDs).
659 rule(RuleNb,Rule)
660 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
661 least_occurrence(RuleNb,IDs).
663 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
664 <=> true.
665 is_least_occurrence(_)
666 <=> fail.
668 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
669 <=> Q = O.
670 get_allocation_occurrence(_,Q)
671 <=> chr_pp_flag(late_allocation,off), Q=0.
672 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
674 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
675 <=> Q = Rule.
676 get_rule(_,_)
677 <=> fail.
679 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
681 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
682 %
683 % Default store constraint index assignment.
685 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
686 :- chr_option(mode,constraint_index(+,+)).
687 :- chr_option(type_declaration,constraint_index(constraint,int)).
689 :- chr_constraint get_constraint_index/2.
690 :- chr_option(mode,get_constraint_index(+,-)).
691 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
693 :- chr_constraint get_indexed_constraint/2.
694 :- chr_option(mode,get_indexed_constraint(+,-)).
695 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
697 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
698 :- chr_option(mode,max_constraint_index(+)).
699 :- chr_option(type_declaration,max_constraint_index(int)).
701 :- chr_constraint get_max_constraint_index/1.
702 :- chr_option(mode,get_max_constraint_index(-)).
703 :- chr_option(type_declaration,get_max_constraint_index(int)).
705 constraint_index(C,Index) \ get_constraint_index(C,Query)
706 <=> Query = Index.
707 get_constraint_index(C,Query)
708 <=> fail.
710 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
711 <=> Q = C.
712 get_indexed_constraint(Index,Q)
713 <=> fail.
715 max_constraint_index(Index) \ get_max_constraint_index(Query)
716 <=> Query = Index.
717 get_max_constraint_index(Query)
718 <=> Query = 0.
720 set_constraint_indices(Constraints) :-
721 set_constraint_indices(Constraints,1).
722 set_constraint_indices([],M) :-
723 N is M - 1,
724 max_constraint_index(N).
725 set_constraint_indices([C|Cs],N) :-
726 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
727 ; get_store_type(C,var_assoc_store(_,_))) ->
728 constraint_index(C,N),
729 M is N + 1,
730 set_constraint_indices(Cs,M)
731 ;
732 set_constraint_indices(Cs,N)
733 ).
735 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
736 % Identifier Indexes
738 :- chr_constraint identifier_size/1.
739 :- chr_option(mode,identifier_size(+)).
740 :- chr_option(type_declaration,identifier_size(natural)).
742 identifier_size(_) \ identifier_size(_)
743 <=>
744 true.
746 :- chr_constraint get_identifier_size/1.
747 :- chr_option(mode,get_identifier_size(-)).
748 :- chr_option(type_declaration,get_identifier_size(natural)).
750 identifier_size(Size) \ get_identifier_size(Q)
751 <=>
752 Q = Size.
754 get_identifier_size(Q)
755 <=>
756 Q = 1.
758 :- chr_constraint identifier_index/3.
759 :- chr_option(mode,identifier_index(+,+,+)).
760 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
762 identifier_index(C,I,_) \ identifier_index(C,I,_)
763 <=>
764 true.
766 :- chr_constraint get_identifier_index/3.
767 :- chr_option(mode,get_identifier_index(+,+,-)).
768 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
770 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
771 <=>
772 Q = II.
773 identifier_size(Size), get_identifier_index(C,I,Q)
774 <=>
775 NSize is Size + 1,
776 identifier_index(C,I,NSize),
777 identifier_size(NSize),
778 Q = NSize.
779 get_identifier_index(C,I,Q)
780 <=>
781 identifier_index(C,I,2),
782 identifier_size(2),
783 Q = 2.
785 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
786 % Type Indexed Identifier Indexes
788 :- chr_constraint type_indexed_identifier_size/2.
789 :- chr_option(mode,type_indexed_identifier_size(+,+)).
790 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
792 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
793 <=>
794 true.
796 :- chr_constraint get_type_indexed_identifier_size/2.
797 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
798 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
800 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
801 <=>
802 Q = Size.
804 get_type_indexed_identifier_size(IndexType,Q)
805 <=>
806 Q = 1.
808 :- chr_constraint type_indexed_identifier_index/4.
809 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
810 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
812 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
813 <=>
814 true.
816 :- chr_constraint get_type_indexed_identifier_index/4.
817 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
818 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
820 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
821 <=>
822 Q = II.
823 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
824 <=>
825 NSize is Size + 1,
826 type_indexed_identifier_index(IndexType,C,I,NSize),
827 type_indexed_identifier_size(IndexType,NSize),
828 Q = NSize.
829 get_type_indexed_identifier_index(IndexType,C,I,Q)
830 <=>
831 type_indexed_identifier_index(IndexType,C,I,2),
832 type_indexed_identifier_size(IndexType,2),
833 Q = 2.
835 type_indexed_identifier_structure(IndexType,Structure) :-
836 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
837 get_type_indexed_identifier_size(IndexType,Arity),
838 functor(Structure,Functor,Arity).
839 type_indexed_identifier_name(IndexType,Prefix,Name) :-
840 ( atom(IndexType) ->
841 IndexTypeName = IndexType
842 ;
843 term_to_atom(IndexType,IndexTypeName)
844 ),
845 atom_concat_list([Prefix,'_',IndexTypeName],Name).
847 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
852 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
853 %%
854 %% Translation
856 chr_translate(Declarations,NewDeclarations) :-
857 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
859 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
860 chr_banner,
861 restart_after_flattening(Declarations0,Declarations),
862 init_chr_pp_flags,
863 chr_source_file(File),
864 /* sort out the interesting stuff from the input */
865 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
866 chr_compiler_options:sanity_check,
868 dump_code(Declarations),
870 check_declared_constraints(Constraints0),
871 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
872 add_constraints(Constraints),
873 add_rules(Rules1),
874 generate_never_stored_rules(Constraints,NewRules),
875 add_rules(NewRules),
876 append(Rules1,NewRules,Rules),
877 chr_analysis(Rules,Constraints,Declarations),
878 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
879 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
880 phase_end(validate_store_type_assumptions),
881 used_states_known,
882 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
883 insert_declarations(OtherClauses, Clauses0),
884 chr_module_declaration(CHRModuleDeclaration),
885 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
886 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
887 append([Clauses0,GeneratedClauses], NewDeclarations),
888 dump_code(NewDeclarations),
889 !. /* cut choicepoint of restart_after_flattening */
891 chr_analysis(Rules,Constraints,Declarations) :-
892 check_rules(Rules,Constraints),
893 time('type checking',chr_translate:static_type_check),
894 /* constants */
895 collect_constants(Rules,Constraints,Declarations),
896 add_occurrences(Rules),
897 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
898 time('set semantics',chr_translate:set_semantics_rules(Rules)),
899 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
900 time('guard simplification',chr_translate:guard_simplification),
901 time('late storage',chr_translate:storage_analysis(Constraints)),
902 time('observation',chr_translate:observation_analysis(Constraints)),
903 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
904 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
905 partial_wake_analysis,
906 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
907 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
908 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
909 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
911 store_management_preds(Constraints,Clauses) :-
912 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
913 generate_attr_unify_hook(AttrUnifyHookClauses),
914 generate_attach_increment(AttachIncrementClauses),
915 generate_extra_clauses(Constraints,ExtraClauses),
916 generate_insert_delete_constraints(Constraints,DeleteClauses),
917 generate_attach_code(Constraints,StoreClauses),
918 generate_counter_code(CounterClauses),
919 generate_dynamic_type_check_clauses(TypeCheckClauses),
920 append([AttachAConstraintClauses
921 ,AttachIncrementClauses
922 ,AttrUnifyHookClauses
923 ,ExtraClauses
924 ,DeleteClauses
925 ,StoreClauses
926 ,CounterClauses
927 ,TypeCheckClauses
928 ]
929 ,Clauses).
932 insert_declarations(Clauses0, Clauses) :-
933 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
934 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
936 auxiliary_module(chr_hashtable_store).
937 auxiliary_module(chr_integertable_store).
938 auxiliary_module(chr_assoc_store).
940 generate_counter_code(Clauses) :-
941 ( chr_pp_flag(store_counter,on) ->
942 Clauses = [
943 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
944 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
945 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
946 (:- '$counter_init'('$insert_counter')),
947 (:- '$counter_init'('$delete_counter')),
948 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
949 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
950 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
951 ]
952 ;
953 Clauses = []
954 ).
956 % for systems with multifile declaration
957 chr_module_declaration(CHRModuleDeclaration) :-
958 get_target_module(Mod),
959 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
960 CHRModuleDeclaration = [
961 (:- multifile chr:'$chr_module'/1),
962 chr:'$chr_module'(Mod)
963 ]
964 ;
965 CHRModuleDeclaration = []
966 ).
969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
970 %%
971 %% Partitioning of clauses into constraint declarations, chr rules and other
972 %% clauses
974 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
975 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
976 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
977 partition_clauses([],[],[],[]).
978 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
979 ( parse_rule(Clause,Rule) ->
980 ConstraintDeclarations = RestConstraintDeclarations,
981 Rules = [Rule|RestRules],
982 OtherClauses = RestOtherClauses
983 ; is_declaration(Clause,ConstraintDeclaration) ->
984 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
985 Rules = RestRules,
986 OtherClauses = RestOtherClauses
987 ; is_module_declaration(Clause,Mod) ->
988 target_module(Mod),
989 ConstraintDeclarations = RestConstraintDeclarations,
990 Rules = RestRules,
991 OtherClauses = [Clause|RestOtherClauses]
992 ; is_type_definition(Clause) ->
993 ConstraintDeclarations = RestConstraintDeclarations,
994 Rules = RestRules,
995 OtherClauses = RestOtherClauses
996 ; is_chr_declaration(Clause) ->
997 ConstraintDeclarations = RestConstraintDeclarations,
998 Rules = RestRules,
999 OtherClauses = RestOtherClauses
1000 ; Clause = (handler _) ->
1001 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
1002 ConstraintDeclarations = RestConstraintDeclarations,
1003 Rules = RestRules,
1004 OtherClauses = RestOtherClauses
1005 ; Clause = (rules _) ->
1006 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1007 ConstraintDeclarations = RestConstraintDeclarations,
1008 Rules = RestRules,
1009 OtherClauses = RestOtherClauses
1010 ; Clause = option(OptionName,OptionValue) ->
1011 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1012 handle_option(OptionName,OptionValue),
1013 ConstraintDeclarations = RestConstraintDeclarations,
1014 Rules = RestRules,
1015 OtherClauses = RestOtherClauses
1016 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1017 handle_option(OptionName,OptionValue),
1018 ConstraintDeclarations = RestConstraintDeclarations,
1019 Rules = RestRules,
1020 OtherClauses = RestOtherClauses
1021 ; Clause = ('$chr_compiled_with_version'(_)) ->
1022 ConstraintDeclarations = RestConstraintDeclarations,
1023 Rules = RestRules,
1024 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1025 ; ConstraintDeclarations = RestConstraintDeclarations,
1026 Rules = RestRules,
1027 OtherClauses = [Clause|RestOtherClauses]
1028 ),
1029 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1031 '$chr_compiled_with_version'(2).
1033 is_declaration(D, Constraints) :- %% constraint declaration
1034 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1035 conj2list(Cs,Constraints0)
1036 ;
1037 ( D = (:- Decl) ->
1038 Decl =.. [constraints,Cs]
1039 ;
1040 D =.. [constraints,Cs]
1041 ),
1042 conj2list(Cs,Constraints0),
1043 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1044 ),
1045 extract_type_mode(Constraints0,Constraints).
1047 extract_type_mode([],[]).
1048 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1049 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1050 ( C0 = C # Annotation ->
1051 functor(C,F,A),
1052 extract_annotation(Annotation,F/A)
1053 ;
1054 C0 = C,
1055 functor(C,F,A)
1056 ),
1057 ConstraintSymbol = F/A,
1058 C =.. [_|Args],
1059 extract_types_and_modes(Args,ArgTypes,ArgModes),
1060 assert_constraint_type(ConstraintSymbol,ArgTypes),
1061 constraint_mode(ConstraintSymbol,ArgModes),
1062 extract_type_mode(R,R2).
1064 extract_annotation(stored,Symbol) :-
1065 stored_assertion(Symbol).
1066 extract_annotation(default(Goal),Symbol) :-
1067 never_stored_default(Symbol,Goal).
1069 extract_types_and_modes([],[],[]).
1070 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1071 extract_type_and_mode(X,T,M),
1072 extract_types_and_modes(R,R2,R3).
1074 extract_type_and_mode(+(T),T,(+)) :- !.
1075 extract_type_and_mode(?(T),T,(?)) :- !.
1076 extract_type_and_mode(-(T),T,(-)) :- !.
1077 extract_type_and_mode((+),any,(+)) :- !.
1078 extract_type_and_mode((?),any,(?)) :- !.
1079 extract_type_and_mode((-),any,(-)) :- !.
1080 extract_type_and_mode(Illegal,_,_) :-
1081 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1083 is_chr_declaration(Declaration) :-
1084 Declaration = (:- chr_declaration Decl),
1085 ( Decl = (Pattern ---> Information) ->
1086 background_info(Pattern,Information)
1087 ; Decl = Information ->
1088 background_info([Information])
1089 ).
1090 is_type_definition(Declaration) :-
1091 is_type_definition(Declaration,Result),
1092 assert_type_definition(Result).
1094 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1095 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1097 is_type_definition(Declaration,Result) :-
1098 ( Declaration = (:- TDef) ->
1099 true
1100 ;
1101 Declaration = TDef
1102 ),
1103 TDef =.. [chr_type,TypeDef],
1104 ( TypeDef = (Name ---> Def) ->
1105 tdisj2list(Def,DefList),
1106 Result = typedef(Name,DefList)
1107 ; TypeDef = (Alias == Name) ->
1108 Result = alias(Alias,Name)
1109 ;
1110 Result = typedef(TypeDef,[]),
1111 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1112 ).
1114 %% tdisj2list(+Goal,-ListOfGoals) is det.
1115 %
1116 % no removal of fails, e.g. :- type bool ---> true ; fail.
1117 tdisj2list(Conj,L) :-
1118 tdisj2list(Conj,L,[]).
1120 tdisj2list(Conj,L,T) :-
1121 Conj = (G1;G2), !,
1122 tdisj2list(G1,L,T1),
1123 tdisj2list(G2,T1,T).
1124 tdisj2list(G,[G | T],T).
1127 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1128 %% parse_rule(+term,-pragma_rule) is semidet.
1129 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1130 parse_rule(RI,R) :- %% name @ rule
1131 RI = (Name @ RI2), !,
1132 rule(RI2,yes(Name),R).
1133 parse_rule(RI,R) :-
1134 rule(RI,no,R).
1136 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1137 %% parse_rule(+term,-pragma_rule) is semidet.
1138 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1139 rule(RI,Name,R) :-
1140 RI = (RI2 pragma P), !, %% pragmas
1141 ( var(P) ->
1142 Ps = [_] % intercept variable
1143 ;
1144 conj2list(P,Ps)
1145 ),
1146 inc_rule_count(RuleCount),
1147 R = pragma(R1,IDs,Ps,Name,RuleCount),
1148 is_rule(RI2,R1,IDs,R).
1149 rule(RI,Name,R) :-
1150 inc_rule_count(RuleCount),
1151 R = pragma(R1,IDs,[],Name,RuleCount),
1152 is_rule(RI,R1,IDs,R).
1154 is_rule(RI,R,IDs,RC) :- %% propagation rule
1155 RI = (H ==> B), !,
1156 conj2list(H,Head2i),
1157 get_ids(Head2i,IDs2,Head2,RC),
1158 IDs = ids([],IDs2),
1159 ( B = (G | RB) ->
1160 R = rule([],Head2,G,RB)
1161 ;
1162 R = rule([],Head2,true,B)
1163 ).
1164 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1165 RI = (H <=> B), !,
1166 ( B = (G | RB) ->
1167 Guard = G,
1168 Body = RB
1169 ; Guard = true,
1170 Body = B
1171 ),
1172 ( H = (H1 \ H2) ->
1173 conj2list(H1,Head2i),
1174 conj2list(H2,Head1i),
1175 get_ids(Head2i,IDs2,Head2,0,N,RC),
1176 get_ids(Head1i,IDs1,Head1,N,_,RC),
1177 IDs = ids(IDs1,IDs2)
1178 ; conj2list(H,Head1i),
1179 Head2 = [],
1180 get_ids(Head1i,IDs1,Head1,RC),
1181 IDs = ids(IDs1,[])
1182 ),
1183 R = rule(Head1,Head2,Guard,Body).
1185 get_ids(Cs,IDs,NCs,RC) :-
1186 get_ids(Cs,IDs,NCs,0,_,RC).
1188 get_ids([],[],[],N,N,_).
1189 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1190 ( C = (NC # N1) ->
1191 ( var(N1) ->
1192 N1 = N
1193 ;
1194 check_direct_pragma(N1,N,RC)
1195 )
1196 ;
1197 NC = C
1198 ),
1199 M is N + 1,
1200 get_ids(Cs,IDs,NCs, M,NN,RC).
1202 check_direct_pragma(passive,Id,PragmaRule) :- !,
1203 PragmaRule = pragma(_,_,_,_,RuleNb),
1204 passive(RuleNb,Id).
1205 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1206 ( direct_pragma(FullPragma),
1207 atom_concat(Abbrev,Remainder,FullPragma) ->
1208 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1209 ;
1210 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1211 ).
1213 direct_pragma(passive).
1215 is_module_declaration((:- module(Mod)),Mod).
1216 is_module_declaration((:- module(Mod,_)),Mod).
1218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1220 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1221 % Add constraints
1222 add_constraints([]).
1223 add_constraints([C|Cs]) :-
1224 max_occurrence(C,0),
1225 C = _/A,
1226 length(Mode,A),
1227 set_elems(Mode,?),
1228 constraint_mode(C,Mode),
1229 add_constraints(Cs).
1231 % Add rules
1232 add_rules([]).
1233 add_rules([Rule|Rules]) :-
1234 Rule = pragma(_,_,_,_,RuleNb),
1235 rule(RuleNb,Rule),
1236 add_rules(Rules).
1238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1241 %% Some input verification:
1243 check_declared_constraints(Constraints) :-
1244 tree_set_empty(Acc),
1245 check_declared_constraints(Constraints,Acc).
1247 check_declared_constraints([],_).
1248 check_declared_constraints([C|Cs],Acc) :-
1249 ( tree_set_memberchk(C,Acc) ->
1250 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1251 ;
1252 true
1253 ),
1254 tree_set_add(Acc,C,NAcc),
1255 check_declared_constraints(Cs,NAcc).
1257 %% - all constraints in heads are declared constraints
1258 %% - all passive pragmas refer to actual head constraints
1260 check_rules([],_).
1261 check_rules([PragmaRule|Rest],Decls) :-
1262 check_rule(PragmaRule,Decls),
1263 check_rules(Rest,Decls).
1265 check_rule(PragmaRule,Decls) :-
1266 check_rule_indexing(PragmaRule),
1267 check_trivial_propagation_rule(PragmaRule),
1268 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1269 Rule = rule(H1,H2,_,_),
1270 append(H1,H2,HeadConstraints),
1271 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1272 check_pragmas(Pragmas,PragmaRule).
1274 % Make all heads passive in trivial propagation rule
1275 % ... ==> ... | true.
1276 check_trivial_propagation_rule(PragmaRule) :-
1277 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1278 ( Rule = rule([],_,_,true) ->
1279 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1280 set_all_passive(RuleNb)
1281 ;
1282 true
1283 ).
1285 check_head_constraints([],_,_).
1286 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1287 functor(Constr,F,A),
1288 ( memberchk(F/A,Decls) ->
1289 check_head_constraints(Rest,Decls,PragmaRule)
1290 ;
1291 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1292 ).
1294 check_pragmas([],_).
1295 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1296 check_pragma(Pragma,PragmaRule),
1297 check_pragmas(Pragmas,PragmaRule).
1299 check_pragma(Pragma,PragmaRule) :-
1300 var(Pragma), !,
1301 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1302 check_pragma(passive(ID), PragmaRule) :-
1303 !,
1304 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1305 ( memberchk_eq(ID,IDs1) ->
1306 true
1307 ; memberchk_eq(ID,IDs2) ->
1308 true
1309 ;
1310 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1311 ),
1312 passive(RuleNb,ID).
1314 check_pragma(mpassive(IDs), PragmaRule) :-
1315 !,
1316 PragmaRule = pragma(_,_,_,_,RuleNb),
1317 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1318 maplist(passive(RuleNb),IDs).
1320 check_pragma(Pragma, PragmaRule) :-
1321 Pragma = already_in_heads,
1322 !,
1323 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1325 check_pragma(Pragma, PragmaRule) :-
1326 Pragma = already_in_head(_),
1327 !,
1328 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1330 check_pragma(Pragma, PragmaRule) :-
1331 Pragma = no_history,
1332 !,
1333 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1334 PragmaRule = pragma(_,_,_,_,N),
1335 no_history(N).
1337 check_pragma(Pragma, PragmaRule) :-
1338 Pragma = history(HistoryName,IDs),
1339 !,
1340 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1341 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1342 ( IDs1 \== [] ->
1343 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1344 ; \+ atom(HistoryName) ->
1345 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1346 ; \+ is_set(IDs) ->
1347 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1348 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1349 history(RuleNb,HistoryName,IDs)
1350 ;
1351 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1352 ).
1353 check_pragma(Pragma,PragmaRule) :-
1354 Pragma = line_number(LineNumber),
1355 !,
1356 PragmaRule = pragma(_,_,_,_,RuleNb),
1357 line_number(RuleNb,LineNumber).
1359 check_history_pragma_ids([], _, _).
1360 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1361 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1362 check_history_pragma_ids(IDs,IDs1,IDs2).
1364 check_pragma(Pragma,PragmaRule) :-
1365 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1367 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1368 %% no_history(+RuleNb) is det.
1369 :- chr_constraint no_history/1.
1370 :- chr_option(mode,no_history(+)).
1371 :- chr_option(type_declaration,no_history(int)).
1373 %% has_no_history(+RuleNb) is semidet.
1374 :- chr_constraint has_no_history/1.
1375 :- chr_option(mode,has_no_history(+)).
1376 :- chr_option(type_declaration,has_no_history(int)).
1378 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1379 has_no_history(_) <=> fail.
1381 :- chr_constraint history/3.
1382 :- chr_option(mode,history(+,+,+)).
1383 :- chr_option(type_declaration,history(any,any,list)).
1385 :- chr_constraint named_history/3.
1387 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1388 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1390 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1391 length(IDs1,L1), length(IDs2,L2),
1392 ( L1 \== L2 ->
1393 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1394 ;
1395 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1396 ).
1398 test_named_history_id_pairs(_, [], _, []).
1399 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1400 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1401 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1403 :- chr_constraint test_named_history_id_pair/4.
1404 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1406 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1407 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1408 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1409 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1411 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1412 named_history(_,_,_) <=> fail.
1414 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1417 format_rule(PragmaRule) :-
1418 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1419 ( MaybeName = yes(Name) ->
1420 write('rule '), write(Name)
1421 ;
1422 write('rule number '), write(RuleNumber)
1423 ),
1424 get_line_number(RuleNumber,LineNumber),
1425 write(' (line '),
1426 write(LineNumber),
1427 write(')').
1429 check_rule_indexing(PragmaRule) :-
1430 PragmaRule = pragma(Rule,_,_,_,_),
1431 Rule = rule(H1,H2,G,_),
1432 term_variables(H1-H2,HeadVars),
1433 remove_anti_monotonic_guards(G,HeadVars,NG),
1434 check_indexing(H1,NG-H2),
1435 check_indexing(H2,NG-H1),
1436 % EXPERIMENT
1437 ( chr_pp_flag(term_indexing,on) ->
1438 term_variables(NG,GuardVariables),
1439 append(H1,H2,Heads),
1440 check_specs_indexing(Heads,GuardVariables,Specs)
1441 ;
1442 true
1443 ).
1445 :- chr_constraint indexing_spec/2.
1446 :- chr_option(mode,indexing_spec(+,+)).
1448 :- chr_constraint get_indexing_spec/2.
1449 :- chr_option(mode,get_indexing_spec(+,-)).
1452 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1453 get_indexing_spec(_,Spec) <=> Spec = [].
1455 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1456 <=>
1457 append(Specs1,Specs2,Specs),
1458 indexing_spec(FA,Specs).
1460 remove_anti_monotonic_guards(G,Vars,NG) :-
1461 conj2list(G,GL),
1462 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1463 list2conj(NGL,NG).
1465 remove_anti_monotonic_guard_list([],_,[]).
1466 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1467 ( G = var(X), memberchk_eq(X,Vars) ->
1468 NGs = RGs
1469 % TODO: this is not correct
1470 % ; G = functor(Term,Functor,Arity), % isotonic
1471 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1472 % NGs = RGs
1473 ;
1474 NGs = [G|RGs]
1475 ),
1476 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1478 check_indexing([],_).
1479 check_indexing([Head|Heads],Other) :-
1480 functor(Head,F,A),
1481 Head =.. [_|Args],
1482 term_variables(Heads-Other,OtherVars),
1483 check_indexing(Args,1,F/A,OtherVars),
1484 check_indexing(Heads,[Head|Other]).
1486 check_indexing([],_,_,_).
1487 check_indexing([Arg|Args],I,FA,OtherVars) :-
1488 ( is_indexed_argument(FA,I) ->
1489 true
1490 ; nonvar(Arg) ->
1491 indexed_argument(FA,I)
1492 ; % var(Arg) ->
1493 term_variables(Args,ArgsVars),
1494 append(ArgsVars,OtherVars,RestVars),
1495 ( memberchk_eq(Arg,RestVars) ->
1496 indexed_argument(FA,I)
1497 ;
1498 true
1499 )
1500 ),
1501 J is I + 1,
1502 term_variables(Arg,NVars),
1503 append(NVars,OtherVars,NOtherVars),
1504 check_indexing(Args,J,FA,NOtherVars).
1506 check_specs_indexing([],_,[]).
1507 check_specs_indexing([Head|Heads],Variables,Specs) :-
1508 Specs = [Spec|RSpecs],
1509 term_variables(Heads,OtherVariables,Variables),
1510 check_spec_indexing(Head,OtherVariables,Spec),
1511 term_variables(Head,NVariables,Variables),
1512 check_specs_indexing(Heads,NVariables,RSpecs).
1514 check_spec_indexing(Head,OtherVariables,Spec) :-
1515 functor(Head,F,A),
1516 Spec = spec(F,A,ArgSpecs),
1517 Head =.. [_|Args],
1518 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1519 indexing_spec(F/A,[ArgSpecs]).
1521 check_args_spec_indexing([],_,_,[]).
1522 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1523 term_variables(Args,Variables,OtherVariables),
1524 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1525 ArgSpecs = [ArgSpec|RArgSpecs]
1526 ;
1527 ArgSpecs = RArgSpecs
1528 ),
1529 J is I + 1,
1530 term_variables(Arg,NOtherVariables,OtherVariables),
1531 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1533 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1534 ( var(Arg) ->
1535 memberchk_eq(Arg,Variables),
1536 ArgSpec = specinfo(I,any,[])
1537 ;
1538 functor(Arg,F,A),
1539 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1540 Arg =.. [_|Args],
1541 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1542 ).
1544 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1546 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1547 % Occurrences
1549 add_occurrences([]).
1550 add_occurrences([Rule|Rules]) :-
1551 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1552 add_occurrences(H1,IDs1,simplification,Nb),
1553 add_occurrences(H2,IDs2,propagation,Nb),
1554 add_occurrences(Rules).
1556 add_occurrences([],[],_,_).
1557 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1558 functor(H,F,A),
1559 FA = F/A,
1560 new_occurrence(FA,RuleNb,ID,Type),
1561 add_occurrences(Hs,IDs,Type,RuleNb).
1563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1565 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1566 % Observation Analysis
1567 %
1568 % CLASSIFICATION
1569 %
1570 %
1571 %
1572 %
1573 %
1574 %
1576 :- chr_constraint observation_analysis/1.
1577 :- chr_option(mode, observation_analysis(+)).
1579 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1580 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1581 ( chr_pp_flag(store_in_guards, on) ->
1582 observation_analysis(RuleNb, Guard, guard, Cs)
1583 ;
1584 true
1585 ),
1586 observation_analysis(RuleNb, Body, body, Cs)
1588 pragma passive(Id).
1589 observation_analysis(_) <=> true.
1591 observation_analysis(RuleNb, Term, GB, Cs) :-
1592 ( all_spawned(RuleNb,GB) ->
1593 true
1594 ; var(Term) ->
1595 spawns_all(RuleNb,GB)
1596 ; Term = true ->
1597 true
1598 ; Term = fail ->
1599 true
1600 ; Term = '!' ->
1601 true
1602 ; Term = (T1,T2) ->
1603 observation_analysis(RuleNb,T1,GB,Cs),
1604 observation_analysis(RuleNb,T2,GB,Cs)
1605 ; Term = (T1;T2) ->
1606 observation_analysis(RuleNb,T1,GB,Cs),
1607 observation_analysis(RuleNb,T2,GB,Cs)
1608 ; Term = (T1->T2) ->
1609 observation_analysis(RuleNb,T1,GB,Cs),
1610 observation_analysis(RuleNb,T2,GB,Cs)
1611 ; Term = (\+ T) ->
1612 observation_analysis(RuleNb,T,GB,Cs)
1613 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1614 spawns(RuleNb,GB,F/A)
1615 ; Term = (_ = _) ->
1616 spawns_all_triggers(RuleNb,GB)
1617 ; Term = (_ is _) ->
1618 spawns_all_triggers(RuleNb,GB)
1619 ; builtin_binds_b(Term,Vars) ->
1620 ( Vars == [] ->
1621 true
1622 ;
1623 spawns_all_triggers(RuleNb,GB)
1624 )
1625 ;
1626 spawns_all(RuleNb,GB)
1627 ).
1629 :- chr_constraint spawns/3.
1630 :- chr_option(mode, spawns(+,+,+)).
1631 :- chr_type spawns_type ---> guard ; body.
1632 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1634 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1635 :- chr_option(mode, spawns_all(+,+)).
1636 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1637 :- chr_option(mode, spawns_all_triggers(+,+)).
1638 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1640 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1641 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1642 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1643 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1644 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1645 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1647 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1648 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1649 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1650 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1652 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1653 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1655 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1656 \
1657 spawns(RuleNb1,GB,C1)
1658 <=>
1659 \+ is_passive(RuleNb2,O)
1660 |
1661 spawns_all(RuleNb1,GB)
1662 pragma
1663 passive(Id).
1665 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1666 ==>
1667 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1668 \+ is_passive(RuleNb2,O), may_trigger(C1)
1669 |
1670 spawns_all_triggers_implies_spawns_all
1671 pragma
1672 passive(Id).
1674 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1675 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1676 spawns_all_triggers_implies_spawns_all \
1677 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1679 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1680 \
1681 spawns(RuleNb1,GB,C1)
1682 <=>
1683 may_trigger(C1),
1684 \+ is_passive(RuleNb2,O)
1685 |
1686 spawns_all_triggers(RuleNb1,GB)
1687 pragma
1688 passive(Id).
1690 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1691 spawns(RuleNb1,GB,C1)
1692 ==>
1693 \+ may_trigger(C1),
1694 \+ is_passive(RuleNb2,O)
1695 |
1696 spawns_all_triggers(RuleNb1,GB)
1697 pragma
1698 passive(Id).
1700 % a bit dangerous this rule: could start propagating too much too soon?
1701 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1702 spawns(RuleNb1,GB,C1)
1703 ==>
1704 RuleNb1 \== RuleNb2, C1 \== C2,
1705 \+ is_passive(RuleNb2,O)
1706 |
1707 spawns(RuleNb1,GB,C2)
1708 pragma
1709 passive(Id).
1711 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1712 spawns_all_triggers(RuleNb1,GB)
1713 ==>
1714 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1715 |
1716 spawns(RuleNb1,GB,C2)
1717 pragma
1718 passive(Id).
1721 :- chr_constraint all_spawned/2.
1722 :- chr_option(mode, all_spawned(+,+)).
1723 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1724 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1725 all_spawned(RuleNb,GB) <=> fail.
1728 % Overview of the supported queries:
1729 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1730 % only succeeds if the occurrence is observed by the
1731 % guard resp. body (depending on the last argument) of its rule
1732 % is_observed(+functor/artiy, +occurrence_number, -)
1733 % succeeds if the occurrence is observed by either the guard or
1734 % the body of its rule
1735 % NOTE: the last argument is NOT bound by this query
1736 %
1737 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1738 % succeeds if the given constraint is observed by the given
1739 % guard resp. body
1740 % do_is_observed(+functor/artiy,+rule_number)
1741 % succeeds if the given constraint is observed by the given
1742 % rule (either its guard or its body)
1745 is_observed(C,O) :-
1746 is_observed(C,O,_),
1747 ai_is_observed(C,O).
1749 is_stored_in_guard(C,RuleNb) :-
1750 chr_pp_flag(store_in_guards, on),
1751 do_is_observed(C,RuleNb,guard).
1753 :- chr_constraint is_observed/3.
1754 :- chr_option(mode, is_observed(+,+,+)).
1755 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1756 is_observed(_,_,_) <=> fail. % this will not happen in practice
1759 :- chr_constraint do_is_observed/3.
1760 :- chr_option(mode, do_is_observed(+,+,?)).
1761 :- chr_constraint do_is_observed/2.
1762 :- chr_option(mode, do_is_observed(+,+)).
1764 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1766 % (1) spawns_all
1767 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1768 % and some non-passive occurrence of some (possibly other) constraint
1769 % exists in a rule (could be same rule) with at least one occurrence of C
1771 spawns_all(RuleNb,GB),
1772 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1773 \
1774 do_is_observed(C,RuleNb,GB)
1775 <=>
1776 \+ is_passive(RuleNb2,O)
1777 |
1778 true.
1780 spawns_all(RuleNb,_),
1781 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1782 \
1783 do_is_observed(C,RuleNb)
1784 <=>
1785 \+ is_passive(RuleNb2,O)
1786 |
1787 true.
1789 % (2) spawns
1790 % a constraint C is observed if the GB of the rule it occurs in spawns a
1791 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1792 % as an occurrence of C
1794 spawns(RuleNb,GB,C2),
1795 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1796 \
1797 do_is_observed(C,RuleNb,GB)
1798 <=>
1799 \+ is_passive(RuleNb2,O)
1800 |
1801 true.
1803 spawns(RuleNb,_,C2),
1804 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1805 \
1806 do_is_observed(C,RuleNb)
1807 <=>
1808 \+ is_passive(RuleNb2,O)
1809 |
1810 true.
1812 % (3) spawns_all_triggers
1813 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1814 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1815 % exists in a rule (could be same rule) with at least one occurrence of C
1817 spawns_all_triggers(RuleNb,GB),
1818 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1819 \
1820 do_is_observed(C,RuleNb,GB)
1821 <=>
1822 \+ is_passive(RuleNb2,O), may_trigger(C2)
1823 |
1824 true.
1826 spawns_all_triggers(RuleNb,_),
1827 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1828 \
1829 do_is_observed(C,RuleNb)
1830 <=>
1831 \+ is_passive(RuleNb2,O), may_trigger(C2)
1832 |
1833 true.
1835 % (4) conservativeness
1836 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1837 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1840 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1842 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1844 %%
1845 %% Generated predicates
1846 %% attach_$CONSTRAINT
1847 %% attach_increment
1848 %% detach_$CONSTRAINT
1849 %% attr_unify_hook
1851 %% attach_$CONSTRAINT
1852 generate_attach_detach_a_constraint_all([],[]).
1853 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1854 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1855 generate_attach_a_constraint(Constraint,Clauses1),
1856 generate_detach_a_constraint(Constraint,Clauses2)
1857 ;
1858 Clauses1 = [],
1859 Clauses2 = []
1860 ),
1861 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1862 append([Clauses1,Clauses2,Clauses3],Clauses).
1864 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1865 generate_attach_a_constraint_nil(Constraint,Clause1),
1866 generate_attach_a_constraint_cons(Constraint,Clause2).
1868 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1869 make_name('attach_',FA,Name),
1870 Atom =.. [Name,Vars,Susp].
1872 generate_attach_a_constraint_nil(FA,Clause) :-
1873 Clause = (Head :- true),
1874 attach_constraint_atom(FA,[],_,Head).
1876 generate_attach_a_constraint_cons(FA,Clause) :-
1877 Clause = (Head :- Body),
1878 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1879 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1880 Body = ( AttachBody, Subscribe, RecursiveCall ),
1881 get_max_constraint_index(N),
1882 ( N == 1 ->
1883 generate_attach_body_1(FA,Var,Susp,AttachBody)
1884 ;
1885 generate_attach_body_n(FA,Var,Susp,AttachBody)
1886 ),
1887 % SWI-Prolog specific code
1888 chr_pp_flag(solver_events,NMod),
1889 ( NMod \== none ->
1890 Args = [[Var|_],Susp],
1891 get_target_module(Mod),
1892 use_auxiliary_predicate(run_suspensions),
1893 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1894 ;
1895 Subscribe = true
1896 ).
1898 generate_attach_body_1(FA,Var,Susp,Body) :-
1899 get_target_module(Mod),
1900 Body =
1901 ( get_attr(Var, Mod, Susps) ->
1902 put_attr(Var, Mod, [Susp|Susps])
1903 ;
1904 put_attr(Var, Mod, [Susp])
1905 ).
1907 generate_attach_body_n(F/A,Var,Susp,Body) :-
1908 get_constraint_index(F/A,Position),
1909 get_max_constraint_index(Total),
1910 get_target_module(Mod),
1911 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1912 singleton_attr(Total,Susp,Position,NewAttr3),
1913 Body =
1914 ( get_attr(Var,Mod,TAttr) ->
1915 AddGoal,
1916 put_attr(Var,Mod,NTAttr)
1917 ;
1918 put_attr(Var,Mod,NewAttr3)
1919 ), !.
1921 %% detach_$CONSTRAINT
1922 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1923 generate_detach_a_constraint_nil(Constraint,Clause1),
1924 generate_detach_a_constraint_cons(Constraint,Clause2).
1926 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1927 make_name('detach_',FA,Name),
1928 Atom =.. [Name,Vars,Susp].
1930 generate_detach_a_constraint_nil(FA,Clause) :-
1931 Clause = ( Head :- true),
1932 detach_constraint_atom(FA,[],_,Head).
1934 generate_detach_a_constraint_cons(FA,Clause) :-
1935 Clause = (Head :- Body),
1936 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1937 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1938 Body = ( DetachBody, RecursiveCall ),
1939 get_max_constraint_index(N),
1940 ( N == 1 ->
1941 generate_detach_body_1(FA,Var,Susp,DetachBody)
1942 ;
1943 generate_detach_body_n(FA,Var,Susp,DetachBody)
1944 ).
1946 generate_detach_body_1(FA,Var,Susp,Body) :-
1947 get_target_module(Mod),
1948 Body =
1949 ( get_attr(Var,Mod,Susps) ->
1950 'chr sbag_del_element'(Susps,Susp,NewSusps),
1951 ( NewSusps == [] ->
1952 del_attr(Var,Mod)
1953 ;
1954 put_attr(Var,Mod,NewSusps)
1955 )
1956 ;
1957 true
1958 ).
1960 generate_detach_body_n(F/A,Var,Susp,Body) :-
1961 get_constraint_index(F/A,Position),
1962 get_max_constraint_index(Total),
1963 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1964 get_target_module(Mod),
1965 Body =
1966 ( get_attr(Var,Mod,TAttr) ->
1967 RemGoal
1968 ;
1969 true
1970 ), !.
1972 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1973 %-------------------------------------------------------------------------------
1974 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1975 :- chr_constraint generate_indexed_variables_body/4.
1976 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1977 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1978 %-------------------------------------------------------------------------------
1979 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1980 get_indexing_spec(F/A,Specs),
1981 ( chr_pp_flag(term_indexing,on) ->
1982 spectermvars(Specs,Args,F,A,Body,Vars)
1983 ;
1984 get_constraint_type_det(F/A,ArgTypes),
1985 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1986 ( MaybeBody == empty ->
1987 Body = true,
1988 Vars = []
1989 ; N == 0 ->
1990 ( Args = [Term] ->
1991 true
1992 ;
1993 Term =.. [term|Args]
1994 ),
1995 Body = term_variables(Term,Vars)
1996 ;
1997 MaybeBody = Body
1998 )
1999 ).
2000 generate_indexed_variables_body(FA,_,_,_) <=>
2001 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
2002 %===============================================================================
2004 create_indexed_variables_body([],[],[],_,_,_,empty,0).
2005 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
2006 J is I + 1,
2007 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
2008 ( Mode == (?),
2009 is_indexed_argument(FA,I) ->
2010 ( atomic_type(Type) ->
2011 Body =
2012 (
2013 ( var(V) ->
2014 Vars = [V|Tail]
2015 ;
2016 Vars = Tail
2017 ),
2018 Continuation
2019 ),
2020 ( RBody == empty ->
2021 Continuation = true, Tail = []
2022 ;
2023 Continuation = RBody
2024 )
2025 ;
2026 ( RBody == empty ->
2027 Body = term_variables(V,Vars)
2028 ;
2029 Body = (term_variables(V,Vars,Tail),RBody)
2030 )
2031 ),
2032 N = M
2033 ; Mode == (-), is_indexed_argument(FA,I) ->
2034 ( RBody == empty ->
2035 Body = (Vars = [V])
2036 ;
2037 Body = (Vars = [V|Tail],RBody)
2038 ),
2039 N is M + 1
2040 ;
2041 Vars = Tail,
2042 Body = RBody,
2043 N is M + 1
2044 ).
2045 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2046 % EXPERIMENTAL
2047 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2048 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2050 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2051 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2052 Goal = (ArgGoal,RGoal),
2053 argspecs(Specs,I,TempArgSpecs,RSpecs),
2054 merge_argspecs(TempArgSpecs,ArgSpecs),
2055 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2056 J is I + 1,
2057 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2059 argspecs([],_,[],[]).
2060 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2061 argspecs(Rest,I,ArgSpecs,RestSpecs).
2062 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2063 ( I == J ->
2064 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2065 ( Specs = [] ->
2066 RRestSpecs = RestSpecs
2067 ;
2068 RestSpecs = [Specs|RRestSpecs]
2069 )
2070 ;
2071 ArgSpecs = RArgSpecs,
2072 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2073 ),
2074 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2076 merge_argspecs(In,Out) :-
2077 sort(In,Sorted),
2078 merge_argspecs_(Sorted,Out).
2080 merge_argspecs_([],[]).
2081 merge_argspecs_([X],R) :- !, R = [X].
2082 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2083 ( (F1 == any ; F2 == any) ->
2084 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2085 ; F1 == F2 ->
2086 append(A1,A2,A),
2087 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2088 ;
2089 R = [specinfo(I,F1,A1)|RR],
2090 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2091 ).
2093 arggoal(List,Arg,Goal,L,T) :-
2094 ( List == [] ->
2095 L = T,
2096 Goal = true
2097 ; List = [specinfo(_,any,_)] ->
2098 Goal = term_variables(Arg,L,T)
2099 ;
2100 Goal =
2101 ( var(Arg) ->
2102 L = [Arg|T]
2103 ;
2104 Cases
2105 ),
2106 arggoal_cases(List,Arg,L,T,Cases)
2107 ).
2109 arggoal_cases([],_,L,T,L=T).
2110 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2111 ( ArgSpecs == [] ->
2112 Cases = RCases
2113 ; ArgSpecs == [[]] ->
2114 Cases = RCases
2115 ; FA = F/A ->
2116 Cases = (Case ; RCases),
2117 functor(Term,F,A),
2118 Term =.. [_|Args],
2119 Case = (Arg = Term -> ArgsGoal),
2120 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2121 ),
2122 arggoal_cases(Rest,Arg,L,T,RCases).
2123 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2125 generate_extra_clauses(Constraints,List) :-
2126 generate_activate_clauses(Constraints,List,Tail0),
2127 generate_remove_clauses(Constraints,Tail0,Tail1),
2128 generate_allocate_clauses(Constraints,Tail1,Tail2),
2129 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2130 generate_novel_production(Tail3,Tail4),
2131 generate_extend_history(Tail4,Tail5),
2132 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2133 generate_empty_named_history_initialisations(Tail6,Tail7),
2134 Tail7 = [].
2136 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2137 % remove_constraint_internal/[1/3]
2139 generate_remove_clauses([],List,List).
2140 generate_remove_clauses([C|Cs],List,Tail) :-
2141 generate_remove_clause(C,List,List1),
2142 generate_remove_clauses(Cs,List1,Tail).
2144 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2145 uses_state(Constraint,removed),
2146 ( chr_pp_flag(inline_insertremove,off) ->
2147 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2148 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2149 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2150 ;
2151 delay_phase_end(validate_store_type_assumptions,
2152 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2153 )
2154 ).
2156 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2157 make_name('$remove_constraint_internal_',Constraint,Name),
2158 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2159 Goal =.. [Name, Susp,Delete]
2160 ;
2161 Goal =.. [Name,Susp,Agenda,Delete]
2162 ).
2164 generate_remove_clause(Constraint,List,Tail) :-
2165 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2166 List = [RemoveClause|Tail],
2167 RemoveClause = (Head :- RemoveBody),
2168 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2169 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2170 ;
2171 List = Tail
2172 ).
2174 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2175 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2176 ( Role == active ->
2177 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2178 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2179 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2180 ; Role == partner ->
2181 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2182 GetStateValue = true,
2183 MaybeDelete = DeleteYes
2184 ),
2185 RemoveBody =
2186 (
2187 GetState,
2188 GetStateValue,
2189 UpdateState,
2190 MaybeDelete
2191 )
2192 ;
2193 static_suspension_term(Constraint,Susp2),
2194 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2195 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2196 ( chr_pp_flag(debugable,on) ->
2197 Constraint = Functor / _,
2198 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2199 ;
2200 true
2201 ),
2202 ( Role == active ->
2203 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2204 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2205 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2206 ; Role == partner ->
2207 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2208 GetStateValue = true,
2209 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2210 ),
2211 RemoveBody =
2212 (
2213 Susp = Susp2,
2214 GetStateValue,
2215 UpdateState,
2216 MaybeDelete
2217 )
2218 ).
2220 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2221 % activate_constraint/4
2223 generate_activate_clauses([],List,List).
2224 generate_activate_clauses([C|Cs],List,Tail) :-
2225 generate_activate_clause(C,List,List1),
2226 generate_activate_clauses(Cs,List1,Tail).
2228 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2229 ( chr_pp_flag(inline_insertremove,off) ->
2230 use_auxiliary_predicate(activate_constraint,Constraint),
2231 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2232 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2233 ;
2234 delay_phase_end(validate_store_type_assumptions,
2235 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2236 )
2237 ).
2239 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2240 make_name('$activate_constraint_',Constraint,Name),
2241 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2242 Goal =.. [Name,Store, Susp]
2243 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2244 Goal =.. [Name,Store, Susp, Generation]
2245 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2246 Goal =.. [Name,Store, Vars, Susp, Generation]
2247 ;
2248 Goal =.. [Name,Store, Vars, Susp]
2249 ).
2251 generate_activate_clause(Constraint,List,Tail) :-
2252 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2253 List = [Clause|Tail],
2254 Clause = (Head :- Body),
2255 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2256 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2257 ;
2258 List = Tail
2259 ).
2261 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2262 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2263 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2264 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2265 ;
2266 GenerationHandling = true
2267 ),
2268 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2269 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2270 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2271 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2272 ;
2273 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2274 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2275 ( chr_pp_flag(guard_locks,off) ->
2276 NoneLocked = true
2277 ;
2278 NoneLocked = 'chr none_locked'( Vars)
2279 ),
2280 if_used_state(Constraint,not_stored_yet,
2281 ( State == not_stored_yet ->
2282 ArgumentsGoal,
2283 IndexedVariablesBody,
2284 NoneLocked,
2285 StoreYes
2286 ;
2287 % Vars = [],
2288 StoreNo
2289 ),
2290 % (Vars = [],StoreNo),StoreVarsGoal)
2291 StoreNo,StoreVarsGoal)
2292 ),
2293 Body =
2294 (
2295 GetState,
2296 GetStateValue,
2297 UpdateState,
2298 GenerationHandling,
2299 StoreVarsGoal
2300 ).
2301 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2302 % allocate_constraint/4
2304 generate_allocate_clauses([],List,List).
2305 generate_allocate_clauses([C|Cs],List,Tail) :-
2306 generate_allocate_clause(C,List,List1),
2307 generate_allocate_clauses(Cs,List1,Tail).
2309 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2310 uses_state(Constraint,not_stored_yet),
2311 ( chr_pp_flag(inline_insertremove,off) ->
2312 use_auxiliary_predicate(allocate_constraint,Constraint),
2313 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2314 ;
2315 Goal = (Susp = Suspension, Goal0),
2316 delay_phase_end(validate_store_type_assumptions,
2317 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2318 )
2319 ).
2321 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2322 make_name('$allocate_constraint_',Constraint,Name),
2323 Goal =.. [Name,Susp|Args].
2325 generate_allocate_clause(Constraint,List,Tail) :-
2326 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2327 List = [Clause|Tail],
2328 Clause = (Head :- Body),
2329 Constraint = _/A,
2330 length(Args,A),
2331 allocate_constraint_atom(Constraint,Susp,Args,Head),
2332 allocate_constraint_body(Constraint,Susp,Args,Body)
2333 ;
2334 List = Tail
2335 ).
2337 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2338 static_suspension_term(Constraint,Suspension),
2339 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2340 ( chr_pp_flag(debugable,on) ->
2341 Constraint = Functor / _,
2342 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2343 ;
2344 true
2345 ),
2346 ( chr_pp_flag(debugable,on) ->
2347 ( may_trigger(Constraint) ->
2348 append(Args,[Susp],VarsSusp),
2349 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2350 get_target_module(Mod),
2351 Continuation = Mod : ContinuationGoal
2352 ;
2353 Continuation = true
2354 ),
2355 Init = (Susp = Suspension),
2356 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2357 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2358 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2359 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2360 Susp = Suspension, Init = true, CreateContinuation = true
2361 ;
2362 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2363 ),
2364 ( uses_history(Constraint) ->
2365 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2366 ;
2367 CreateHistory = true
2368 ),
2369 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2370 ( has_suspension_field(Constraint,id) ->
2371 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2372 gen_id(Id,GenID)
2373 ;
2374 GenID = true
2375 ),
2376 Body =
2377 (
2378 Init,
2379 CreateContinuation,
2380 CreateGeneration,
2381 CreateHistory,
2382 CreateState,
2383 GenID
2384 ).
2386 gen_id(Id,'chr gen_id'(Id)).
2387 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2388 % insert_constraint_internal
2390 generate_insert_constraint_internal_clauses([],List,List).
2391 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2392 generate_insert_constraint_internal_clause(C,List,List1),
2393 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2395 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2396 ( chr_pp_flag(inline_insertremove,off) ->
2397 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2398 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2399 ;
2400 delay_phase_end(validate_store_type_assumptions,
2401 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2402 )
2403 ).
2406 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2407 insert_constraint_internal_constraint_name(Constraint,Name),
2408 ( chr_pp_flag(debugable,on) ->
2409 Goal =.. [Name, Vars, Self, Closure | Args]
2410 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2411 Goal =.. [Name,Self | Args]
2412 ;
2413 Goal =.. [Name,Vars, Self | Args]
2414 ).
2416 insert_constraint_internal_constraint_name(Constraint,Name) :-
2417 make_name('$insert_constraint_internal_',Constraint,Name).
2419 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2420 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2421 List = [Clause|Tail],
2422 Clause = (Head :- Body),
2423 Constraint = _/A,
2424 length(Args,A),
2425 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2426 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2427 ;
2428 List = Tail
2429 ).
2432 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2433 static_suspension_term(Constraint,Suspension),
2434 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2435 ( chr_pp_flag(debugable,on) ->
2436 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2437 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2438 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2439 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2440 ;
2441 CreateGeneration = true
2442 ),
2443 ( chr_pp_flag(debugable,on) ->
2444 Constraint = Functor / _,
2445 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2446 ;
2447 true
2448 ),
2449 ( uses_history(Constraint) ->
2450 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2451 ;
2452 CreateHistory = true
2453 ),
2454 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2455 List = [Clause|Tail],
2456 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2457 suspension_term_base_fields(Constraint,BaseFields),
2458 ( has_suspension_field(Constraint,id) ->
2459 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2460 gen_id(Id,GenID)
2461 ;
2462 GenID = true
2463 ),
2464 Body =
2465 (
2466 Susp = Suspension,
2467 CreateState,
2468 CreateGeneration,
2469 CreateHistory,
2470 GenID
2471 )
2472 ;
2473 ( has_suspension_field(Constraint,id) ->
2474 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2475 gen_id(Id,GenID)
2476 ;
2477 GenID = true
2478 ),
2479 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2480 ( chr_pp_flag(guard_locks,off) ->
2481 NoneLocked = true
2482 ;
2483 NoneLocked = 'chr none_locked'( Vars)
2484 ),
2485 Body =
2486 (
2487 Susp = Suspension,
2488 IndexedVariablesBody,
2489 NoneLocked,
2490 CreateState,
2491 CreateGeneration,
2492 CreateHistory,
2493 GenID
2494 )
2495 ).
2497 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2498 % novel_production/2
2500 generate_novel_production(List,Tail) :-
2501 ( is_used_auxiliary_predicate(novel_production) ->
2502 List = [Clause|Tail],
2503 Clause =
2504 (
2505 '$novel_production'( Self, Tuple) :-
2506 % arg( 3, Self, Ref), % ARGXXX
2507 % 'chr get_mutable'( History, Ref),
2508 arg( 3, Self, History), % ARGXXX
2509 ( hprolog:get_ds( Tuple, History, _) ->
2510 fail
2511 ;
2512 true
2513 )
2514 )
2515 ;
2516 List = Tail
2517 ).
2519 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2520 % extend_history/2
2522 generate_extend_history(List,Tail) :-
2523 ( is_used_auxiliary_predicate(extend_history) ->
2524 List = [Clause|Tail],
2525 Clause =
2526 (
2527 '$extend_history'( Self, Tuple) :-
2528 % arg( 3, Self, Ref), % ARGXXX
2529 % 'chr get_mutable'( History, Ref),
2530 arg( 3, Self, History), % ARGXXX
2531 hprolog:put_ds( Tuple, History, x, NewHistory),
2532 setarg( 3, Self, NewHistory) % ARGXXX
2533 )
2534 ;
2535 List = Tail
2536 ).
2538 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2539 %
2540 :- chr_constraint
2541 empty_named_history_initialisations/2,
2542 generate_empty_named_history_initialisation/1,
2543 find_empty_named_histories/0.
2545 generate_empty_named_history_initialisations(List, Tail) :-
2546 empty_named_history_initialisations(List, Tail),
2547 find_empty_named_histories.
2549 find_empty_named_histories, history(_, Name, []) ==>
2550 generate_empty_named_history_initialisation(Name).
2552 generate_empty_named_history_initialisation(Name) \
2553 generate_empty_named_history_initialisation(Name) <=> true.
2554 generate_empty_named_history_initialisation(Name) \
2555 empty_named_history_initialisations(List, Tail) # Passive
2556 <=>
2557 empty_named_history_global_variable(Name, GlobalVariable),
2558 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2559 empty_named_history_initialisations(Rest, Tail)
2560 pragma passive(Passive).
2562 find_empty_named_histories \
2563 generate_empty_named_history_initialisation(_) # Passive <=> true
2564 pragma passive(Passive).
2566 find_empty_named_histories,
2567 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2568 pragma passive(Passive).
2570 find_empty_named_histories <=>
2571 chr_error(internal, 'find_empty_named_histories was not removed', []).
2574 empty_named_history_global_variable(Name, GlobalVariable) :-
2575 atom_concat('chr empty named history ', Name, GlobalVariable).
2577 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2578 empty_named_history_global_variable(Name, GlobalVariable).
2580 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2581 empty_named_history_global_variable(Name, GlobalVariable).
2584 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2585 % run_suspensions/2
2587 generate_run_suspensions_clauses([],List,List).
2588 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2589 generate_run_suspensions_clause(C,List,List1),
2590 generate_run_suspensions_clauses(Cs,List1,Tail).
2592 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2593 make_name('$run_suspensions_',Constraint,Name),
2594 Goal =.. [Name,Suspensions].
2596 generate_run_suspensions_clause(Constraint,List,Tail) :-
2597 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2598 List = [Clause1,Clause2|Tail],
2599 run_suspensions_goal(Constraint,[],Clause1),
2600 ( chr_pp_flag(debugable,on) ->
2601 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2602 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2603 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2604 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2605 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2606 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2607 Clause2 =
2608 (
2609 Clause2Head :-
2610 GetState,
2611 GetStateValue,
2612 ( State==active ->
2613 UpdateState,
2614 GetGeneration,
2615 GetGenerationValue,
2616 Generation is Gen+1,
2617 UpdateGeneration,
2618 GetContinuation,
2619 (
2620 'chr debug_event'(wake(Suspension)),
2621 call(Continuation)
2622 ;
2623 'chr debug_event'(fail(Suspension)), !,
2624 fail
2625 ),
2626 (
2627 'chr debug_event'(exit(Suspension))
2628 ;
2629 'chr debug_event'(redo(Suspension)),
2630 fail
2631 ),
2632 GetPost,
2633 GetPostValue,
2634 ( Post==triggered ->
2635 UpdatePost % catching constraints that did not do anything
2636 ;
2637 true
2638 )
2639 ;
2640 true
2641 ),
2642 Clause2Recursion
2643 )
2644 ;
2645 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2646 static_suspension_term(Constraint,SuspensionTerm),
2647 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2648 append(Arguments,[Suspension],VarsSusp),
2649 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2650 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2651 ( uses_field(Constraint,generation) ->
2652 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2653 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2654 ;
2655 GenerationHandling = true
2656 ),
2657 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2658 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2659 if_used_state(Constraint,removed,
2660 ( GetState,
2661 ( State==active
2662 -> ReactivateConstraint
2663 ; true)
2664 ),ReactivateConstraint,CondReactivate),
2665 ReactivateConstraint =
2666 (
2667 UpdateState,
2668 GenerationHandling,
2669 Continuation,
2670 GetPostState,
2671 ( Post==triggered ->
2672 UpdatePostState % catching constraints that did not do anything
2673 ;
2674 true
2675 )
2676 ),
2677 Clause2 =
2678 (
2679 Clause2Head :-
2680 Suspension = SuspensionTerm,
2681 CondReactivate,
2682 Clause2Recursion
2683 )
2684 )
2685 ;
2686 List = Tail
2687 ).
2689 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2691 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2692 generate_attach_increment(Clauses) :-
2693 get_max_constraint_index(N),
2694 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2695 Clauses = [Clause1,Clause2],
2696 generate_attach_increment_empty(Clause1),
2697 ( N == 1 ->
2698 generate_attach_increment_one(Clause2)
2699 ;
2700 generate_attach_increment_many(N,Clause2)
2701 )
2702 ;
2703 Clauses = []
2704 ).
2706 generate_attach_increment_empty((attach_increment([],_) :- true)).
2708 generate_attach_increment_one(Clause) :-
2709 Head = attach_increment([Var|Vars],Susps),
2710 get_target_module(Mod),
2711 ( chr_pp_flag(guard_locks,off) ->
2712 NotLocked = true
2713 ;
2714 NotLocked = 'chr not_locked'( Var)
2715 ),
2716 Body =
2717 (
2718 NotLocked,
2719 ( get_attr(Var,Mod,VarSusps) ->
2720 sort(VarSusps,SortedVarSusps),
2721 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2722 put_attr(Var,Mod,MergedSusps)
2723 ;
2724 put_attr(Var,Mod,Susps)
2725 ),
2726 attach_increment(Vars,Susps)
2727 ),
2728 Clause = (Head :- Body).
2730 generate_attach_increment_many(N,Clause) :-
2731 Head = attach_increment([Var|Vars],TAttr1),
2732 % writeln(merge_attributes_1_before),
2733 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2734 % writeln(merge_attributes_1_after),
2735 get_target_module(Mod),
2736 ( chr_pp_flag(guard_locks,off) ->
2737 NotLocked = true
2738 ;
2739 NotLocked = 'chr not_locked'( Var)
2740 ),
2741 Body =
2742 (
2743 NotLocked,
2744 ( get_attr(Var,Mod,TAttr2) ->
2745 MergeGoal,
2746 put_attr(Var,Mod,Attr)
2747 ;
2748 put_attr(Var,Mod,TAttr1)
2749 ),
2750 attach_increment(Vars,TAttr1)
2751 ),
2752 Clause = (Head :- Body).
2754 %% attr_unify_hook
2755 generate_attr_unify_hook(Clauses) :-
2756 get_max_constraint_index(N),
2757 ( N == 0 ->
2758 Clauses = []
2759 ;
2760 ( N == 1 ->
2761 generate_attr_unify_hook_one(Clauses)
2762 ;
2763 generate_attr_unify_hook_many(N,Clauses)
2764 )
2765 ).
2767 generate_attr_unify_hook_one([Clause]) :-
2768 Head = attr_unify_hook(Susps,Other),
2769 get_target_module(Mod),
2770 get_indexed_constraint(1,C),
2771 ( get_store_type(C,ST),
2772 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2773 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2774 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2775 ( atomic_types_suspended_constraint(C) ->
2776 SortGoal1 = true,
2777 SortedSusps = Susps,
2778 SortGoal2 = true,
2779 SortedOtherSusps = OtherSusps,
2780 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2781 NonvarBody = true
2782 ;
2783 SortGoal1 = sort(Susps, SortedSusps),
2784 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2785 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2786 use_auxiliary_predicate(attach_increment),
2787 NonvarBody =
2788 ( compound(Other) ->
2789 term_variables(Other,OtherVars),
2790 attach_increment(OtherVars, SortedSusps)
2791 ;
2792 true
2793 )
2794 ),
2795 Body =
2796 (
2797 SortGoal1,
2798 ( var(Other) ->
2799 ( get_attr(Other,Mod,OtherSusps) ->
2800 SortGoal2,
2801 MergeGoal,
2802 put_attr(Other,Mod,NewSusps),
2803 WakeNewSusps
2804 ;
2805 put_attr(Other,Mod,SortedSusps),
2806 WakeSusps
2807 )
2808 ;
2809 NonvarBody,
2810 WakeSusps
2811 )
2812 ),
2813 Clause = (Head :- Body)
2814 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2815 make_run_suspensions(List,List,WakeNewSusps),
2816 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2817 Body =
2818 ( get_attr(Other,Mod,OtherSusps) ->
2819 MergeGoal,
2820 WakeNewSusps
2821 ;
2822 put_attr(Other,Mod,Susps)
2823 ),
2824 Clause = (Head :- Body)
2825 ).
2828 generate_attr_unify_hook_many(N,[Clause]) :-
2829 chr_pp_flag(dynattr,off), !,
2830 Head = attr_unify_hook(Attr,Other),
2831 get_target_module(Mod),
2832 make_attr(N,Mask,SuspsList,Attr),
2833 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2834 list2conj(SortGoalList,SortGoals),
2835 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2836 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2837 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2838 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2839 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2840 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2841 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2842 NonvarBody = true
2843 ;
2844 use_auxiliary_predicate(attach_increment),
2845 NonvarBody =
2846 ( compound(Other) ->
2847 term_variables(Other,OtherVars),
2848 attach_increment(OtherVars,SortedAttr)
2849 ;
2850 true
2851 )
2852 ),
2853 Body =
2854 (
2855 SortGoals,
2856 ( var(Other) ->
2857 ( get_attr(Other,Mod,TOtherAttr) ->
2858 MergeGoal,
2859 put_attr(Other,Mod,MergedAttr),
2860 WakeMergedSusps
2861 ;
2862 put_attr(Other,Mod,SortedAttr),
2863 WakeSortedSusps
2864 )
2865 ;
2866 NonvarBody,
2867 WakeSortedSusps
2868 )
2869 ),
2870 Clause = (Head :- Body).
2872 % NEW
2873 generate_attr_unify_hook_many(N,Clauses) :-
2874 Head = attr_unify_hook(Attr,Other),
2875 get_target_module(Mod),
2876 normalize_attr(Attr,NormalGoal,NormalAttr),
2877 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2878 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2879 make_run_suspensions(N),
2880 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2881 NonvarBody = true
2882 ;
2883 use_auxiliary_predicate(attach_increment),
2884 NonvarBody =
2885 ( compound(Other) ->
2886 term_variables(Other,OtherVars),
2887 attach_increment(OtherVars,NormalAttr)
2888 ;
2889 true
2890 )
2891 ),
2892 Body =
2893 (
2894 NormalGoal,
2895 ( var(Other) ->
2896 ( get_attr(Other,Mod,OtherAttr) ->
2897 NormalOtherGoal,
2898 MergeGoal,
2899 put_attr(Other,Mod,MergedAttr),
2900 '$dispatch_run_suspensions'(MergedAttr)
2901 ;
2902 put_attr(Other,Mod,NormalAttr),
2903 '$dispatch_run_suspensions'(NormalAttr)
2904 )
2905 ;
2906 NonvarBody,
2907 '$dispatch_run_suspensions'(NormalAttr)
2908 )
2909 ),
2910 Clause = (Head :- Body),
2911 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2912 DispatchList1 = ('$dispatch_run_suspensions'([])),
2913 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2914 run_suspensions_dispatchers(N,[],Dispatchers).
2916 % NEW
2917 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2918 ( N > 0 ->
2919 get_indexed_constraint(N,C),
2920 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2921 ( may_trigger(C) ->
2922 run_suspensions_goal(C,List,Body)
2923 ;
2924 Body = true
2925 ),
2926 M is N - 1,
2927 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2928 ;
2929 Dispatchers = Acc
2930 ).
2932 % NEW
2933 make_run_suspensions(N) :-
2934 ( N > 0 ->
2935 ( get_indexed_constraint(N,C),
2936 may_trigger(C) ->
2937 use_auxiliary_predicate(run_suspensions,C)
2938 ;
2939 true
2940 ),
2941 M is N - 1,
2942 make_run_suspensions(M)
2943 ;
2944 true
2945 ).
2947 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2948 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2950 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2951 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2952 use_auxiliary_predicate(run_suspensions,C),
2953 ( wakes_partially(C) ->
2954 run_suspensions_goal(C,OneSusps,Goal)
2955 ;
2956 run_suspensions_goal(C,AllSusps,Goal)
2957 )
2958 ;
2959 Goal = true
2960 ).
2962 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2963 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2965 make_run_suspensions_loop([],[],_,true).
2966 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2967 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2968 J is I + 1,
2969 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2971 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2972 % $insert_in_store_F/A
2973 % $delete_from_store_F/A
2975 generate_insert_delete_constraints([],[]).
2976 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2977 ( is_stored(FA) ->
2978 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2979 ;
2980 Clauses = RestClauses
2981 ),
2982 generate_insert_delete_constraints(Rest,RestClauses).
2984 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2985 insert_constraint_clause(FA,Clauses,RestClauses1),
2986 delete_constraint_clause(FA,RestClauses1,RestClauses).
2988 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2989 % insert_in_store
2991 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2992 ( chr_pp_flag(inline_insertremove,off) ->
2993 use_auxiliary_predicate(insert_in_store,FA),
2994 insert_constraint_atom(FA,Susp,Goal)
2995 ;
2996 delay_phase_end(validate_store_type_assumptions,
2997 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2998 insert_constraint_direct_used_vars(UsedVars,Vars)
2999 )
3000 )
3001 ).
3003 insert_constraint_direct_used_vars([],_).
3004 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
3005 nth1(Index,Vars,Var),
3006 insert_constraint_direct_used_vars(Rest,Vars).
3008 insert_constraint_atom(FA,Susp,Call) :-
3009 make_name('$insert_in_store_',FA,Functor),
3010 Call =.. [Functor,Susp].
3012 insert_constraint_clause(C,Clauses,RestClauses) :-
3013 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3014 Clauses = [Clause|RestClauses],
3015 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3016 insert_constraint_atom(C,Susp,Head),
3017 insert_constraint_body(C,Susp,UsedVars,Body),
3018 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3019 ( chr_pp_flag(store_counter,on) ->
3020 InsertCounterInc = '$insert_counter_inc'
3021 ;
3022 InsertCounterInc = true
3023 )
3024 ;
3025 Clauses = RestClauses
3026 ).
3028 insert_constraint_used_vars([],_,_,true).
3029 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3030 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3031 insert_constraint_used_vars(Rest,C,Susp,Goals).
3033 insert_constraint_body(C,Susp,UsedVars,Body) :-
3034 get_store_type(C,StoreType),
3035 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3037 insert_constraint_body(default,C,Susp,[],Body) :-
3038 global_list_store_name(C,StoreName),
3039 make_get_store_goal(StoreName,Store,GetStoreGoal),
3040 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3041 ( chr_pp_flag(debugable,on) ->
3042 Cell = [Susp|Store],
3043 Body =
3044 (
3045 GetStoreGoal,
3046 UpdateStoreGoal
3047 )
3048 ;
3049 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3050 Body =
3051 (
3052 GetStoreGoal,
3053 Cell = [Susp|Store],
3054 UpdateStoreGoal,
3055 ( Store = [NextSusp|_] ->
3056 SetGoal
3057 ;
3058 true
3059 )
3060 )
3061 ).
3062 % get_target_module(Mod),
3063 % get_max_constraint_index(Total),
3064 % ( Total == 1 ->
3065 % generate_attach_body_1(C,Store,Susp,AttachBody)
3066 % ;
3067 % generate_attach_body_n(C,Store,Susp,AttachBody)
3068 % ),
3069 % Body =
3070 % (
3071 % 'chr default_store'(Store),
3072 % AttachBody
3073 % ).
3074 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3075 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3076 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3077 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3078 sort_out_used_vars(MixedUsedVars,UsedVars).
3079 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3080 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3081 constants_store_index_name(C,Index,IndexName),
3082 IndexLookup =.. [IndexName,Key,StoreName],
3083 Body =
3084 ( IndexLookup ->
3085 nb_getval(StoreName,Store),
3086 b_setval(StoreName,[Susp|Store])
3087 ;
3088 true
3089 ).
3090 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3091 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3092 constants_store_index_name(C,Index,IndexName),
3093 IndexLookup =.. [IndexName,Key,StoreName],
3094 Body =
3095 ( IndexLookup ->
3096 nb_getval(StoreName,Store),
3097 b_setval(StoreName,[Susp|Store])
3098 ;
3099 true
3100 ).
3101 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3102 global_ground_store_name(C,StoreName),
3103 make_get_store_goal(StoreName,Store,GetStoreGoal),
3104 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3105 ( chr_pp_flag(debugable,on) ->
3106 Cell = [Susp|Store],
3107 Body =
3108 (
3109 GetStoreGoal,
3110 UpdateStoreGoal
3111 )
3112 ;
3113 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3114 Body =
3115 (
3116 GetStoreGoal,
3117 Cell = [Susp|Store],
3118 UpdateStoreGoal,
3119 ( Store = [NextSusp|_] ->
3120 SetGoal
3121 ;
3122 true
3123 )
3124 )
3125 ).
3126 % global_ground_store_name(C,StoreName),
3127 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3128 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3129 % Body =
3130 % (
3131 % GetStoreGoal, % nb_getval(StoreName,Store),
3132 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3133 % ).
3134 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3135 % TODO: generalize to more than one !!!
3136 get_target_module(Module),
3137 Body = ( get_attr(Variable,Module,AssocStore) ->
3138 insert_assoc_store(AssocStore,Key,Susp)
3139 ;
3140 new_assoc_store(AssocStore),
3141 put_attr(Variable,Module,AssocStore),
3142 insert_assoc_store(AssocStore,Key,Susp)
3143 ).
3145 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3146 global_singleton_store_name(C,StoreName),
3147 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3148 Body =
3149 (
3150 UpdateStoreGoal
3151 ).
3152 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3153 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3154 list2conj(Bodies,Body),
3155 sort_out_used_vars(NestedUsedVars,UsedVars).
3156 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3157 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3158 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3159 UsedVars = [Index-Var],
3160 get_identifier_size(ISize),
3161 functor(Struct,struct,ISize),
3162 get_identifier_index(C,Index,IIndex),
3163 arg(IIndex,Struct,Susps),
3164 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3165 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3166 UsedVars = [Index-Var],
3167 type_indexed_identifier_structure(IndexType,Struct),
3168 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3169 arg(IIndex,Struct,Susps),
3170 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3172 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3173 flatten(NestedUsedVars,FlatUsedVars),
3174 sort(FlatUsedVars,SortedFlatUsedVars),
3175 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3177 sort_out_used_vars1([],[]).
3178 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3179 sort_out_used_vars1([I-X,J-Y|R],L) :-
3180 ( I == J ->
3181 X = Y,
3182 sort_out_used_vars1([I-X|R],L)
3183 ;
3184 L = [I-X|T],
3185 sort_out_used_vars1([J-Y|R],T)
3186 ).
3188 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3189 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3190 multi_hash_store_name(FA,Index,StoreName),
3191 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3192 Body =
3193 (
3194 KeyBody,
3195 nb_getval(StoreName,Store),
3196 insert_iht(Store,Key,Susp)
3197 ),
3198 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3200 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3201 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3202 multi_hash_store_name(FA,Index,StoreName),
3203 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3204 make_get_store_goal(StoreName,Store,GetStoreGoal),
3205 ( chr_pp_flag(ht_removal,on)
3206 -> ht_prev_field(Index,PrevField),
3207 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3208 SetGoal),
3209 Body =
3210 (
3211 GetStoreGoal,
3212 insert_ht(Store,Key,Susp,Result),
3213 ( Result = [_,NextSusp|_]
3214 -> SetGoal
3215 ; true
3216 )
3217 )
3218 ; Body =
3219 (
3220 GetStoreGoal,
3221 insert_ht(Store,Key,Susp)
3222 )
3223 ),
3224 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3226 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3227 % Delete
3229 delete_constraint_clause(C,Clauses,RestClauses) :-
3230 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3231 Clauses = [Clause|RestClauses],
3232 Clause = (Head :- Body),
3233 delete_constraint_atom(C,Susp,Head),
3234 C = F/A,
3235 functor(Head,F,A),
3236 delete_constraint_body(C,Head,Susp,[],Body)
3237 ;
3238 Clauses = RestClauses
3239 ).
3241 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3242 functor(Head,F,A),
3243 C = F/A,
3244 ( chr_pp_flag(inline_insertremove,off) ->
3245 use_auxiliary_predicate(delete_from_store,C),
3246 delete_constraint_atom(C,Susp,Goal)
3247 ;
3248 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3249 ).
3251 delete_constraint_atom(C,Susp,Atom) :-
3252 make_name('$delete_from_store_',C,Functor),
3253 Atom =.. [Functor,Susp].
3256 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3257 Body = (CounterBody,DeleteBody),
3258 ( chr_pp_flag(store_counter,on) ->
3259 CounterBody = '$delete_counter_inc'
3260 ;
3261 CounterBody = true
3262 ),
3263 get_store_type(C,StoreType),
3264 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3266 delete_constraint_body(default,C,_,Susp,_,Body) :-
3267 ( chr_pp_flag(debugable,on) ->
3268 global_list_store_name(C,StoreName),
3269 make_get_store_goal(StoreName,Store,GetStoreGoal),
3270 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3271 Body =
3272 (
3273 GetStoreGoal, % nb_getval(StoreName,Store),
3274 'chr sbag_del_element'(Store,Susp,NStore),
3275 UpdateStoreGoal % b_setval(StoreName,NStore)
3276 )
3277 ;
3278 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3279 global_list_store_name(C,StoreName),
3280 make_get_store_goal(StoreName,Store,GetStoreGoal),
3281 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3282 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3283 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3284 Body =
3285 (
3286 GetGoal,
3287 ( var(PredCell) ->
3288 GetStoreGoal, % nb_getval(StoreName,Store),
3289 Store = [_|Tail],
3290 UpdateStoreGoal,
3291 ( Tail = [NextSusp|_] ->
3292 SetGoal1
3293 ;
3294 true
3295 )
3296 ;
3297 PredCell = [_,_|Tail],
3298 setarg(2,PredCell,Tail),
3299 ( Tail = [NextSusp|_] ->
3300 SetGoal2
3301 ;
3302 true
3303 )
3304 )
3305 )
3306 ).
3307 % get_target_module(Mod),
3308 % get_max_constraint_index(Total),
3309 % ( Total == 1 ->
3310 % generate_detach_body_1(C,Store,Susp,DetachBody),
3311 % Body =
3312 % (
3313 % 'chr default_store'(Store),
3314 % DetachBody
3315 % )
3316 % ;
3317 % generate_detach_body_n(C,Store,Susp,DetachBody),
3318 % Body =
3319 % (
3320 % 'chr default_store'(Store),
3321 % DetachBody
3322 % )
3323 % ).
3324 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3325 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3326 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3327 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3328 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3329 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3330 constants_store_index_name(C,Index,IndexName),
3331 IndexLookup =.. [IndexName,Key,StoreName],
3332 Body =
3333 ( KeyBody,
3334 ( IndexLookup ->
3335 nb_getval(StoreName,Store),
3336 'chr sbag_del_element'(Store,Susp,NStore),
3337 b_setval(StoreName,NStore)
3338 ;
3339 true
3340 )).
3341 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3342 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3343 constants_store_index_name(C,Index,IndexName),
3344 IndexLookup =.. [IndexName,Key,StoreName],
3345 Body =
3346 ( KeyBody,
3347 ( IndexLookup ->
3348 nb_getval(StoreName,Store),
3349 'chr sbag_del_element'(Store,Susp,NStore),
3350 b_setval(StoreName,NStore)
3351 ;
3352 true
3353 )).
3354 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3355 ( chr_pp_flag(debugable,on) ->
3356 global_ground_store_name(C,StoreName),
3357 make_get_store_goal(StoreName,Store,GetStoreGoal),
3358 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3359 Body =
3360 (
3361 GetStoreGoal, % nb_getval(StoreName,Store),
3362 'chr sbag_del_element'(Store,Susp,NStore),
3363 UpdateStoreGoal % b_setval(StoreName,NStore)
3364 )
3365 ;
3366 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3367 global_ground_store_name(C,StoreName),
3368 make_get_store_goal(StoreName,Store,GetStoreGoal),
3369 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3370 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3371 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3372 Body =
3373 (
3374 GetGoal,
3375 ( var(PredCell) ->
3376 GetStoreGoal, % nb_getval(StoreName,Store),
3377 Store = [_|Tail],
3378 UpdateStoreGoal,
3379 ( Tail = [NextSusp|_] ->
3380 SetGoal1
3381 ;
3382 true
3383 )
3384 ;
3385 PredCell = [_,_|Tail],
3386 setarg(2,PredCell,Tail),
3387 ( Tail = [NextSusp|_] ->
3388 SetGoal2
3389 ;
3390 true
3391 )
3392 )
3393 )
3394 ).
3395 % global_ground_store_name(C,StoreName),
3396 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3397 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3398 % Body =
3399 % (
3400 % GetStoreGoal, % nb_getval(StoreName,Store),
3401 % 'chr sbag_del_element'(Store,Susp,NStore),
3402 % UpdateStoreGoal % b_setval(StoreName,NStore)
3403 % ).
3404 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3405 get_target_module(Module),
3406 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3407 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3408 Body = (
3409 VariableGoal,
3410 get_attr(Variable,Module,AssocStore),
3411 KeyGoal,
3412 delete_assoc_store(AssocStore,Key,Susp)
3413 ).
3414 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3415 global_singleton_store_name(C,StoreName),
3416 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3417 Body =
3418 (
3419 UpdateStoreGoal % b_setval(StoreName,[])
3420 ).
3421 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3422 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3423 list2conj(Bodies,Body).
3424 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3425 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3426 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3427 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3428 get_identifier_size(ISize),
3429 functor(Struct,struct,ISize),
3430 get_identifier_index(C,Index,IIndex),
3431 arg(IIndex,Struct,Susps),
3432 Body = (
3433 VariableGoal,
3434 Variable = Struct,
3435 'chr sbag_del_element'(Susps,Susp,NSusps),
3436 setarg(IIndex,Variable,NSusps)
3437 ).
3438 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3439 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3440 type_indexed_identifier_structure(IndexType,Struct),
3441 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3442 arg(IIndex,Struct,Susps),
3443 Body = (
3444 VariableGoal,
3445 Variable = Struct,
3446 'chr sbag_del_element'(Susps,Susp,NSusps),
3447 setarg(IIndex,Variable,NSusps)
3448 ).
3450 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3451 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3452 multi_hash_store_name(FA,Index,StoreName),
3453 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3454 Body =
3455 (
3456 KeyBody,
3457 nb_getval(StoreName,Store),
3458 delete_iht(Store,Key,Susp)
3459 ),
3460 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3461 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3462 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3463 multi_hash_store_name(C,Index,StoreName),
3464 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3465 make_get_store_goal(StoreName,Store,GetStoreGoal),
3466 ( chr_pp_flag(ht_removal,on)
3467 -> ht_prev_field(Index,PrevField),
3468 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3469 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3470 SetGoal1),
3471 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3472 SetGoal2),
3473 Body =
3474 (
3475 GetGoal,
3476 ( var(Prev)
3477 -> GetStoreGoal,
3478 KeyBody,
3479 delete_first_ht(Store,Key,Values),
3480 ( Values = [NextSusp|_]
3481 -> SetGoal1
3482 ; true
3483 )
3484 ; Prev = [_,_|Values],
3485 setarg(2,Prev,Values),
3486 ( Values = [NextSusp|_]
3487 -> SetGoal2
3488 ; true
3489 )
3490 )
3491 )
3492 ; Body =
3493 (
3494 KeyBody,
3495 GetStoreGoal, % nb_getval(StoreName,Store),
3496 delete_ht(Store,Key,Susp)
3497 )
3498 ),
3499 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3501 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3503 :- chr_constraint
3504 module_initializer/1,
3505 module_initializers/1.
3507 module_initializers(G), module_initializer(Initializer) <=>
3508 G = (Initializer,Initializers),
3509 module_initializers(Initializers).
3511 module_initializers(G) <=>
3512 G = true.
3514 generate_attach_code(Constraints,Clauses) :-
3515 enumerate_stores_code(Constraints,Enumerate),
3516 append(Enumerate,L,Clauses),
3517 generate_attach_code(Constraints,L,T),
3518 module_initializers(Initializers),
3519 prolog_global_variables_code(PrologGlobalVariables),
3520 % Do not rename or the 'chr_initialization' predicate
3521 % without warning SSS
3522 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3524 generate_attach_code([],L,L).
3525 generate_attach_code([C|Cs],L,T) :-
3526 get_store_type(C,StoreType),
3527 generate_attach_code(StoreType,C,L,L1),
3528 generate_attach_code(Cs,L1,T).
3530 generate_attach_code(default,C,L,T) :-
3531 global_list_store_initialisation(C,L,T).
3532 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3533 multi_inthash_store_initialisations(Indexes,C,L,L1),
3534 multi_inthash_via_lookups(Indexes,C,L1,T).
3535 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3536 multi_hash_store_initialisations(Indexes,C,L,L1),
3537 multi_hash_lookups(Indexes,C,L1,T).
3538 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3539 constants_initializers(C,Index,Constants),
3540 atomic_constants_code(C,Index,Constants,L,T).
3541 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3542 constants_initializers(C,Index,Constants),
3543 ground_constants_code(C,Index,Constants,L,T).
3544 generate_attach_code(global_ground,C,L,T) :-
3545 global_ground_store_initialisation(C,L,T).
3546 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3547 use_auxiliary_module(chr_assoc_store).
3548 generate_attach_code(global_singleton,C,L,T) :-
3549 global_singleton_store_initialisation(C,L,T).
3550 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3551 multi_store_generate_attach_code(StoreTypes,C,L,T).
3552 generate_attach_code(identifier_store(Index),C,L,T) :-
3553 get_identifier_index(C,Index,IIndex),
3554 ( IIndex == 2 ->
3555 get_identifier_size(ISize),
3556 functor(Struct,struct,ISize),
3557 Struct =.. [_,Label|Stores],
3558 set_elems(Stores,[]),
3559 Clause1 = new_identifier(Label,Struct),
3560 functor(Struct2,struct,ISize),
3561 arg(1,Struct2,Label2),
3562 Clause2 =
3563 ( user:portray(Struct2) :-
3564 write('<id:'),
3565 print(Label2),
3566 write('>')
3567 ),
3568 functor(Struct3,struct,ISize),
3569 arg(1,Struct3,Label3),
3570 Clause3 = identifier_label(Struct3,Label3),
3571 L = [Clause1,Clause2,Clause3|T]
3572 ;
3573 L = T
3574 ).
3575 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3576 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3577 ( IIndex == 2 ->
3578 identifier_store_initialization(IndexType,L,L1),
3579 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3581 get_type_indexed_identifier_size(IndexType,ISize),
3582 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3583 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3584 type_indexed_identifier_structure(IndexType,Struct),
3585 Struct =.. [_,Label|Stores],
3586 set_elems(Stores,[]),
3587 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3588 Clause1 =.. [Name1,Label,Struct],
3589 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3590 Goal1 =.. [Name1,Label1b,S1b],
3591 type_indexed_identifier_structure(IndexType,Struct1b),
3592 Struct1b =.. [_,Label1b|Stores1b],
3593 set_elems(Stores1b,[]),
3594 Expansion1 = (S1b = Struct1b),
3595 Clause1b = user:goal_expansion(Goal1,Expansion1),
3596 % writeln(Clause1-Clause1b),
3597 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3598 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3599 type_indexed_identifier_structure(IndexType,Struct2),
3600 arg(1,Struct2,Label2),
3601 Clause2 =
3602 ( user:portray(Struct2) :-
3603 write('<id:'),
3604 print(Label2),
3605 write('>')
3606 ),
3607 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3608 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3609 type_indexed_identifier_structure(IndexType,Struct3),
3610 arg(1,Struct3,Label3),
3611 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3612 Clause3 =.. [Name3,Struct3,Label3],
3613 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3614 Goal3b =.. [Name3,S3b,L3b],
3615 type_indexed_identifier_structure(IndexType,Struct3b),
3616 arg(1,Struct3b,L3b),
3617 Expansion3b = (S3 = Struct3b),
3618 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3619 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3620 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3621 identifier_store_name(IndexType,GlobalVariable),
3622 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3623 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3624 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3625 Clause4 =
3626 ( LookupAtom :-
3627 nb_getval(GlobalVariable,HT),
3628 ( lookup_ht(HT,X,[IX]) ->
3629 true
3630 ;
3631 NewIdentifierGoal,
3632 insert_ht(HT,X,IX)
3633 )
3634 ),
3635 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3636 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3637 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3638 ;
3639 L = T
3640 ).
3642 constants_initializers(C,Index,Constants) :-
3643 maplist(constant_initializer(C,Index),Constants).
3645 constant_initializer(C,Index,Constant) :-
3646 constants_store_name(C,Index,Constant,StoreName),
3647 prolog_global_variable(StoreName),
3648 module_initializer(nb_setval(StoreName,[])).
3650 lookup_identifier_atom(Key,X,IX,Atom) :-
3651 atom_concat('lookup_identifier_',Key,LookupFunctor),
3652 Atom =.. [LookupFunctor,X,IX].
3654 identifier_label_atom(IndexType,IX,X,Atom) :-
3655 type_indexed_identifier_name(IndexType,identifier_label,Name),
3656 Atom =.. [Name,IX,X].
3658 multi_store_generate_attach_code([],_,L,L).
3659 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3660 generate_attach_code(ST,C,L,L1),
3661 multi_store_generate_attach_code(STs,C,L1,T).
3663 multi_inthash_store_initialisations([],_,L,L).
3664 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3665 use_auxiliary_module(chr_integertable_store),
3666 multi_hash_store_name(FA,Index,StoreName),
3667 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3668 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3669 L1 = L,
3670 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3671 multi_hash_store_initialisations([],_,L,L).
3672 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3673 use_auxiliary_module(chr_hashtable_store),
3674 multi_hash_store_name(FA,Index,StoreName),
3675 prolog_global_variable(StoreName),
3676 make_init_store_goal(StoreName,HT,InitStoreGoal),
3677 module_initializer((new_ht(HT),InitStoreGoal)),
3678 L1 = L,
3679 multi_hash_store_initialisations(Indexes,FA,L1,T).
3681 global_list_store_initialisation(C,L,T) :-
3682 ( is_stored(C) ->
3683 global_list_store_name(C,StoreName),
3684 prolog_global_variable(StoreName),
3685 make_init_store_goal(StoreName,[],InitStoreGoal),
3686 module_initializer(InitStoreGoal)
3687 ;
3688 true
3689 ),
3690 L = T.
3691 global_ground_store_initialisation(C,L,T) :-
3692 global_ground_store_name(C,StoreName),
3693 prolog_global_variable(StoreName),
3694 make_init_store_goal(StoreName,[],InitStoreGoal),
3695 module_initializer(InitStoreGoal),
3696 L = T.
3697 global_singleton_store_initialisation(C,L,T) :-
3698 global_singleton_store_name(C,StoreName),
3699 prolog_global_variable(StoreName),
3700 make_init_store_goal(StoreName,[],InitStoreGoal),
3701 module_initializer(InitStoreGoal),
3702 L = T.
3703 identifier_store_initialization(IndexType,L,T) :-
3704 use_auxiliary_module(chr_hashtable_store),
3705 identifier_store_name(IndexType,StoreName),
3706 prolog_global_variable(StoreName),
3707 make_init_store_goal(StoreName,HT,InitStoreGoal),
3708 module_initializer((new_ht(HT),InitStoreGoal)),
3709 L = T.
3712 multi_inthash_via_lookups([],_,L,L).
3713 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3714 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3715 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3716 L = [(Head :- Body)|L1],
3717 multi_inthash_via_lookups(Indexes,C,L1,T).
3718 multi_hash_lookups([],_,L,L).
3719 multi_hash_lookups([Index|Indexes],C,L,T) :-
3720 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3721 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3722 L = [(Head :- Body)|L1],
3723 multi_hash_lookups(Indexes,C,L1,T).
3725 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3726 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3727 Head =.. [Name,Key,SuspsList].
3729 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3730 %
3731 % Returns goal that performs hash table lookup.
3732 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3733 % INLINED:
3734 get_store_type(ConstraintSymbol,multi_store(Stores)),
3735 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3736 ( ground(Key) ->
3737 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3738 Goal = nb_getval(StoreName,SuspsList)
3739 ;
3740 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3741 Lookup =.. [IndexName,Key,StoreName],
3742 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3743 )
3744 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3745 ( ground(Key) ->
3746 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3747 Goal = nb_getval(StoreName,SuspsList)
3748 ;
3749 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3750 Lookup =.. [IndexName,Key,StoreName],
3751 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3752 )
3753 ; memberchk(multi_hash([Index]),Stores) ->
3754 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3755 make_get_store_goal(StoreName,HT,GetStoreGoal),
3756 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3757 Goal =
3758 (
3759 GetStoreGoal, % nb_getval(StoreName,HT),
3760 HashCall, % hash_term(Key,Hash),
3761 lookup_ht1(HT,Hash,Key,SuspsList)
3762 )
3763 ;
3764 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3765 Goal =
3766 (
3767 GetStoreGoal, % nb_getval(StoreName,HT),
3768 Lookup
3769 )
3770 )
3771 ; HashType == inthash ->
3772 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3773 make_get_store_goal(StoreName,HT,GetStoreGoal),
3774 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3775 Goal =
3776 (
3777 GetStoreGoal, % nb_getval(StoreName,HT),
3778 Lookup
3779 )
3780 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3781 % find alternative index
3782 % -> SubIndex + RestIndex
3783 % -> SubKey + RestKeys
3784 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3785 % instantiate rest goal?
3786 % Goal = (SubGoal,RestGoal)
3787 ).
3790 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3791 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3793 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3794 ( ground(Key) ->
3795 % This is based on a property of SWI-Prolog's
3796 % hash_term/2 predicate:
3797 % the hash value is stable over repeated invocations
3798 % of SWI-Prolog
3799 hash_term(Key,Hash),
3800 Call = true
3801 % ; Index = [IndexPos],
3802 % get_constraint_type(Constraint,ArgTypes),
3803 % nth1(IndexPos,ArgTypes,Type),
3804 % unalias_type(Type,NormalType),
3805 % memberchk_eq(NormalType,[int,natural]) ->
3806 % ( NormalType == int ->
3807 % Call = (Hash is abs(Key))
3808 % ;
3809 % Hash = Key,
3810 % Call = true
3811 % )
3812 % ;
3813 % nonvar(Key),
3814 % specialize_hash_term(Key,NewKey),
3815 % NewKey \== Key,
3816 % Call = hash_term(NewKey,Hash)
3817 ).
3819 % specialize_hash_term(Term,NewTerm) :-
3820 % ( ground(Term) ->
3821 % hash_term(Term,NewTerm)
3822 % ; var(Term) ->
3823 % NewTerm = Term
3824 % ;
3825 % Term =.. [F|Args],
3826 % maplist(specialize_hash_term,Args,NewArgs),
3827 % NewTerm =.. [F|NewArgs]
3828 % ).
3830 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3831 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3832 ( /* chr_pp_flag(experiment,off) ->
3833 true
3834 ; */ atomic(Key) ->
3835 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3836 ; ground(Key) ->
3837 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3838 ;
3839 ( Index = [Pos],
3840 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3841 is_chr_constants_type(Type,_,_)
3842 ->
3843 true
3844 ;
3845 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3846 )
3847 ),
3848 delay_phase_end(validate_store_type_assumptions,
3849 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3851 :- chr_constraint actual_atomic_multi_hash_keys/3.
3852 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3854 :- chr_constraint actual_ground_multi_hash_keys/3.
3855 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3857 :- chr_constraint actual_non_ground_multi_hash_key/2.
3858 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3860 /*
3861 actual_atomic_multi_hash_keys(C,Index,Keys)
3862 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3864 actual_ground_multi_hash_keys(C,Index,Keys)
3865 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3867 actual_non_ground_multi_hash_key(C,Index)
3868 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3869 */
3870 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3871 <=> append(Keys1,Keys2,Keys0),
3872 sort(Keys0,Keys),
3873 actual_atomic_multi_hash_keys(C,Index,Keys).
3875 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3876 <=> append(Keys1,Keys2,Keys0),
3877 sort(Keys0,Keys),
3878 actual_ground_multi_hash_keys(C,Index,Keys).
3880 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3881 <=> append(Keys1,Keys2,Keys0),
3882 sort(Keys0,Keys),
3883 actual_ground_multi_hash_keys(C,Index,Keys).
3885 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3886 <=> true.
3888 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3889 <=> true.
3891 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3892 <=> true.
3894 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3895 %
3896 % Returns predicate name of hash table lookup predicate.
3897 multi_hash_lookup_name(F/A,Index,Name) :-
3898 atom_concat_list(Index,IndexName),
3899 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3901 multi_hash_store_name(F/A,Index,Name) :-
3902 get_target_module(Mod),
3903 atom_concat_list(Index,IndexName),
3904 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3906 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3907 ( Index = [I] ->
3908 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3909 ;
3910 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
3911 Key =.. [k|Keys],
3912 list2conj(Bodies,KeyBody)
3913 ).
3915 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3916 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3918 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3919 ( Index = [I] ->
3920 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3921 ;
3922 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
3923 Key =.. [k|Keys],
3924 list2conj(Bodies,KeyBody)
3925 ).
3927 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3928 arg(Index,Head,OriginalArg),
3929 ( term_variables(OriginalArg,OriginalVars),
3930 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
3931 translate(OriginalVars,VarDict,Vars) ->
3932 Goal = true
3933 ;
3934 functor(Head,F,A),
3935 C = F/A,
3936 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3937 ).
3939 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3940 ( Index = [I] ->
3941 UsedVars = [I-Key]
3942 ;
3943 pairup(Index,Keys,UsedVars),
3944 Key =.. [k|Keys]
3945 ).
3947 args(Index,Head,KeyArgs) :-
3948 maplist(arg1(Head),Index,KeyArgs).
3950 split_args(Indexes,Args,IArgs,NIArgs) :-
3951 split_args(Indexes,Args,1,IArgs,NIArgs).
3953 split_args([],Args,_,[],Args).
3954 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
3955 NJ is J + 1,
3956 ( I == J ->
3957 IArgs = [Arg|Rest],
3958 split_args(Is,Args,NJ,Rest,NIArgs)
3959 ;
3960 NIArgs = [Arg|Rest],
3961 split_args([I|Is],Args,NJ,IArgs,Rest)
3962 ).
3965 %-------------------------------------------------------------------------------
3966 atomic_constants_code(C,Index,Constants,L,T) :-
3967 constants_store_index_name(C,Index,IndexName),
3968 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3969 append(Clauses,T,L).
3971 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3972 constants_store_name(C,Index,Constant,StoreName),
3973 Clause =.. [IndexName,Constant,StoreName].
3975 %-------------------------------------------------------------------------------
3976 ground_constants_code(C,Index,Terms,L,T) :-
3977 constants_store_index_name(C,Index,IndexName),
3978 maplist(constants_store_name(C,Index),Terms,StoreNames),
3979 length(Terms,N),
3980 replicate(N,[],More),
3981 trie_index([Terms|More],StoreNames,IndexName,L,T).
3983 constants_store_name(F/A,Index,Term,Name) :-
3984 get_target_module(Mod),
3985 term_to_atom(Term,Constant),
3986 term_to_atom(Index,IndexAtom),
3987 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3989 constants_store_index_name(F/A,Index,Name) :-
3990 get_target_module(Mod),
3991 term_to_atom(Index,IndexAtom),
3992 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3994 % trie index code {{{
3995 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3996 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3998 trie_step([],_,_,[],[],L,L) :- !.
3999 % length MorePatterns == length Patterns == length Results
4000 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
4001 MorePatterns = [List|_],
4002 length(List,N),
4003 aggregate_all(set(F/A),
4004 ( member(Pattern,Patterns),
4005 functor(Pattern,F,A)
4006 ),
4007 FAs),
4008 N1 is N + 1,
4009 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4011 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4012 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4013 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4014 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4016 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4017 Clause = (Head :- Body),
4018 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4019 N1 is N + 1,
4020 functor(Head,Symbol,N1),
4021 arg(1,Head,IndexPattern),
4022 Head =.. [_,_|RestArgs],
4023 once(append(Vs,[Result],RestArgs)),
4024 /* IndexPattern = F() */
4025 functor(IndexPattern,F,A),
4026 IndexPattern =.. [_|Args],
4027 append(Args,RestArgs,RecArgs),
4028 ( RecArgs == [Result] ->
4029 /* nothing more to match on */
4030 List = Tail,
4031 Body = true,
4032 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4033 MoreResults = [Result]
4034 ; /* more things to match on */
4035 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4036 ( MoreCases = [OneMoreCase] ->
4037 /* only one more thing to match on */
4038 List = Tail,
4039 Body = true,
4040 append([Cases,OneMoreCase,MoreResults],RecArgs)
4041 ;
4042 /* more than one thing to match on */
4043 /* [ x1,..., xn]
4044 [xs1,...,xsn]
4045 */
4046 pairup(Cases,MoreCases,CasePairs),
4047 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4048 append(Args,Vs,[First|Rest]),
4049 First-Rest = CommonPatternPair,
4050 % Body = RSymbol(DiffVars,Result)
4051 gensym(Prefix,RSymbol),
4052 append(DiffVars,[Result],RecCallVars),
4053 Body =.. [RSymbol|RecCallVars],
4054 maplist(head_tail,Differences,CHs,CTs),
4055 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4056 )
4057 ).
4059 head_tail([H|T],H,T).
4061 rec_cases([],[],[],_,[],[],[]).
4062 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4063 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4064 Cases = [Case|NCases],
4065 MoreCases = [MoreCase|NMoreCases],
4066 MoreResults = [Result|NMoreResults],
4067 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4068 ;
4069 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4070 ).
4071 % }}}
4073 %% common_pattern(+terms,-term,-vars,-differences) is det.
4074 common_pattern(Ts,T,Vars,Differences) :-
4075 fold1(gct,Ts,T),
4076 term_variables(T,Vars),
4077 findall(Vars,member(T,Ts),Differences).
4079 gct(T1,T2,T) :-
4080 gct_(T1,T2,T,[],_).
4082 gct_(T1,T2,T,Dict0,Dict) :-
4083 ( nonvar(T1),
4084 nonvar(T2),
4085 functor(T1,F1,A1),
4086 functor(T2,F2,A2),
4087 F1 == F2,
4088 A1 == A2 ->
4089 functor(T,F1,A1),
4090 T1 =.. [_|Args1],
4091 T2 =.. [_|Args2],
4092 T =.. [_|Args],
4093 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4094 ;
4095 /* T is a variable */
4096 ( lookup_eq(Dict0,T1+T2,T) ->
4097 /* we already have a variable for this difference */
4098 Dict = Dict0
4099 ;
4100 /* T is a fresh variable */
4101 Dict = [(T1+T2)-T|Dict0]
4102 )
4103 ).
4106 fold1(P,[Head|Tail],Result) :-
4107 fold(Tail,P,Head,Result).
4109 fold([],_,Acc,Acc).
4110 fold([X|Xs],P,Acc,Res) :-
4111 call(P,X,Acc,NAcc),
4112 fold(Xs,P,NAcc,Res).
4114 maplist_dcg(P,L1,L2,L) -->
4115 maplist_dcg_(L1,L2,L,P).
4117 maplist_dcg_([],[],[],_) --> [].
4118 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4119 call(P,X,Y,Z),
4120 maplist_dcg_(Xs,Ys,Zs,P).
4122 %-------------------------------------------------------------------------------
4123 global_list_store_name(F/A,Name) :-
4124 get_target_module(Mod),
4125 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4126 global_ground_store_name(F/A,Name) :-
4127 get_target_module(Mod),
4128 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4129 global_singleton_store_name(F/A,Name) :-
4130 get_target_module(Mod),
4131 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4133 identifier_store_name(TypeName,Name) :-
4134 get_target_module(Mod),
4135 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4137 :- chr_constraint prolog_global_variable/1.
4138 :- chr_option(mode,prolog_global_variable(+)).
4140 :- chr_constraint prolog_global_variables/1.
4141 :- chr_option(mode,prolog_global_variables(-)).
4143 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4145 prolog_global_variables(List), prolog_global_variable(Name) <=>
4146 List = [Name|Tail],
4147 prolog_global_variables(Tail).
4148 prolog_global_variables(List) <=> List = [].
4150 %% SWI begin
4151 prolog_global_variables_code(Code) :-
4152 prolog_global_variables(Names),
4153 ( Names == [] ->
4154 Code = []
4155 ;
4156 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4157 Code = [(:- dynamic user:exception/3),
4158 (:- multifile user:exception/3),
4159 (user:exception(undefined_global_variable,Name,retry) :-
4160 (
4161 '$chr_prolog_global_variable'(Name),
4162 '$chr_initialization'
4163 )
4164 )
4165 |
4166 NameDeclarations
4167 ]
4168 ).
4169 %% SWI end
4170 %% SICStus begin
4171 % prolog_global_variables_code([]).
4172 %% SICStus end
4173 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4174 %sbag_member_call(S,L,sysh:mem(S,L)).
4175 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4176 %sbag_member_call(S,L,member(S,L)).
4177 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4178 %update_mutable_call(A,B,setarg(1, B, A)).
4179 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4180 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4182 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4183 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4184 % create_get_mutable(Value,Field,Get1).
4185 %
4186 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4187 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4188 % update_mutable_call(NewValue,Field,Set).
4189 %
4190 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4191 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4192 % create_get_mutable_ref(Value,Field,Get1),
4193 % update_mutable_call(NewValue,Field,Set).
4194 %
4195 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4196 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4197 % create_mutable_call(Value,Field,Create).
4198 %
4199 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4200 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4201 % create_get_mutable(Value,Field,Get).
4202 %
4203 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4204 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4205 % create_get_mutable_ref(Value,Field,Get),
4206 % update_mutable_call(NewValue,Field,Set).
4208 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4209 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4211 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4212 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4214 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4215 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4216 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4218 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4219 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4221 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4222 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4224 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4225 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4226 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4228 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4230 enumerate_stores_code(Constraints,[Clause|List]) :-
4231 Head = '$enumerate_constraints'(Constraint),
4232 Clause = ( Head :- Body),
4233 enumerate_store_bodies(Constraints,Constraint,List),
4234 ( List = [] ->
4235 Body = fail
4236 ;
4237 Body = ( nonvar(Constraint) ->
4238 functor(Constraint,Functor,_),
4239 '$enumerate_constraints'(Functor,Constraint)
4240 ;
4241 '$enumerate_constraints'(_,Constraint)
4242 )
4243 ).
4245 enumerate_store_bodies([],_,[]).
4246 enumerate_store_bodies([C|Cs],Constraint,L) :-
4247 ( is_stored(C) ->
4248 get_store_type(C,StoreType),
4249 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4250 true
4251 ;
4252 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4253 ),
4254 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4255 C = F/_,
4256 Constraint0 =.. [F|Arguments],
4257 Head = '$enumerate_constraints'(F,Constraint),
4258 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4259 L = [(Head :- Body)|T]
4260 ;
4261 L = T
4262 ),
4263 enumerate_store_bodies(Cs,Constraint,T).
4265 enumerate_store_body(default,C,Susp,Body) :-
4266 global_list_store_name(C,StoreName),
4267 sbag_member_call(Susp,List,Sbag),
4268 make_get_store_goal(StoreName,List,GetStoreGoal),
4269 Body =
4270 (
4271 GetStoreGoal, % nb_getval(StoreName,List),
4272 Sbag
4273 ).
4274 % get_constraint_index(C,Index),
4275 % get_target_module(Mod),
4276 % get_max_constraint_index(MaxIndex),
4277 % Body1 =
4278 % (
4279 % 'chr default_store'(GlobalStore),
4280 % get_attr(GlobalStore,Mod,Attr)
4281 % ),
4282 % ( MaxIndex > 1 ->
4283 % NIndex is Index + 1,
4284 % sbag_member_call(Susp,List,Sbag),
4285 % Body2 =
4286 % (
4287 % arg(NIndex,Attr,List),
4288 % Sbag
4289 % )
4290 % ;
4291 % sbag_member_call(Susp,Attr,Sbag),
4292 % Body2 = Sbag
4293 % ),
4294 % Body = (Body1,Body2).
4295 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4296 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4297 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4298 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4299 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4300 Completeness == complete, % fail if incomplete
4301 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4302 list2disj(Disjuncts, Disjunction),
4303 Body = ( Disjunction, member(Susp,Susps) ).
4304 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4305 constants_store_name(C,Index,Constant,StoreName).
4307 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4308 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4309 enumerate_store_body(global_ground,C,Susp,Body) :-
4310 global_ground_store_name(C,StoreName),
4311 sbag_member_call(Susp,List,Sbag),
4312 make_get_store_goal(StoreName,List,GetStoreGoal),
4313 Body =
4314 (
4315 GetStoreGoal, % nb_getval(StoreName,List),
4316 Sbag
4317 ).
4318 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4319 Body = fail.
4320 enumerate_store_body(global_singleton,C,Susp,Body) :-
4321 global_singleton_store_name(C,StoreName),
4322 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4323 Body =
4324 (
4325 GetStoreGoal, % nb_getval(StoreName,Susp),
4326 Susp \== []
4327 ).
4328 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4329 ( memberchk(global_ground,STs) ->
4330 enumerate_store_body(global_ground,C,Susp,Body)
4331 ;
4332 once((
4333 member(ST,STs),
4334 enumerate_store_body(ST,C,Susp,Body)
4335 ))
4336 ).
4337 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4338 Body = fail.
4339 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4340 Body = fail.
4342 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4343 multi_hash_store_name(C,I,StoreName),
4344 B =
4345 (
4346 nb_getval(StoreName,HT),
4347 value_iht(HT,Susp)
4348 ).
4349 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4350 multi_hash_store_name(C,I,StoreName),
4351 make_get_store_goal(StoreName,HT,GetStoreGoal),
4352 B =
4353 (
4354 GetStoreGoal, % nb_getval(StoreName,HT),
4355 value_ht(HT,Susp)
4356 ).
4358 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4359 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4360 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4362 :- chr_constraint
4363 background_info/1,
4364 background_info/2,
4365 get_bg_info/1,
4366 get_bg_info/2,
4367 get_bg_info_answer/1.
4369 background_info(X), background_info(Y) <=>
4370 append(X,Y,XY), background_info(XY).
4371 background_info(X) \ get_bg_info(Q) <=> Q=X.
4372 get_bg_info(Q) <=> Q = [].
4374 background_info(T,I), get_bg_info(A,Q) ==>
4375 copy_term_nat(T,T1),
4376 subsumes_chk(T1,A)
4377 |
4378 copy_term_nat(T-I,A-X),
4379 get_bg_info_answer([X]).
4380 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4381 append(X,Y,XY), get_bg_info_answer(XY).
4383 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4384 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4386 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4389 :- chr_constraint
4390 prev_guard_list/8,
4391 prev_guard_list/6,
4392 simplify_guards/1,
4393 set_all_passive/1.
4395 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4396 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4397 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4398 :- chr_option(mode,simplify_guards(+)).
4399 :- chr_option(mode,set_all_passive(+)).
4401 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4402 % GUARD SIMPLIFICATION
4403 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4404 % If the negation of the guards of earlier rules entails (part of)
4405 % the current guard, the current guard can be simplified. We can only
4406 % use earlier rules with a head that matches if the head of the current
4407 % rule does, and which make it impossible for the current rule to match
4408 % if they fire (i.e. they shouldn't be propagation rules and their
4409 % head constraints must be subsets of those of the current rule).
4410 % At this point, we know for sure that the negation of the guard
4411 % of such a rule has to be true (otherwise the earlier rule would have
4412 % fired, because of the refined operational semantics), so we can use
4413 % that information to simplify the guard by replacing all entailed
4414 % conditions by true/0. As a consequence, the never-stored analysis
4415 % (in a further phase) will detect more cases of never-stored constraints.
4416 %
4417 % e.g. c(X),d(Y) <=> X > 0 | ...
4418 % e(X) <=> X < 0 | ...
4419 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4420 % \____________/
4421 % true
4423 guard_simplification :-
4424 ( chr_pp_flag(guard_simplification,on) ->
4425 precompute_head_matchings,
4426 simplify_guards(1)
4427 ;
4428 true
4429 ).
4431 % for every rule, we create a prev_guard_list where the last argument
4432 % eventually is a list of the negations of earlier guards
4433 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4434 <=>
4435 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4436 append(Head1,Head2,Heads),
4437 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4438 tree_set_empty(Done),
4439 multiple_occ_constraints_checked(Done),
4440 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4442 append(IDs1,IDs2,IDs),
4443 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4444 empty_q(EmptyHeap),
4445 insert_list_q(HeapData,EmptyHeap,Heap),
4446 next_prev_rule(Heap,_,Heap1),
4447 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4448 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4449 NextRule is RuleNb+1,
4450 simplify_guards(NextRule).
4452 next_prev_rule(Heap,RuleNb,NHeap) :-
4453 ( find_min_q(Heap,_-Priority) ->
4454 Priority = (-RuleNb),
4455 normalize_heap(Heap,Priority,NHeap)
4456 ;
4457 RuleNb = 0,
4458 NHeap = Heap
4459 ).
4461 normalize_heap(Heap,Priority,NHeap) :-
4462 ( find_min_q(Heap,_-Priority) ->
4463 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4464 ( O > 1 ->
4465 NO is O -1,
4466 get_occurrence(C,NO,RuleNb,_),
4467 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4468 ;
4469 Heap2 = Heap1
4470 ),
4471 normalize_heap(Heap2,Priority,NHeap)
4472 ;
4473 NHeap = Heap
4474 ).
4476 % no more rule
4477 simplify_guards(_)
4478 <=>
4479 true.
4481 % The negation of the guard of a non-propagation rule is added
4482 % if its kept head constraints are a subset of the kept constraints of
4483 % the rule we're working on, and its removed head constraints (at least one)
4484 % are a subset of the removed constraints.
4486 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4487 <=>
4488 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4489 H1 \== [],
4490 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4491 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4492 |
4493 append(H1,H2,Heads),
4494 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4495 append(GuardList,DerivedInfo,GL1),
4496 normalize_conj_list(GL1,GL),
4497 append(GH_New1,GH,GH1),
4498 normalize_conj_list(GH1,GH_New),
4499 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4500 % PrevPrevRuleNb is PrevRuleNb-1,
4501 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4503 % if this isn't the case, we skip this one and try the next rule
4504 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4505 <=>
4506 ( N > 0 ->
4507 next_prev_rule(Heap,N1,NHeap),
4508 % N1 is N-1,
4509 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4510 ;
4511 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4512 ).
4514 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4515 <=>
4516 GH \== []
4517 |
4518 head_types_modes_condition(GH,H,TypeInfo),
4519 conj2list(TypeInfo,TI),
4520 term_variables(H,HeadVars),
4521 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4522 normalize_conj_list(Info,InfoL),
4523 append(H,InfoL,RelevantTerms),
4524 add_background_info([G|RelevantTerms],BGInfo),
4525 append(InfoL,BGInfo,AllInfo_),
4526 normalize_conj_list(AllInfo_,AllInfo),
4527 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4529 head_types_modes_condition([],H,true).
4530 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4531 types_modes_condition(H,GH,TI1),
4532 head_types_modes_condition(GHs,H,TI2).
4534 add_background_info(Term,Info) :-
4535 get_bg_info(GeneralInfo),
4536 add_background_info2(Term,TermInfo),
4537 append(GeneralInfo,TermInfo,Info).
4539 add_background_info2(X,[]) :- var(X), !.
4540 add_background_info2([],[]) :- !.
4541 add_background_info2([X|Xs],Info) :- !,
4542 add_background_info2(X,Info1),
4543 add_background_info2(Xs,Infos),
4544 append(Info1,Infos,Info).
4546 add_background_info2(X,Info) :-
4547 (functor(X,_,A), A>0 ->
4548 X =.. [_|XArgs],
4549 add_background_info2(XArgs,XArgInfo)
4550 ;
4551 XArgInfo = []
4552 ),
4553 get_bg_info(X,XInfo),
4554 append(XInfo,XArgInfo,Info).
4556 %%
4557 % when all earlier guards are added or skipped, we simplify the guard.
4558 % if it's different from the original one, we change the rule
4560 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4561 <=>
4562 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4563 G \== true, % let's not try to simplify this ;)
4564 append(M,GuardList,Info),
4565 (% if guard + context is a contradiction, it should be simplified to "fail"
4566 conj2list(G,GL), append(Info,GL,GuardWithContext),
4567 guard_entailment:entails_guard(GuardWithContext,fail) ->
4568 SimpleGuard = fail
4569 ;
4570 % otherwise we try to remove redundant conjuncts
4571 simplify_guard(G,B,Info,SimpleGuard,NB)
4572 ),
4573 G \== SimpleGuard % only do this if we can change the guard
4574 |
4575 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4576 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4578 %% normalize_conj_list(+List,-NormalList) is det.
4579 %
4580 % Removes =true= elements and flattens out conjunctions.
4582 normalize_conj_list(List,NormalList) :-
4583 list2conj(List,Conj),
4584 conj2list(Conj,NormalList).
4586 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4587 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4588 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4590 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4591 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4592 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4593 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4594 append(Renaming1,ExtraRenaming,Renaming2),
4595 list2conj(PrevMatchings,Match),
4596 negate_b(Match,HeadsDontMatch),
4597 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4598 list2conj(HeadsMatch,HeadsMatchBut),
4599 term_variables(Renaming2,RenVars),
4600 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4601 new_vars(MGVars,RenVars,ExtraRenaming2),
4602 append(Renaming2,ExtraRenaming2,Renaming),
4603 ( PrevGuard == true -> % true can't fail
4604 Info_ = HeadsDontMatch
4605 ;
4606 negate_b(PrevGuard,TheGuardFailed),
4607 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4608 ),
4609 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4610 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4611 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4612 list2conj(RenamedMatchings_,RenamedMatchings),
4613 apply_guard_wrt_term(H,RenamedG2,GH2),
4614 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4615 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4617 simplify_guard(G,B,Info,SG,NB) :-
4618 conj2list(G,LG),
4619 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4620 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4621 list2conj(SGL,SG).
4624 new_vars([],_,[]).
4625 new_vars([A|As],RV,ER) :-
4626 ( memberchk_eq(A,RV) ->
4627 new_vars(As,RV,ER)
4628 ;
4629 ER = [A-NewA,NewA-A|ER2],
4630 new_vars(As,RV,ER2)
4631 ).
4633 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4634 %
4635 % check if a list of constraints is a subset of another list of constraints
4636 % (multiset-subset), meanwhile computing a variable renaming to convert
4637 % one into the other.
4638 head_subset(H,Head,Renaming) :-
4639 head_subset(H,Head,Renaming,[],_).
4641 head_subset([],Remainder,Renaming,Renaming,Remainder).
4642 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4643 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4644 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4646 % check if A is in the list, remove it from Headleft
4647 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4648 ( variable_replacement(A,X,Acc,Renaming),
4649 Remainder = Xs
4650 ;
4651 Remainder = [X|RRemainder],
4652 head_member(Xs,A,Renaming,Acc,RRemainder)
4653 ).
4654 %-------------------------------------------------------------------------------%
4655 % memoing code to speed up repeated computation
4657 :- chr_constraint precompute_head_matchings/0.
4659 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4660 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4661 append(H1,H2,Heads),
4662 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4663 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4664 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4666 precompute_head_matchings <=> true.
4668 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4669 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4671 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4672 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4674 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4675 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4676 <=>
4677 Q1 = NHeads,
4678 Q2 = Matchings.
4679 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4681 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4682 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4683 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4684 %-------------------------------------------------------------------------------%
4686 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4687 extract_arguments(Heads,Arguments),
4688 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4689 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4691 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4692 extract_arguments(Heads,Arguments),
4693 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4694 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4696 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4697 extract_arguments(Heads,Arguments1),
4698 extract_arguments(MatchingFreeHeads,Arguments2),
4699 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4701 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4702 %
4703 % Returns list of arguments of given list of constraints.
4704 extract_arguments([],[]).
4705 extract_arguments([Constraint|Constraints],AllArguments) :-
4706 Constraint =.. [_|Arguments],
4707 append(Arguments,RestArguments,AllArguments),
4708 extract_arguments(Constraints,RestArguments).
4710 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4711 %
4712 % Substitutes arguments of constraints with those in the given list.
4714 substitute_arguments([],[],[]).
4715 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4716 functor(Constraint,F,N),
4717 split_at(N,Variables,Arguments,RestVariables),
4718 NConstraint =.. [F|Arguments],
4719 substitute_arguments(Constraints,RestVariables,NConstraints).
4721 make_matchings_explicit([],[],_,MC,MC,[]).
4722 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4723 ( var(Arg) ->
4724 ( memberchk_eq(Arg,VarAcc) ->
4725 list2disj(MatchingCondition,MatchingCondition_disj),
4726 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4727 NVarAcc = VarAcc
4728 ;
4729 Matchings = RestMatchings,
4730 NewVar = Arg,
4731 NVarAcc = [Arg|VarAcc]
4732 ),
4733 MatchingCondition2 = MatchingCondition
4734 ;
4735 functor(Arg,F,A),
4736 Arg =.. [F|RecArgs],
4737 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4738 FlatArg =.. [F|RecVars],
4739 ( RecMatchings == [] ->
4740 Matchings = [functor(NewVar,F,A)|RestMatchings]
4741 ;
4742 list2conj(RecMatchings,ArgM_conj),
4743 list2disj(MatchingCondition,MatchingCondition_disj),
4744 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4745 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4746 ),
4747 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4748 term_variables(Args,ArgVars),
4749 append(ArgVars,VarAcc,NVarAcc)
4750 ),
4751 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4754 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4755 %
4756 % Returns list of new variables and list of pairwise unifications between given list and variables.
4758 make_matchings_explicit_not_negated([],[],[]).
4759 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4760 Matchings = [Var = X|RMatchings],
4761 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4763 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4764 %
4765 % (Partially) applies substitutions of =Goal= to given list.
4767 apply_guard_wrt_term([],_Guard,[]).
4768 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4769 ( var(Term) ->
4770 apply_guard_wrt_variable(Guard,Term,NTerm)
4771 ;
4772 Term =.. [F|HArgs],
4773 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4774 NTerm =.. [F|NewHArgs]
4775 ),
4776 apply_guard_wrt_term(RH,Guard,RGH).
4778 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4779 %
4780 % (Partially) applies goal =Guard= wrt variable.
4782 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4783 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4784 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4785 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4786 ( Guard = (X = Y), Variable == X ->
4787 NVariable = Y
4788 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4789 functor(NVariable,Functor,Arity)
4790 ;
4791 NVariable = Variable
4792 ).
4795 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4796 % ALWAYS FAILING GUARDS
4797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4799 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4800 ==>
4801 chr_pp_flag(check_impossible_rules,on),
4802 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4803 conj2list(G,GL),
4804 append(M,GuardList,Info),
4805 append(Info,GL,GuardWithContext),
4806 guard_entailment:entails_guard(GuardWithContext,fail)
4807 |
4808 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4809 set_all_passive(RuleNb).
4811 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4812 % HEAD SIMPLIFICATION
4813 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4815 % now we check the head matchings (guard may have been simplified meanwhile)
4816 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4817 <=>
4818 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4819 simplify_heads(M,GuardList,G,B,NewM,NewB),
4820 NewM \== [],
4821 extract_arguments(Head1,VH1),
4822 extract_arguments(Head2,VH2),
4823 extract_arguments(H,VH),
4824 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4825 substitute_arguments(Head1,H1,NewH1),
4826 substitute_arguments(Head2,H2,NewH2),
4827 append(NewB,NewB_,NewBody),
4828 list2conj(NewBody,BodyMatchings),
4829 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4830 (Head1 \== NewH1 ; Head2 \== NewH2 )
4831 |
4832 rule(RuleNb,NewRule).
4834 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4835 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4836 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4838 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4839 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4840 ( NH == M ->
4841 H2_ = M,
4842 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4843 ;
4844 (M = functor(X,F,A), NH == X ->
4845 length(A_args,A),
4846 (var(H2) ->
4847 NewB1 = [],
4848 H2_ =.. [F|A_args]
4849 ;
4850 H2 =.. [F|OrigArgs],
4851 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4852 H2_ =.. [F|A_args_]
4853 ),
4854 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4855 append(NewB1,NewB2,NewB)
4856 ;
4857 H2_ = H2,
4858 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4859 )
4860 ).
4862 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4863 ( NH == M ->
4864 H1_ = M,
4865 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4866 ;
4867 (M = functor(X,F,A), NH == X ->
4868 length(A_args,A),
4869 (var(H1) ->
4870 NewB1 = [],
4871 H1_ =.. [F|A_args]
4872 ;
4873 H1 =.. [F|OrigArgs],
4874 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4875 H1_ =.. [F|A_args_]
4876 ),
4877 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4878 append(NewB1,NewB2,NewB)
4879 ;
4880 H1_ = H1,
4881 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4882 )
4883 ).
4885 use_same_args([],[],[],_,_,[]).
4886 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4887 var(OA),!,
4888 Out = OA,
4889 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4890 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4891 nonvar(OA),!,
4892 ( common_variables(OA,Body) ->
4893 NewB = [NA = OA|NextB]
4894 ;
4895 NewB = NextB
4896 ),
4897 Out = NA,
4898 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4901 simplify_heads([],_GuardList,_G,_Body,[],[]).
4902 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4903 M = (A = B),
4904 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4905 guard_entailment:entails_guard(GuardList,(A=B)) ->
4906 ( common_variables(B,G-RM-GuardList) ->
4907 NewB = NextB,
4908 NewM = NextM
4909 ;
4910 ( common_variables(B,Body) ->
4911 NewB = [A = B|NextB]
4912 ;
4913 NewB = NextB
4914 ),
4915 NewM = [A|NextM]
4916 )
4917 ;
4918 ( nonvar(B), functor(B,BFu,BAr),
4919 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4920 NewB = NextB,
4921 ( common_variables(B,G-RM-GuardList) ->
4922 NewM = NextM
4923 ;
4924 NewM = [functor(A,BFu,BAr)|NextM]
4925 )
4926 ;
4927 NewM = NextM,
4928 NewB = NextB
4929 )
4930 ),
4931 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4933 common_variables(B,G) :-
4934 term_variables(B,BVars),
4935 term_variables(G,GVars),
4936 intersect_eq(BVars,GVars,L),
4937 L \== [].
4940 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4941 set_all_passive(_) <=> true.
4945 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4946 % OCCURRENCE SUBSUMPTION
4947 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4949 :- chr_constraint
4950 first_occ_in_rule/4,
4951 next_occ_in_rule/6.
4953 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4954 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4956 :- chr_constraint multiple_occ_constraints_checked/1.
4957 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4959 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4960 occurrence(C,O,RuleNb,ID,_),
4961 occurrence(C,O2,RuleNb,ID2,_),
4962 rule(RuleNb,Rule)
4963 \
4964 multiple_occ_constraints_checked(Done)
4965 <=>
4966 O < O2,
4967 chr_pp_flag(occurrence_subsumption,on),
4968 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4969 H1 \== [],
4970 \+ tree_set_memberchk(C,Done)
4971 |
4972 first_occ_in_rule(RuleNb,C,O,ID),
4973 tree_set_add(Done,C,NDone),
4974 multiple_occ_constraints_checked(NDone).
4976 % Find first occurrence of constraint =C= in rule =RuleNb=
4977 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4978 <=>
4979 O < O2
4980 |
4981 first_occ_in_rule(RuleNb,C,O,ID).
4983 first_occ_in_rule(RuleNb,C,O,ID_o1)
4984 <=>
4985 C = F/A,
4986 functor(FreshHead,F,A),
4987 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4989 % Skip passive occurrences.
4990 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4991 <=>
4992 O2 is O+1
4993 |
4994 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4996 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)
4997 <=>
4998 O2 is O+1,
4999 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
5000 |
5001 append(H1,H2,Heads),
5002 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5003 ( ExtraCond == [chr_pp_void_info] ->
5004 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5005 ;
5006 append(ExtraCond,Cond,NewCond),
5007 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5008 copy_term(GuardList,FGuardList),
5009 variable_replacement(GuardList,FGuardList,GLRepl),
5010 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5011 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5012 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5013 append(NewCond,GuardList2,BigCond),
5014 append(BigCond,GuardList3,BigCond2),
5015 copy_with_variable_replacement(M,M2,Repl),
5016 copy_with_variable_replacement(M,M3,Repl2),
5017 append(M3,BigCond2,BigCond3),
5018 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5019 list2conj(CheckCond,OccSubsum),
5020 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5021 ( OccSubsum \= chr_pp_void_info ->
5022 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5023 passive(RuleNb,ID_o2)
5024 ;
5025 true
5026 )
5027 ;
5028 true
5029 ),!,
5030 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5031 ).
5034 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5035 <=>
5036 true.
5038 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5039 <=>
5040 true.
5042 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5043 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5044 append(ID2,ID1,IDs),
5045 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5046 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5047 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5048 copy_with_variable_replacement(G,FG,Repl),
5049 extract_explicit_matchings(FG,FG2),
5050 negate_b(FG2,NotFG),
5051 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5052 ( subsumes(FH,FH2) ->
5053 FailCond = [(NotFG;FMPCond)]
5054 ;
5055 % in this case, not much can be done
5056 % e.g. c(f(...)), c(g(...)) <=> ...
5057 FailCond = [chr_pp_void_info]
5058 ).
5060 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5061 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5062 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5063 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5064 Cond = (chr_pp_not_in_store(H);Cond1),
5065 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5067 extract_explicit_matchings((A,B),D) :- !,
5068 ( extract_explicit_matchings(A) ->
5069 extract_explicit_matchings(B,D)
5070 ;
5071 D = (A,E),
5072 extract_explicit_matchings(B,E)
5073 ).
5074 extract_explicit_matchings(A,D) :- !,
5075 ( extract_explicit_matchings(A) ->
5076 D = true
5077 ;
5078 D = A
5079 ).
5081 extract_explicit_matchings(A=B) :-
5082 var(A), var(B), !, A=B.
5083 extract_explicit_matchings(A==B) :-
5084 var(A), var(B), !, A=B.
5086 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5087 % TYPE INFORMATION
5088 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5090 :- chr_constraint
5091 type_definition/2,
5092 type_alias/2,
5093 constraint_type/2,
5094 get_type_definition/2,
5095 get_constraint_type/2.
5098 :- chr_option(mode,type_definition(?,?)).
5099 :- chr_option(mode,get_type_definition(?,?)).
5100 :- chr_option(mode,type_alias(?,?)).
5101 :- chr_option(mode,constraint_type(+,+)).
5102 :- chr_option(mode,get_constraint_type(+,-)).
5104 assert_constraint_type(Constraint,ArgTypes) :-
5105 ( ground(ArgTypes) ->
5106 constraint_type(Constraint,ArgTypes)
5107 ;
5108 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5109 ).
5111 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5112 % Consistency checks of type aliases
5114 type_alias(T1,T2) <=>
5115 var(T1)
5116 |
5117 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5119 type_alias(T1,T2) <=>
5120 var(T2)
5121 |
5122 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5124 type_alias(T,T2) <=>
5125 functor(T,F,A),
5126 functor(T2,F,A),
5127 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5128 |
5129 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5131 type_alias(T1,A1), type_alias(T2,A2) <=>
5132 functor(T1,F,A),
5133 functor(T2,F,A),
5134 \+ (T1\=T2)
5135 |
5136 copy_term_nat(T1,T1_),
5137 copy_term_nat(T2,T2_),
5138 T1_ = T2_,
5139 chr_error(type_error,
5140 '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_]).
5142 type_alias(T,B) \ type_alias(X,T2) <=>
5143 functor(T,F,A),
5144 functor(T2,F,A),
5145 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5146 subsumes(T1,T3)
5147 |
5148 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5149 type_alias(X2,D1).
5151 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5152 % Consistency checks of type definitions
5154 type_definition(T1,_), type_definition(T2,_)
5155 <=>
5156 functor(T1,F,A), functor(T2,F,A)
5157 |
5158 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5160 type_definition(T1,_), type_alias(T2,_)
5161 <=>
5162 functor(T1,F,A), functor(T2,F,A)
5163 |
5164 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5166 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5167 %% get_type_definition(+Type,-Definition) is semidet.
5168 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5170 get_type_definition(T,Def)
5171 <=>
5172 \+ ground(T)
5173 |
5174 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5176 type_alias(T,D) \ get_type_definition(T2,Def)
5177 <=>
5178 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5179 copy_term_nat((T,D),(T1,D1)),T1=T2
5180 |
5181 ( get_type_definition(D1,Def) ->
5182 true
5183 ;
5184 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5185 ).
5187 type_definition(T,D) \ get_type_definition(T2,Def)
5188 <=>
5189 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5190 copy_term_nat((T,D),(T1,D1)),T1=T2
5191 |
5192 Def = D1.
5194 get_type_definition(Type,Def)
5195 <=>
5196 atomic_builtin_type(Type,_,_)
5197 |
5198 Def = [Type].
5200 get_type_definition(Type,Def)
5201 <=>
5202 compound_builtin_type(Type,_,_,_)
5203 |
5204 Def = [Type].
5206 get_type_definition(X,Y) <=> fail.
5208 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5209 %% get_type_definition_det(+Type,-Definition) is det.
5210 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5211 get_type_definition_det(Type,Definition) :-
5212 ( get_type_definition(Type,Definition) ->
5213 true
5214 ;
5215 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5216 ).
5218 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5219 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5220 %
5221 % Return argument types of =ConstraintSymbol=, but fails if none where
5222 % declared.
5223 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5224 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5225 get_constraint_type(_,_) <=> fail.
5227 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5228 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5229 %
5230 % Like =get_constraint_type/2=, but returns list of =any= types when
5231 % no types are declared.
5232 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5233 get_constraint_type_det(ConstraintSymbol,Types) :-
5234 ( get_constraint_type(ConstraintSymbol,Types) ->
5235 true
5236 ;
5237 ConstraintSymbol = _ / N,
5238 replicate(N,any,Types)
5239 ).
5240 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5241 %% unalias_type(+Alias,-Type) is det.
5242 %
5243 % Follows alias chain until base type is reached.
5244 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5245 :- chr_constraint unalias_type/2.
5247 unalias_var @
5248 unalias_type(Alias,BaseType)
5249 <=>
5250 var(Alias)
5251 |
5252 BaseType = Alias.
5254 unalias_alias @
5255 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5256 <=>
5257 nonvar(AliasProtoType),
5258 nonvar(Alias),
5259 functor(AliasProtoType,F,A),
5260 functor(Alias,F,A),
5261 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5262 Alias = AliasInstance
5263 |
5264 unalias_type(Type,BaseType).
5266 unalias_type_definition @
5267 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5268 <=>
5269 nonvar(ProtoType),
5270 nonvar(Alias),
5271 functor(ProtoType,F,A),
5272 functor(Alias,F,A)
5273 |
5274 BaseType = Alias.
5276 unalias_atomic_builtin @
5277 unalias_type(Alias,BaseType)
5278 <=>
5279 atomic_builtin_type(Alias,_,_)
5280 |
5281 BaseType = Alias.
5283 unalias_compound_builtin @
5284 unalias_type(Alias,BaseType)
5285 <=>
5286 compound_builtin_type(Alias,_,_,_)
5287 |
5288 BaseType = Alias.
5290 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5291 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5292 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5293 :- chr_constraint types_modes_condition/3.
5294 :- chr_option(mode,types_modes_condition(+,+,?)).
5295 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5297 types_modes_condition([],[],T) <=> T=true.
5299 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5300 <=>
5301 functor(Head,F,A)
5302 |
5303 Head =.. [_|Args],
5304 Condition = (ModesCondition, TypesCondition, RestCondition),
5305 modes_condition(Modes,Args,ModesCondition),
5306 get_constraint_type_det(F/A,Types),
5307 UnrollHead =.. [_|RealArgs],
5308 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5309 types_modes_condition(Heads,UnrollHeads,RestCondition).
5311 types_modes_condition([Head|_],_,_)
5312 <=>
5313 functor(Head,F,A),
5314 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5317 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5318 %% modes_condition(+Modes,+Args,-Condition) is det.
5319 %
5320 % Return =Condition= on =Args= that checks =Modes=.
5321 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5322 modes_condition([],[],true).
5323 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5324 ( Mode == (+) ->
5325 Condition = ( ground(Arg) , RCondition )
5326 ; Mode == (-) ->
5327 Condition = ( var(Arg) , RCondition )
5328 ;
5329 Condition = RCondition
5330 ),
5331 modes_condition(Modes,Args,RCondition).
5333 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5334 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5335 %
5336 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5337 % =UnrollArgs= controls the depth of type definition unrolling.
5338 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5339 types_condition([],[],[],[],true).
5340 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5341 ( Mode == (-) ->
5342 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5343 ;
5344 get_type_definition_det(Type,Def),
5345 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5346 ( Mode == (+) ->
5347 TypeConditionList = TypeConditionList1
5348 ;
5349 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5350 )
5351 ),
5352 list2disj(TypeConditionList,DisjTypeConditionList),
5353 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5355 type_condition([],_,_,_,[]).
5356 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5357 ( var(DefCase) ->
5358 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5359 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5360 true
5361 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5362 true
5363 ;
5364 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5365 ),
5366 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5368 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5369 :- chr_type atomic_builtin_type ---> any
5370 ; number
5371 ; float
5372 ; int
5373 ; natural
5374 ; dense_int
5375 ; chr_identifier
5376 ; chr_identifier(any)
5377 ; /* all possible values are given */
5378 chr_enum(list(any))
5379 ; /* all possible values appear in rule heads;
5380 to distinguish between multiple chr_constants
5381 we have a key*/
5382 chr_constants(any)
5383 ; /* all relevant values appear in rule heads;
5384 for other values a handler is provided */
5385 chr_constants(any,any).
5386 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5388 atomic_builtin_type(any,_Arg,true).
5389 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5390 atomic_builtin_type(int,Arg,integer(Arg)).
5391 atomic_builtin_type(number,Arg,number(Arg)).
5392 atomic_builtin_type(float,Arg,float(Arg)).
5393 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5394 atomic_builtin_type(chr_identifier,_Arg,true).
5396 compound_builtin_type(chr_constants(_),_Arg,true,true).
5397 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5398 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5399 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5400 once(( member(Constant,Constants),
5401 unifiable(Arg,Constant,_)
5402 )
5403 )
5404 ).
5406 is_chr_constants_type(chr_constants(Key),Key,no).
5407 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5409 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5410 ( nonvar(DefCase) ->
5411 functor(DefCase,F,A),
5412 ( A == 0 ->
5413 Condition = (Arg = DefCase)
5414 ; var(UnrollArg) ->
5415 Condition = functor(Arg,F,A)
5416 ; functor(UnrollArg,F,A) ->
5417 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5418 DefCase =.. [_|ArgTypes],
5419 UnrollArg =.. [_|UnrollArgs],
5420 functor(Template,F,A),
5421 Template =.. [_|TemplateArgs],
5422 replicate(A,Mode,ArgModes),
5423 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5424 ;
5425 Condition = functor(Arg,F,A)
5426 )
5427 ;
5428 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5429 ).
5432 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5433 % STATIC TYPE CHECKING
5434 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5435 % Checks head constraints and CHR constraint calls in bodies.
5436 %
5437 % TODO:
5438 % - type clashes involving built-in types
5439 % - Prolog built-ins in guard and body
5440 % - indicate position in terms in error messages
5441 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5442 :- chr_constraint
5443 static_type_check/0.
5446 % 1. Check the declared types
5448 constraint_type(Constraint,ArgTypes), static_type_check
5449 ==>
5450 forall(
5451 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5452 ( get_type_definition(Type,_) ->
5453 true
5454 ;
5455 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5456 )
5457 ).
5459 % 2. Check the rules
5461 :- chr_type type_error_src ---> head(any) ; body(any).
5463 rule(_,Rule), static_type_check
5464 ==>
5465 copy_term_nat(Rule,RuleCopy),
5466 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5467 (
5468 catch(
5469 ( static_type_check_heads(Head1),
5470 static_type_check_heads(Head2),
5471 conj2list(Body,GoalList),
5472 static_type_check_body(GoalList)
5473 ),
5474 type_error(Error),
5475 ( Error = invalid_functor(Src,Term,Type) ->
5476 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5477 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5478 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5479 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5480 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5481 )
5482 ),
5483 fail % cleanup constraints
5484 ;
5485 true
5486 ).
5489 static_type_check <=> true.
5491 static_type_check_heads([]).
5492 static_type_check_heads([Head|Heads]) :-
5493 static_type_check_head(Head),
5494 static_type_check_heads(Heads).
5496 static_type_check_head(Head) :-
5497 functor(Head,F,A),
5498 get_constraint_type_det(F/A,Types),
5499 Head =..[_|Args],
5500 maplist(static_type_check_term(head(Head)),Args,Types).
5502 static_type_check_body([]).
5503 static_type_check_body([Goal|Goals]) :-
5504 functor(Goal,F,A),
5505 get_constraint_type_det(F/A,Types),
5506 Goal =..[_|Args],
5507 maplist(static_type_check_term(body(Goal)),Args,Types),
5508 static_type_check_body(Goals).
5510 :- chr_constraint static_type_check_term/3.
5511 :- chr_option(mode,static_type_check_term(?,?,?)).
5512 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5514 static_type_check_term(Src,Term,Type)
5515 <=>
5516 var(Term)
5517 |
5518 static_type_check_var(Src,Term,Type).
5519 static_type_check_term(Src,Term,Type)
5520 <=>
5521 atomic_builtin_type(Type,Term,Goal)
5522 |
5523 ( call(Goal) ->
5524 true
5525 ;
5526 throw(type_error(invalid_functor(Src,Term,Type)))
5527 ).
5528 static_type_check_term(Src,Term,Type)
5529 <=>
5530 compound_builtin_type(Type,Term,_,Goal)
5531 |
5532 ( call(Goal) ->
5533 true
5534 ;
5535 throw(type_error(invalid_functor(Src,Term,Type)))
5536 ).
5537 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5538 <=>
5539 functor(Type,F,A),
5540 functor(AType,F,A)
5541 |
5542 copy_term_nat(AType-ADef,Type-Def),
5543 static_type_check_term(Src,Term,Def).
5545 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5546 <=>
5547 functor(Type,F,A),
5548 functor(AType,F,A)
5549 |
5550 copy_term_nat(AType-ADef,Type-Variants),
5551 functor(Term,TF,TA),
5552 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5553 Term =.. [_|Args],
5554 Variant =.. [_|Types],
5555 maplist(static_type_check_term(Src),Args,Types)
5556 ;
5557 throw(type_error(invalid_functor(Src,Term,Type)))
5558 ).
5560 static_type_check_term(Src,Term,Type)
5561 <=>
5562 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5564 :- chr_constraint static_type_check_var/3.
5565 :- chr_option(mode,static_type_check_var(?,-,?)).
5566 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5568 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5569 <=>
5570 functor(AType,F,A),
5571 functor(Type,F,A)
5572 |
5573 copy_term_nat(AType-ADef,Type-Def),
5574 static_type_check_var(Src,Var,Def).
5576 static_type_check_var(Src,Var,Type)
5577 <=>
5578 atomic_builtin_type(Type,_,_)
5579 |
5580 static_atomic_builtin_type_check_var(Src,Var,Type).
5582 static_type_check_var(Src,Var,Type)
5583 <=>
5584 compound_builtin_type(Type,_,_,_)
5585 |
5586 true.
5589 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5590 <=>
5591 Type1 \== Type2
5592 |
5593 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5595 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5596 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5597 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5598 :- chr_constraint static_atomic_builtin_type_check_var/3.
5599 :- chr_option(mode,static_type_check_var(?,-,+)).
5600 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5602 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5603 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5604 <=>
5605 true.
5606 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5607 <=>
5608 true.
5609 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5610 <=>
5611 true.
5612 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5613 <=>
5614 true.
5615 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5616 <=>
5617 true.
5618 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5619 <=>
5620 true.
5621 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5622 <=>
5623 true.
5624 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5625 <=>
5626 true.
5627 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5628 <=>
5629 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5631 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5632 %% format_src(+type_error_src) is det.
5633 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5634 format_src(head(Head)) :- format('head ~w',[Head]).
5635 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5637 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5638 % Dynamic type checking
5639 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5641 :- chr_constraint
5642 dynamic_type_check/0,
5643 dynamic_type_check_clauses/1,
5644 get_dynamic_type_check_clauses/1.
5646 generate_dynamic_type_check_clauses(Clauses) :-
5647 ( chr_pp_flag(debugable,on) ->
5648 dynamic_type_check,
5649 get_dynamic_type_check_clauses(Clauses0),
5650 append(Clauses0,
5651 [('$dynamic_type_check'(Type,Term) :-
5652 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5653 )],
5654 Clauses)
5655 ;
5656 Clauses = []
5657 ).
5659 type_definition(T,D), dynamic_type_check
5660 ==>
5661 copy_term_nat(T-D,Type-Definition),
5662 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5663 dynamic_type_check_clauses(DynamicChecks).
5664 type_alias(A,B), dynamic_type_check
5665 ==>
5666 copy_term_nat(A-B,Alias-Body),
5667 dynamic_type_check_alias_clause(Alias,Body,Clause),
5668 dynamic_type_check_clauses([Clause]).
5670 dynamic_type_check <=>
5671 findall(
5672 ('$dynamic_type_check'(Type,Term) :- Goal),
5673 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5674 BuiltinChecks
5675 ),
5676 dynamic_type_check_clauses(BuiltinChecks).
5678 dynamic_type_check_clause(T,DC,Clause) :-
5679 copy_term(T-DC,Type-DefinitionClause),
5680 functor(DefinitionClause,F,A),
5681 functor(Term,F,A),
5682 DefinitionClause =.. [_|DCArgs],
5683 Term =.. [_|TermArgs],
5684 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5685 list2conj(RecursiveCallList,RecursiveCalls),
5686 Clause = (
5687 '$dynamic_type_check'(Type,Term) :-
5688 RecursiveCalls
5689 ).
5691 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5692 Clause = (
5693 '$dynamic_type_check'(Alias,Term) :-
5694 '$dynamic_type_check'(Body,Term)
5695 ).
5697 dynamic_type_check_call(Type,Term,Call) :-
5698 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5699 % Call = when(nonvar(Term),Goal)
5700 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5701 % Call = when(nonvar(Term),Goal)
5702 % ;
5703 ( Type == any ->
5704 Call = true
5705 ;
5706 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5707 )
5708 % )
5709 .
5711 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5712 <=>
5713 append(C1,C2,C),
5714 dynamic_type_check_clauses(C).
5716 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5717 <=>
5718 Q = C.
5719 get_dynamic_type_check_clauses(Q)
5720 <=>
5721 Q = [].
5723 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5724 % Atomic Types
5725 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5726 % Some optimizations can be applied for atomic types...
5727 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5729 atomic_types_suspended_constraint(C) :-
5730 C = _/N,
5731 get_constraint_type(C,ArgTypes),
5732 get_constraint_mode(C,ArgModes),
5733 numlist(1,N,Indexes),
5734 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5736 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5737 ( is_indexed_argument(C,Index) ->
5738 ( Mode == (?) ->
5739 atomic_type(Type)
5740 ;
5741 true
5742 )
5743 ;
5744 true
5745 ).
5747 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5748 %% atomic_type(+Type) is semidet.
5749 %
5750 % Succeeds when all values of =Type= are atomic.
5751 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5752 :- chr_constraint atomic_type/1.
5754 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5756 type_definition(TypePat,Def) \ atomic_type(Type)
5757 <=>
5758 functor(Type,F,A), functor(TypePat,F,A)
5759 |
5760 maplist(atomic,Def).
5762 type_alias(TypePat,Alias) \ atomic_type(Type)
5763 <=>
5764 functor(Type,F,A), functor(TypePat,F,A)
5765 |
5766 atomic(Alias),
5767 copy_term_nat(TypePat-Alias,Type-NType),
5768 atomic_type(NType).
5770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5771 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5772 %
5773 % Succeeds when all values of =Type= are atomic
5774 % and the atom values are finitely enumerable.
5775 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5776 :- chr_constraint enumerated_atomic_type/2.
5778 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5780 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5781 <=>
5782 functor(Type,F,A), functor(TypePat,F,A)
5783 |
5784 maplist(atomic,Def),
5785 Atoms = Def.
5787 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5788 <=>
5789 functor(Type,F,A), functor(TypePat,F,A)
5790 |
5791 atomic(Alias),
5792 copy_term_nat(TypePat-Alias,Type-NType),
5793 enumerated_atomic_type(NType,Atoms).
5794 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5796 :- chr_constraint
5797 stored/3, % constraint,occurrence,(yes/no/maybe)
5798 stored_completing/3,
5799 stored_complete/3,
5800 is_stored/1,
5801 is_finally_stored/1,
5802 check_all_passive/2.
5804 :- chr_option(mode,stored(+,+,+)).
5805 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5806 :- chr_type storedinfo ---> yes ; no ; maybe.
5807 :- chr_option(mode,stored_complete(+,+,+)).
5808 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5809 :- chr_option(mode,guard_list(+,+,+,+)).
5810 :- chr_option(mode,check_all_passive(+,+)).
5811 :- chr_option(type_declaration,check_all_passive(any,list)).
5813 % change yes in maybe when yes becomes passive
5814 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5815 stored(C,O,yes), stored_complete(C,RO,Yesses)
5816 <=> O < RO | NYesses is Yesses - 1,
5817 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5818 % change yes in maybe when not observed
5819 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5820 <=> O < RO |
5821 NYesses is Yesses - 1,
5822 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5824 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5825 ==> RO =< MO2 | % C2 is never stored
5826 passive(RuleNb,ID).
5831 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5833 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5834 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5835 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5837 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5838 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5839 check_all_passive(RuleNb,IDs2).
5841 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5842 check_all_passive(RuleNb,IDs).
5844 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5845 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5847 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5849 % collect the storage information
5850 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5851 <=> NO is O + 1, NYesses is Yesses + 1,
5852 stored_completing(C,NO,NYesses).
5853 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5854 <=> NO is O + 1,
5855 stored_completing(C,NO,Yesses).
5857 stored(C,O,no) \ stored_completing(C,O,Yesses)
5858 <=> stored_complete(C,O,Yesses).
5859 stored_completing(C,O,Yesses)
5860 <=> stored_complete(C,O,Yesses).
5862 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5863 O2 > O | passive(RuleNb,Id).
5865 % decide whether a constraint is stored
5866 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5867 <=> RO =< MO | fail.
5868 is_stored(C) <=> true.
5870 % decide whether a constraint is suspends after occurrences
5871 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5872 <=> RO =< MO | fail.
5873 is_finally_stored(C) <=> true.
5875 storage_analysis(Constraints) :-
5876 ( chr_pp_flag(storage_analysis,on) ->
5877 check_constraint_storages(Constraints)
5878 ;
5879 true
5880 ).
5882 check_constraint_storages([]).
5883 check_constraint_storages([C|Cs]) :-
5884 check_constraint_storage(C),
5885 check_constraint_storages(Cs).
5887 check_constraint_storage(C) :-
5888 get_max_occurrence(C,MO),
5889 check_occurrences_storage(C,1,MO).
5891 check_occurrences_storage(C,O,MO) :-
5892 ( O > MO ->
5893 stored_completing(C,1,0)
5894 ;
5895 check_occurrence_storage(C,O),
5896 NO is O + 1,
5897 check_occurrences_storage(C,NO,MO)
5898 ).
5900 check_occurrence_storage(C,O) :-
5901 get_occurrence(C,O,RuleNb,ID),
5902 ( is_passive(RuleNb,ID) ->
5903 stored(C,O,maybe)
5904 ;
5905 get_rule(RuleNb,PragmaRule),
5906 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5907 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5908 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5909 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5910 check_storage_head2(Head2,O,Heads1,Body)
5911 )
5912 ).
5914 check_storage_head1(Head,O,H1,H2,G) :-
5915 functor(Head,F,A),
5916 C = F/A,
5917 ( H1 == [Head],
5918 H2 == [],
5919 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5920 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5921 Head =.. [_|L],
5922 no_matching(L,[]) ->
5923 stored(C,O,no)
5924 ;
5925 stored(C,O,maybe)
5926 ).
5928 no_matching([],_).
5929 no_matching([X|Xs],Prev) :-
5930 var(X),
5931 \+ memberchk_eq(X,Prev),
5932 no_matching(Xs,[X|Prev]).
5934 check_storage_head2(Head,O,H1,B) :-
5935 functor(Head,F,A),
5936 C = F/A,
5937 ( %(
5938 ( H1 \== [], B == true )
5939 %;
5940 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5941 %)
5942 ->
5943 stored(C,O,maybe)
5944 ;
5945 stored(C,O,yes)
5946 ).
5948 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5950 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5951 %% ____ _ ____ _ _ _ _
5952 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5953 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5954 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5955 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5956 %% |_|
5958 constraints_code(Constraints,Clauses) :-
5959 (chr_pp_flag(reduced_indexing,on),
5960 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5961 none_suspended_on_variables
5962 ;
5963 true
5964 ),
5965 constraints_code1(Constraints,Clauses,[]).
5967 %===============================================================================
5968 :- chr_constraint constraints_code1/3.
5969 :- chr_option(mode,constraints_code1(+,+,+)).
5970 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5971 %-------------------------------------------------------------------------------
5972 constraints_code1([],L,T) <=> L = T.
5973 constraints_code1([C|RCs],L,T)
5974 <=>
5975 constraint_code(C,L,T1),
5976 constraints_code1(RCs,T1,T).
5977 %===============================================================================
5978 :- chr_constraint constraint_code/3.
5979 :- chr_option(mode,constraint_code(+,+,+)).
5980 %-------------------------------------------------------------------------------
5981 %% Generate code for a single CHR constraint
5982 constraint_code(Constraint, L, T)
5983 <=> true
5984 | ( (chr_pp_flag(debugable,on) ;
5985 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5986 ( may_trigger(Constraint) ;
5987 get_allocation_occurrence(Constraint,AO),
5988 get_max_occurrence(Constraint,MO), MO >= AO ) )
5989 ->
5990 constraint_prelude(Constraint,Clause),
5991 add_dummy_location(Clause,LocatedClause),
5992 L = [LocatedClause | L1]
5993 ;
5994 L = L1
5995 ),
5996 Id = [0],
5997 occurrences_code(Constraint,1,Id,NId,L1,L2),
5998 gen_cond_attach_clause(Constraint,NId,L2,T).
6000 %===============================================================================
6001 %% Generate prelude predicate for a constraint.
6002 %% f(...) :- f/a_0(...,Susp).
6003 constraint_prelude(F/A, Clause) :-
6004 vars_susp(A,Vars,Susp,VarsSusp),
6005 Head =.. [ F | Vars],
6006 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6007 build_head(F,A,[0],VarsSusp,Delegate),
6008 ( chr_pp_flag(debugable,on) ->
6009 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6010 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6011 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6012 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6014 ( get_constraint_type(F/A,ArgTypeList) ->
6015 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6016 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6017 ;
6018 DynamicTypeChecks = true
6019 ),
6021 Clause =
6022 ( Head :-
6023 DynamicTypeChecks,
6024 InsertGoal,
6025 InsertCall,
6026 AttachCall,
6027 Inactive,
6028 'chr debug_event'(insert(Head#Susp)),
6029 (
6030 'chr debug_event'(call(Susp)),
6031 Delegate
6032 ;
6033 'chr debug_event'(fail(Susp)), !,
6034 fail
6035 ),
6036 (
6037 'chr debug_event'(exit(Susp))
6038 ;
6039 'chr debug_event'(redo(Susp)),
6040 fail
6041 )
6042 )
6043 ; get_allocation_occurrence(F/A,0) ->
6044 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6045 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6046 Clause = ( Head :- Goal, Inactive, Delegate )
6047 ;
6048 Clause = ( Head :- Delegate )
6049 ).
6051 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6052 ( may_trigger(F/A) ->
6053 build_head(F,A,[0],VarsSusp,Delegate),
6054 ( chr_pp_flag(debugable,off) ->
6055 Goal = Delegate
6056 ;
6057 get_target_module(Mod),
6058 Goal = Mod:Delegate
6059 )
6060 ;
6061 Goal = true
6062 ).
6064 %===============================================================================
6065 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6066 :- chr_option(mode,has_active_occurrence(+)).
6067 :- chr_option(mode,has_active_occurrence(+,+)).
6069 :- chr_constraint memo_has_active_occurrence/1.
6070 :- chr_option(mode,memo_has_active_occurrence(+)).
6071 %-------------------------------------------------------------------------------
6072 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6073 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6075 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6076 O > MO | fail.
6077 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6078 has_active_occurrence(C,O) <=>
6079 NO is O + 1,
6080 has_active_occurrence(C,NO).
6081 has_active_occurrence(C,O) <=> true.
6082 %===============================================================================
6084 gen_cond_attach_clause(F/A,Id,L,T) :-
6085 ( is_finally_stored(F/A) ->
6086 get_allocation_occurrence(F/A,AllocationOccurrence),
6087 get_max_occurrence(F/A,MaxOccurrence),
6088 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6089 ( only_ground_indexed_arguments(F/A) ->
6090 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6091 ;
6092 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6093 )
6094 ; vars_susp(A,Args,Susp,AllArgs),
6095 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6096 ),
6097 build_head(F,A,Id,AllArgs,Head),
6098 Clause = ( Head :- Body ),
6099 add_dummy_location(Clause,LocatedClause),
6100 L = [LocatedClause | T]
6101 ;
6102 L = T
6103 ).
6105 :- chr_constraint use_auxiliary_predicate/1.
6106 :- chr_option(mode,use_auxiliary_predicate(+)).
6108 :- chr_constraint use_auxiliary_predicate/2.
6109 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6111 :- chr_constraint is_used_auxiliary_predicate/1.
6112 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6114 :- chr_constraint is_used_auxiliary_predicate/2.
6115 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6118 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6120 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6122 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6124 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6126 is_used_auxiliary_predicate(P) <=> fail.
6128 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6129 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6131 is_used_auxiliary_predicate(P,C) <=> fail.
6133 %------------------------------------------------------------------------------%
6134 % Only generate import statements for actually used modules.
6135 %------------------------------------------------------------------------------%
6137 :- chr_constraint use_auxiliary_module/1.
6138 :- chr_option(mode,use_auxiliary_module(+)).
6140 :- chr_constraint is_used_auxiliary_module/1.
6141 :- chr_option(mode,is_used_auxiliary_module(+)).
6144 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6146 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6148 is_used_auxiliary_module(P) <=> fail.
6150 % only called for constraints with
6151 % at least one
6152 % non-ground indexed argument
6153 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6154 vars_susp(A,Args,Susp,AllArgs),
6155 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6156 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6157 Attach = true
6158 ;
6159 attach_constraint_atom(F/A,Vars,Susp,Attach)
6160 ),
6161 FTerm =.. [F|Args],
6162 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6163 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6164 ( may_trigger(F/A) ->
6165 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6166 Goal =
6167 (
6168 ( var(Susp) ->
6169 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6170 InsertCall,
6171 Attach
6172 ;
6173 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6174 )
6175 )
6176 ;
6177 Goal =
6178 (
6179 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6180 InsertCall,
6181 Attach
6182 )
6183 ).
6185 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6186 vars_susp(A,Args,Susp,AllArgs),
6187 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6188 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6189 attach_constraint_atom(F/A,Vars,Susp,Attach)
6190 ;
6191 Attach = true
6192 ),
6193 FTerm =.. [F|Args],
6194 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6195 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6196 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6197 Goal =
6198 (
6199 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6200 InsertCall
6201 )
6202 ;
6203 Goal =
6204 (
6205 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6206 InsertCall,
6207 Attach
6208 )
6209 ).
6211 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6212 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6213 attach_constraint_atom(FA,Vars,Susp,Attach)
6214 ;
6215 Attach = true
6216 ),
6217 insert_constraint_goal(FA,Susp,Args,InsertCall),
6218 ( chr_pp_flag(late_allocation,on) ->
6219 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6220 ;
6221 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6222 ).
6224 %-------------------------------------------------------------------------------
6225 :- chr_constraint occurrences_code/6.
6226 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6227 %-------------------------------------------------------------------------------
6228 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6229 <=> O > MO
6230 | NId = Id, L = T.
6231 occurrences_code(C,O,Id,NId,L,T)
6232 <=>
6233 occurrence_code(C,O,Id,Id1,L,L1),
6234 NO is O + 1,
6235 occurrences_code(C,NO,Id1,NId,L1,T).
6236 %-------------------------------------------------------------------------------
6237 :- chr_constraint occurrence_code/6.
6238 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6239 %-------------------------------------------------------------------------------
6240 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6241 <=>
6242 ( named_history(RuleNb,_,_) ->
6243 does_use_history(C,O)
6244 ;
6245 true
6246 ),
6247 NId = Id,
6248 L = T.
6249 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6250 <=> true |
6251 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6252 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6253 NId = Id,
6254 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6255 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6257 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6258 ( should_skip_to_next_id(C,O) ->
6259 inc_id(Id,NId),
6260 ( unconditional_occurrence(C,O) ->
6261 L1 = T
6262 ;
6263 gen_alloc_inc_clause(C,O,Id,L1,T)
6264 )
6265 ;
6266 NId = Id,
6267 L1 = T
6268 )
6269 ).
6271 occurrence_code(C,O,_,_,_,_)
6272 <=>
6273 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6274 %-------------------------------------------------------------------------------
6276 %% Generate code based on one removed head of a CHR rule
6277 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6278 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6279 Rule = rule(_,Head2,_,_),
6280 ( Head2 == [] ->
6281 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6282 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6283 ;
6284 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6285 ).
6287 %% Generate code based on one persistent head of a CHR rule
6288 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6289 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6290 Rule = rule(Head1,_,_,_),
6291 ( Head1 == [] ->
6292 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6293 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6294 ;
6295 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6296 ).
6298 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6299 vars_susp(A,Vars,Susp,VarsSusp),
6300 build_head(F,A,Id,VarsSusp,Head),
6301 inc_id(Id,IncId),
6302 build_head(F,A,IncId,VarsSusp,CallHead),
6303 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6304 Clause =
6305 (
6306 Head :-
6307 ConditionalAlloc,
6308 CallHead
6309 ),
6310 add_dummy_location(Clause,LocatedClause),
6311 L = [LocatedClause|T].
6313 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6314 get_allocation_occurrence(FA,AO),
6315 get_occurrence_code_id(FA,AO,AId),
6316 get_occurrence_code_id(FA,O,Id),
6317 ( chr_pp_flag(debugable,off), Id == AId ->
6318 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6319 ( may_trigger(FA) ->
6320 Goal = (var(Susp) -> Goal0 ; true)
6321 ;
6322 Goal = Goal0
6323 )
6324 ;
6325 Goal = true
6326 ).
6328 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6329 get_allocation_occurrence(FA,AO),
6330 ( chr_pp_flag(debugable,off), O < AO ->
6331 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6332 ( may_trigger(FA) ->
6333 Goal = (var(Susp) -> Goal0 ; true)
6334 ;
6335 Goal = Goal0
6336 )
6337 ;
6338 Goal = true
6339 ).
6341 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6343 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6344 %
6345 % Reorders guard goals with respect to partner constraint retrieval goals and
6346 % active constraint. Returns combined partner retrieval + guard goal.
6348 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6349 ( chr_pp_flag(guard_via_reschedule,on) ->
6350 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6351 list2conj(ScheduleSkeleton,GoalSkeleton)
6352 ;
6353 length(Retrievals,RL), length(LookupSkeleton,RL),
6354 length(GuardList,GL), length(GuardListSkeleton,GL),
6355 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6356 list2conj(GoalListSkeleton,GoalSkeleton)
6357 ).
6358 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6359 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6360 initialize_unit_dictionary(ActiveHead,Dict),
6361 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6362 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6363 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6364 dependency_reorder(Units,NUnits),
6365 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6366 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6367 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6369 wrappedunits2lists([],[],[],[]).
6370 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6371 Ss = [GoalCopy|TSs],
6372 ( WrappedGoal = lookup(Goal) ->
6373 Ls = [GoalCopy|TLs],
6374 Gs = TGs
6375 ; WrappedGoal = guard(Goal) ->
6376 Gs = [N-GoalCopy|TGs],
6377 Ls = TLs
6378 ),
6379 wrappedunits2lists(Units,TGs,TLs,TSs).
6381 guard_splitting(Rule,SplitGuardList) :-
6382 Rule = rule(H1,H2,Guard,_),
6383 append(H1,H2,Heads),
6384 conj2list(Guard,GuardList),
6385 term_variables(Heads,HeadVars),
6386 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6387 append(GuardPrefix,[RestGuard],SplitGuardList),
6388 term_variables(RestGuardList,GuardVars1),
6389 % variables that are declared to be ground don't need to be locked
6390 ground_vars(Heads,GroundVars),
6391 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6392 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6393 ( chr_pp_flag(guard_locks,on),
6394 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6395 once(pairup(Locks,Unlocks,LocksUnlocks))
6396 ;
6397 Locks = [],
6398 Unlocks = []
6399 ),
6400 list2conj(Locks,LockPhase),
6401 list2conj(Unlocks,UnlockPhase),
6402 list2conj(RestGuardList,RestGuard1),
6403 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6405 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6406 Rule = rule(_,_,_,Body),
6407 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6408 my_term_copy(Body,VarDict2,BodyCopy).
6411 split_off_simple_guard_new([],_,[],[]).
6412 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6413 ( simple_guard_new(G,VarDict) ->
6414 S = [G|Ss],
6415 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6416 ;
6417 S = [],
6418 C = [G|Gs]
6419 ).
6421 % simple guard: cheap and benign (does not bind variables)
6422 simple_guard_new(G,Vars) :-
6423 builtin_binds_b(G,BoundVars),
6424 not(( member(V,BoundVars),
6425 memberchk_eq(V,Vars)
6426 )).
6428 dependency_reorder(Units,NUnits) :-
6429 dependency_reorder(Units,[],NUnits).
6431 dependency_reorder([],Acc,Result) :-
6432 reverse(Acc,Result).
6434 dependency_reorder([Unit|Units],Acc,Result) :-
6435 Unit = unit(_GID,_Goal,Type,GIDs),
6436 ( Type == fixed ->
6437 NAcc = [Unit|Acc]
6438 ;
6439 dependency_insert(Acc,Unit,GIDs,NAcc)
6440 ),
6441 dependency_reorder(Units,NAcc,Result).
6443 dependency_insert([],Unit,_,[Unit]).
6444 dependency_insert([X|Xs],Unit,GIDs,L) :-
6445 X = unit(GID,_,_,_),
6446 ( memberchk(GID,GIDs) ->
6447 L = [Unit,X|Xs]
6448 ;
6449 L = [X | T],
6450 dependency_insert(Xs,Unit,GIDs,T)
6451 ).
6453 build_units(Retrievals,Guard,InitialDict,Units) :-
6454 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6455 build_guard_units(Guard,N,Dict,Tail).
6457 build_retrieval_units([],N,N,Dict,Dict,L,L).
6458 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6459 term_variables(U,Vs),
6460 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6461 L = [unit(N,U,fixed,GIDs)|L1],
6462 N1 is N + 1,
6463 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6465 initialize_unit_dictionary(Term,Dict) :-
6466 term_variables(Term,Vars),
6467 pair_all_with(Vars,0,Dict).
6469 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6470 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6471 ( lookup_eq(Dict,V,GID) ->
6472 ( (GID == This ; memberchk(GID,GIDs) ) ->
6473 GIDs1 = GIDs
6474 ;
6475 GIDs1 = [GID|GIDs]
6476 ),
6477 Dict1 = Dict
6478 ;
6479 Dict1 = [V - This|Dict],
6480 GIDs1 = GIDs
6481 ),
6482 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6484 build_guard_units(Guard,N,Dict,Units) :-
6485 ( Guard = [Goal] ->
6486 Units = [unit(N,Goal,fixed,[])]
6487 ; Guard = [Goal|Goals] ->
6488 term_variables(Goal,Vs),
6489 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6490 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6491 N1 is N + 1,
6492 build_guard_units(Goals,N1,NDict,RUnits)
6493 ).
6495 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6496 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6497 ( lookup_eq(Dict,V,GID) ->
6498 ( (GID == This ; memberchk(GID,GIDs) ) ->
6499 GIDs1 = GIDs
6500 ;
6501 GIDs1 = [GID|GIDs]
6502 ),
6503 Dict1 = [V - This|Dict]
6504 ;
6505 Dict1 = [V - This|Dict],
6506 GIDs1 = GIDs
6507 ),
6508 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6512 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6513 %% ____ _ ____ _ _
6514 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6515 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6516 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6517 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6518 %%
6519 %% _ _ _ ___ __
6520 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6521 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6522 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6523 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6524 %% |_|
6525 :- chr_constraint
6526 functional_dependency/4,
6527 get_functional_dependency/4.
6529 :- chr_option(mode,functional_dependency(+,+,?,?)).
6530 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6532 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6533 <=>
6534 RuleNb > 1, AO > O
6535 |
6536 functional_dependency(C,1,Pattern,Key).
6538 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6539 <=>
6540 RuleNb2 >= RuleNb1
6541 |
6542 QPattern = Pattern, QKey = Key.
6543 get_functional_dependency(_,_,_,_)
6544 <=>
6545 fail.
6547 functional_dependency_analysis(Rules) :-
6548 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6549 functional_dependency_analysis_main(Rules)
6550 ;
6551 true
6552 ).
6554 functional_dependency_analysis_main([]).
6555 functional_dependency_analysis_main([PRule|PRules]) :-
6556 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6557 functional_dependency(C,RuleNb,Pattern,Key)
6558 ;
6559 true
6560 ),
6561 functional_dependency_analysis_main(PRules).
6563 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6564 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6565 Rule = rule(H1,H2,Guard,_),
6566 ( H1 = [C1],
6567 H2 = [C2] ->
6568 true
6569 ; H1 = [C1,C2],
6570 H2 == [] ->
6571 true
6572 ),
6573 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6574 term_variables(C1,Vs),
6575 \+ (
6576 member(V1,Vs),
6577 lookup_eq(List,V1,V2),
6578 memberchk_eq(V2,Vs)
6579 ),
6580 select_pragma_unique_variables(Vs,List,Key1),
6581 copy_term_nat(C1-Key1,Pattern-Key),
6582 functor(C1,F,A).
6584 select_pragma_unique_variables([],_,[]).
6585 select_pragma_unique_variables([V|Vs],List,L) :-
6586 ( lookup_eq(List,V,_) ->
6587 L = T
6588 ;
6589 L = [V|T]
6590 ),
6591 select_pragma_unique_variables(Vs,List,T).
6593 % depends on functional dependency analysis
6594 % and shape of rule: C1 \ C2 <=> true.
6595 set_semantics_rules(Rules) :-
6596 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6597 set_semantics_rules_main(Rules)
6598 ;
6599 true
6600 ).
6602 set_semantics_rules_main([]).
6603 set_semantics_rules_main([R|Rs]) :-
6604 set_semantics_rule_main(R),
6605 set_semantics_rules_main(Rs).
6607 set_semantics_rule_main(PragmaRule) :-
6608 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6609 ( Rule = rule([C1],[C2],true,_),
6610 IDs = ids([ID1],[ID2]),
6611 \+ is_passive(RuleNb,ID1),
6612 functor(C1,F,A),
6613 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6614 copy_term_nat(Pattern-Key,C1-Key1),
6615 copy_term_nat(Pattern-Key,C2-Key2),
6616 Key1 == Key2 ->
6617 passive(RuleNb,ID2)
6618 ;
6619 true
6620 ).
6622 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6623 \+ any_passive_head(RuleNb),
6624 variable_replacement(C1-C2,C2-C1,List),
6625 copy_with_variable_replacement(G,OtherG,List),
6626 negate_b(G,NotG),
6627 once(entails_b(NotG,OtherG)).
6629 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6630 % where C1 and C2 are symmteric constraints
6631 symmetry_analysis(Rules) :-
6632 ( chr_pp_flag(check_unnecessary_active,off) ->
6633 true
6634 ;
6635 symmetry_analysis_main(Rules)
6636 ).
6638 symmetry_analysis_main([]).
6639 symmetry_analysis_main([R|Rs]) :-
6640 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6641 Rule = rule(H1,H2,_,_),
6642 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6643 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6644 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6645 ;
6646 true
6647 ),
6648 symmetry_analysis_main(Rs).
6650 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6651 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6652 ( \+ is_passive(RuleNb,ID),
6653 member2(PreHs,PreIDs,PreH-PreID),
6654 \+ is_passive(RuleNb,PreID),
6655 variable_replacement(PreH,H,List),
6656 copy_with_variable_replacement(Rule,Rule2,List),
6657 identical_guarded_rules(Rule,Rule2) ->
6658 passive(RuleNb,ID)
6659 ;
6660 true
6661 ),
6662 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6664 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6665 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6666 ( \+ is_passive(RuleNb,ID),
6667 member2(PreHs,PreIDs,PreH-PreID),
6668 \+ is_passive(RuleNb,PreID),
6669 variable_replacement(PreH,H,List),
6670 copy_with_variable_replacement(Rule,Rule2,List),
6671 identical_rules(Rule,Rule2) ->
6672 passive(RuleNb,ID)
6673 ;
6674 true
6675 ),
6676 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6678 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6680 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6681 %% ____ _ _ _ __ _ _ _
6682 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6683 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6684 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6685 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6686 %% |_|
6687 %% {{{
6689 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6690 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6691 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6692 build_head(F,A,Id,HeadVars,ClauseHead),
6693 get_constraint_mode(F/A,Mode),
6694 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6697 guard_splitting(Rule,GuardList0),
6698 ( is_stored_in_guard(F/A, RuleNb) ->
6699 GuardList = [Hole1|GuardList0]
6700 ;
6701 GuardList = GuardList0
6702 ),
6703 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6705 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6707 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6709 ( is_stored_in_guard(F/A, RuleNb) ->
6710 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6711 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6712 GuardCopyList = [Hole1Copy|_],
6713 Hole1Copy = (Allocation, Attachment)
6714 ;
6715 true
6716 ),
6719 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6720 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6722 ( chr_pp_flag(debugable,on) ->
6723 Rule = rule(_,_,Guard,Body),
6724 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6725 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6726 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6727 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6728 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6729 ;
6730 Cut = ActualCut
6731 ),
6732 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6733 Clause = ( ClauseHead :-
6734 FirstMatching,
6735 RescheduledTest,
6736 Cut,
6737 SuspsDetachments,
6738 SuspDetachment,
6739 BodyCopy
6740 ),
6741 add_location(Clause,RuleNb,LocatedClause),
6742 L = [LocatedClause | T].
6744 % }}}
6746 add_location(Clause,RuleNb,NClause) :-
6747 ( chr_pp_flag(line_numbers,on) ->
6748 get_chr_source_file(File),
6749 get_line_number(RuleNb,LineNb),
6750 NClause = '$source_location'(File,LineNb):Clause
6751 ;
6752 NClause = Clause
6753 ).
6755 add_dummy_location(Clause,NClause) :-
6756 ( chr_pp_flag(line_numbers,on) ->
6757 get_chr_source_file(File),
6758 NClause = '$source_location'(File,1):Clause
6759 ;
6760 NClause = Clause
6761 ).
6762 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6763 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6764 %
6765 % Return goal matching newly introduced variables with variables in
6766 % previously looked-up heads.
6767 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6768 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6769 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6771 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6772 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6773 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6774 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6775 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6776 list2conj(GoalList,Goal).
6778 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6779 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6780 ( Mode == (+) ->
6781 term_variables(Arg,GroundVars0,GroundVars),
6782 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6783 ;
6784 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6785 ).
6786 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6787 ( var(Arg) ->
6788 ( lookup_eq(VarDict,Arg,OtherVar) ->
6789 ( Mode = (+) ->
6790 ( memberchk_eq(Arg,GroundVars) ->
6791 GoalList = [Var = OtherVar | RestGoalList],
6792 GroundVars1 = GroundVars
6793 ;
6794 GoalList = [Var == OtherVar | RestGoalList],
6795 GroundVars1 = [Arg|GroundVars]
6796 )
6797 ;
6798 GoalList = [Var == OtherVar | RestGoalList],
6799 GroundVars1 = GroundVars
6800 ),
6801 VarDict1 = VarDict
6802 ;
6803 VarDict1 = [Arg-Var | VarDict],
6804 GoalList = RestGoalList,
6805 ( Mode = (+) ->
6806 GroundVars1 = [Arg|GroundVars]
6807 ;
6808 GroundVars1 = GroundVars
6809 )
6810 ),
6811 Pairs = Rest,
6812 RestModes = Modes
6813 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6814 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6815 GoalList = [Goal|RestGoalList],
6816 VarDict = VarDict1,
6817 GroundVars1 = GroundVars,
6818 Pairs = Rest,
6819 RestModes = Modes
6820 ; atomic(Arg) ->
6821 ( Mode = (+) ->
6822 GoalList = [ Var = Arg | RestGoalList]
6823 ;
6824 GoalList = [ Var == Arg | RestGoalList]
6825 ),
6826 VarDict = VarDict1,
6827 GroundVars1 = GroundVars,
6828 Pairs = Rest,
6829 RestModes = Modes
6830 ; Mode == (+), is_ground(GroundVars,Arg) ->
6831 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6832 GoalList = [ Var = ArgCopy | RestGoalList],
6833 VarDict = VarDict1,
6834 GroundVars1 = GroundVars,
6835 Pairs = Rest,
6836 RestModes = Modes
6837 ; Mode == (?), is_ground(GroundVars,Arg) ->
6838 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6839 GoalList = [ Var == ArgCopy | RestGoalList],
6840 VarDict = VarDict1,
6841 GroundVars1 = GroundVars,
6842 Pairs = Rest,
6843 RestModes = Modes
6844 ; Arg =.. [_|Args],
6845 functor(Arg,Fct,N),
6846 functor(Term,Fct,N),
6847 Term =.. [_|Vars],
6848 ( Mode = (+) ->
6849 GoalList = [ Var = Term | RestGoalList ]
6850 ;
6851 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6852 ),
6853 pairup(Args,Vars,NewPairs),
6854 append(NewPairs,Rest,Pairs),
6855 replicate(N,Mode,NewModes),
6856 append(NewModes,Modes,RestModes),
6857 VarDict1 = VarDict,
6858 GroundVars1 = GroundVars
6859 ),
6860 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6862 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6863 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6864 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6865 add_heads_types([],VarTypes,VarTypes).
6866 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6867 add_head_types(Head,VarTypes,VarTypes1),
6868 add_heads_types(Heads,VarTypes1,NVarTypes).
6870 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6871 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6872 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6873 add_head_types(Head,VarTypes,NVarTypes) :-
6874 functor(Head,F,A),
6875 get_constraint_type_det(F/A,ArgTypes),
6876 Head =.. [_|Args],
6877 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6879 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6880 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6881 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6882 add_args_types([],[],VarTypes,VarTypes).
6883 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6884 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6885 add_args_types(Args,Types,VarTypes1,NVarTypes).
6887 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6888 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6889 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6890 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6891 ( var(Term) ->
6892 ( lookup_eq(VarTypes,Term,_) ->
6893 NVarTypes = VarTypes
6894 ;
6895 NVarTypes = [Term-Type|VarTypes]
6896 )
6897 ; ground(Term) ->
6898 NVarTypes = VarTypes
6899 ; % TODO improve approximation!
6900 term_variables(Term,Vars),
6901 length(Vars,VarNb),
6902 replicate(VarNb,any,Types),
6903 add_args_types(Vars,Types,VarTypes,NVarTypes)
6904 ).
6908 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6909 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6910 %
6911 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6912 add_heads_ground_variables([],GroundVars,GroundVars).
6913 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6914 add_head_ground_variables(Head,GroundVars,GroundVars1),
6915 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6917 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6918 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6919 %
6920 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6921 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6922 functor(Head,F,A),
6923 get_constraint_mode(F/A,ArgModes),
6924 Head =.. [_|Args],
6925 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6928 add_arg_ground_variables([],[],GroundVars,GroundVars).
6929 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6930 ( Mode == (+) ->
6931 term_variables(Arg,Vars),
6932 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6933 ;
6934 GroundVars = GroundVars1
6935 ),
6936 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6938 add_var_ground_variables([],GroundVars,GroundVars).
6939 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6940 ( memberchk_eq(Var,GroundVars) ->
6941 GroundVars1 = GroundVars
6942 ;
6943 GroundVars1 = [Var|GroundVars]
6944 ),
6945 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6946 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6947 %% is_ground(+GroundVars,+Term) is semidet.
6948 %
6949 % Determine whether =Term= is always ground.
6950 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6951 is_ground(GroundVars,Term) :-
6952 ( ground(Term) ->
6953 true
6954 ; compound(Term) ->
6955 Term =.. [_|Args],
6956 maplist(is_ground(GroundVars),Args)
6957 ;
6958 memberchk_eq(Term,GroundVars)
6959 ).
6961 %% check_ground(+GroundVars,+Term,-Goal) is det.
6962 %
6963 % Return runtime check to see whether =Term= is ground.
6964 check_ground(GroundVars,Term,Goal) :-
6965 term_variables(Term,Variables),
6966 check_ground_variables(Variables,GroundVars,Goal).
6968 check_ground_variables([],_,true).
6969 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6970 ( memberchk_eq(Var,GroundVars) ->
6971 check_ground_variables(Vars,GroundVars,Goal)
6972 ;
6973 Goal = (ground(Var), RGoal),
6974 check_ground_variables(Vars,GroundVars,RGoal)
6975 ).
6977 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6978 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6980 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6981 ( Heads = [_|_] ->
6982 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6983 ;
6984 GoalList = [],
6985 Susps = [],
6986 VarDict = NVarDict,
6987 GroundVars = NGroundVars
6988 ).
6990 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6991 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6992 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6993 functor(H,F,A),
6994 head_info(H,A,Vars,_,_,Pairs),
6995 get_store_type(F/A,StoreType),
6996 ( StoreType == default ->
6997 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6998 delay_phase_end(validate_store_type_assumptions,
6999 ( static_suspension_term(F/A,Suspension),
7000 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
7001 get_static_suspension_field(F/A,Suspension,state,active,GetState)
7002 )
7003 ),
7004 % create_get_mutable_ref(active,State,GetMutable),
7005 get_constraint_mode(F/A,Mode),
7006 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7007 NPairs = Pairs,
7008 sbag_member_call(Susp,VarSusps,Sbag),
7009 ExistentialLookup = (
7010 ViaGoal,
7011 Sbag,
7012 Susp = Suspension, % not inlined
7013 GetState
7014 )
7015 ;
7016 delay_phase_end(validate_store_type_assumptions,
7017 ( static_suspension_term(F/A,Suspension),
7018 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7019 )
7020 ),
7021 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7022 get_constraint_mode(F/A,Mode),
7023 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7024 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
7025 ),
7026 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7027 filter_append(NPairs,VarDict1,DA_), % order important here
7028 translate(GroundVars1,DA_,GroundVarsA),
7029 translate(GroundVars1,VarDict1,GroundVarsB),
7030 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
7031 Goal =
7032 (
7033 ExistentialLookup,
7034 DiffSuspGoals,
7035 MatchingGoal2
7036 ),
7037 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7039 inline_matching_goal(A==B,true,GVA,GVB) :-
7040 memberchk_eq(A,GVA),
7041 memberchk_eq(B,GVB),
7042 A=B, !.
7044 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7045 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7046 inline_matching_goal(A,A2,GVA,GVB),
7047 inline_matching_goal(B,B2,GVA,GVB).
7048 inline_matching_goal(X,X,_,_).
7051 filter_mode([],_,_,[]).
7052 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7053 ( Var == V ->
7054 Modes = [M|MT],
7055 filter_mode(Rest,R,Ms,MT)
7056 ;
7057 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7058 ).
7060 filter_append([],VarDict,VarDict).
7061 filter_append([X|Xs],VarDict,NVarDict) :-
7062 ( X = silent(_) ->
7063 filter_append(Xs,VarDict,NVarDict)
7064 ;
7065 NVarDict = [X|NVarDict0],
7066 filter_append(Xs,VarDict,NVarDict0)
7067 ).
7069 check_unique_keys([],_).
7070 check_unique_keys([V|Vs],Dict) :-
7071 lookup_eq(Dict,V,_),
7072 check_unique_keys(Vs,Dict).
7074 % Generates tests to ensure the found constraint differs from previously found constraints
7075 % TODO: detect more cases where constraints need be different
7076 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7077 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7078 list2conj(DiffSuspGoalList,DiffSuspGoals).
7080 different_from_other_susps_(_,[],_,_,[]) :- !.
7081 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7082 ( functor(Head,F,A), functor(PreHead,F,A),
7083 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7084 \+ \+ PreHeadCopy = HeadCopy ->
7086 List = [Susp \== PreSusp | Tail]
7087 ;
7088 List = Tail
7089 ),
7090 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7092 % passive_head_via(in,in,in,in,out,out,out) :-
7093 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7094 functor(Head,F,A),
7095 get_constraint_index(F/A,Pos),
7096 /* which static variables may contain runtime variables */
7097 common_variables(Head,PrevHeads,CommonVars0),
7098 ground_vars([Head],GroundVars),
7099 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7100 /********************************************************/
7101 global_list_store_name(F/A,Name),
7102 GlobalGoal = nb_getval(Name,AllSusps),
7103 get_constraint_mode(F/A,ArgModes),
7104 ( Vars == [] ->
7105 Goal = GlobalGoal
7106 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7107 translate([CommonVar],VarDict,[Var]),
7108 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7109 Goal = AttrGoal
7110 ;
7111 translate(CommonVars,VarDict,Vars),
7112 add_heads_types(PrevHeads,[],TypeDict),
7113 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7114 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7115 Goal =
7116 ( ViaGoal ->
7117 AttrGoal
7118 ;
7119 GlobalGoal
7120 )
7121 ).
7123 common_variables(T,Ts,Vs) :-
7124 term_variables(T,V1),
7125 term_variables(Ts,V2),
7126 intersect_eq(V1,V2,Vs).
7128 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7129 via_goal(Vars,TypeDict,ViaGoal,Var),
7130 get_target_module(Mod),
7131 AttrGoal =
7132 ( get_attr(Var,Mod,TSusps),
7133 TSuspsEqSusps % TSusps = Susps
7134 ),
7135 get_max_constraint_index(N),
7136 ( N == 1 ->
7137 TSuspsEqSusps = true, % TSusps = Susps
7138 AllSusps = TSusps
7139 ;
7140 get_constraint_index(FA,Pos),
7141 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7142 ).
7143 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7144 ( Vars = [] ->
7145 ViaGoal = fail
7146 ; Vars = [A] ->
7147 lookup_eq(TypeDict,A,Type),
7148 ( atomic_type(Type) ->
7149 ViaGoal = var(A),
7150 A = Var
7151 ;
7152 ViaGoal = 'chr newvia_1'(A,Var)
7153 )
7154 ; Vars = [A,B] ->
7155 ViaGoal = 'chr newvia_2'(A,B,Var)
7156 ;
7157 ViaGoal = 'chr newvia'(Vars,Var)
7158 ).
7159 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7160 get_target_module(Mod),
7161 AttrGoal =
7162 ( get_attr(Var,Mod,TSusps),
7163 TSuspsEqSusps % TSusps = Susps
7164 ),
7165 get_max_constraint_index(N),
7166 ( N == 1 ->
7167 TSuspsEqSusps = true, % TSusps = Susps
7168 AllSusps = TSusps
7169 ;
7170 get_constraint_index(FA,Pos),
7171 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7172 ).
7174 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7175 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7176 list2conj(GuardCopyList,GuardCopy).
7178 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7179 Rule = rule(_,H,Guard,Body),
7180 conj2list(Guard,GuardList),
7181 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7182 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7184 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7185 term_variables(RestGuardList,GuardVars),
7186 term_variables(RestGuardListCopyCore,GuardCopyVars),
7187 % variables that are declared to be ground don't need to be locked
7188 ground_vars(H,GroundVars),
7189 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7190 ( chr_pp_flag(guard_locks,on),
7191 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7192 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7193 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7194 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7195 ),
7196 LocksUnlocks) ->
7197 once(pairup(Locks,Unlocks,LocksUnlocks))
7198 ;
7199 Locks = [],
7200 Unlocks = []
7201 ),
7202 list2conj(Locks,LockPhase),
7203 list2conj(Unlocks,UnlockPhase),
7204 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7205 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7206 my_term_copy(Body,VarDict2,BodyCopy).
7209 split_off_simple_guard([],_,[],[]).
7210 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7211 ( simple_guard(G,VarDict) ->
7212 S = [G|Ss],
7213 split_off_simple_guard(Gs,VarDict,Ss,C)
7214 ;
7215 S = [],
7216 C = [G|Gs]
7217 ).
7219 % simple guard: cheap and benign (does not bind variables)
7220 simple_guard(G,VarDict) :-
7221 binds_b(G,Vars),
7222 \+ (( member(V,Vars),
7223 lookup_eq(VarDict,V,_)
7224 )).
7226 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7227 functor(Head,F,A),
7228 C = F/A,
7229 ( is_stored(C) ->
7230 (
7231 (
7232 Id == [0], chr_pp_flag(store_in_guards, off)
7233 ;
7234 ( get_allocation_occurrence(C,AO),
7235 get_max_occurrence(C,MO),
7236 MO < AO )
7237 ),
7238 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7239 SuspDetachment = true
7240 ;
7241 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7242 ( chr_pp_flag(late_allocation,on) ->
7243 SuspDetachment =
7244 ( var(Susp) ->
7245 true
7246 ;
7247 UnCondSuspDetachment
7248 )
7249 ;
7250 SuspDetachment = UnCondSuspDetachment
7251 )
7252 )
7253 ;
7254 SuspDetachment = true
7255 ).
7257 partner_constraint_detachments([],[],_,true).
7258 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7259 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7260 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7262 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7263 functor(Head,F,A),
7264 C = F/A,
7265 ( is_stored(C) ->
7266 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7267 ( chr_pp_flag(debugable,on) ->
7268 DebugEvent = 'chr debug_event'(remove(Susp))
7269 ;
7270 DebugEvent = true
7271 ),
7272 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7273 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7274 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7275 detach_constraint_atom(C,Vars,Susp,Detach)
7276 ;
7277 Detach = true
7278 )
7279 ;
7280 SuspDetachment = true
7281 ).
7283 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7285 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7286 %% ____ _ _ _ _
7287 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7288 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7289 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7290 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7291 %% |_| |___/
7292 %% {{{
7294 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7295 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7296 Rule = rule(_Heads,Heads2,Guard,Body),
7298 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7299 get_constraint_mode(F/A,Mode),
7300 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7302 build_head(F,A,Id,HeadVars,ClauseHead),
7304 append(RestHeads,Heads2,Heads),
7305 append(OtherIDs,Heads2IDs,IDs),
7306 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7308 guard_splitting(Rule,GuardList0),
7309 ( is_stored_in_guard(F/A, RuleNb) ->
7310 GuardList = [Hole1|GuardList0]
7311 ;
7312 GuardList = GuardList0
7313 ),
7314 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7316 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7317 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7319 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7321 ( is_stored_in_guard(F/A, RuleNb) ->
7322 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7323 GuardCopyList = [Hole1Copy|_],
7324 Hole1Copy = Attachment
7325 ;
7326 true
7327 ),
7329 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7330 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7331 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7333 ( chr_pp_flag(debugable,on) ->
7334 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7335 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7336 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7337 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7338 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7339 instrument_goal((!),DebugTry,DebugApply,Cut)
7340 ;
7341 Cut = (!)
7342 ),
7344 Clause = ( ClauseHead :-
7345 FirstMatching,
7346 RescheduledTest,
7347 Cut,
7348 SuspsDetachments,
7349 SuspDetachment,
7350 BodyCopy
7351 ),
7352 add_location(Clause,RuleNb,LocatedClause),
7353 L = [LocatedClause | T].
7355 % }}}
7357 split_by_ids([],[],_,[],[]).
7358 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7359 ( memberchk_eq(I,I1s) ->
7360 S1s = [S | R1s],
7361 S2s = R2s
7362 ;
7363 S1s = R1s,
7364 S2s = [S | R2s]
7365 ),
7366 split_by_ids(Is,Ss,I1s,R1s,R2s).
7368 split_by_ids([],[],_,[],[],[],[]).
7369 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7370 ( memberchk_eq(I,I1s) ->
7371 S1s = [S | R1s],
7372 SI1s = [I|RSI1s],
7373 S2s = R2s,
7374 SI2s = RSI2s
7375 ;
7376 S1s = R1s,
7377 SI1s = RSI1s,
7378 S2s = [S | R2s],
7379 SI2s = [I|RSI2s]
7380 ),
7381 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7386 %% ____ _ _ _ ____
7387 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7388 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7389 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7390 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7391 %% |_| |___/
7393 %% Genereate prelude + worker predicate
7394 %% prelude calls worker
7395 %% worker iterates over one type of removed constraints
7396 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7397 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7398 Rule = rule(Heads1,_,Guard,Body),
7399 append(Heads1,RestHeads2,Heads),
7400 append(IDs1,RestIDs,IDs),
7401 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7402 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7403 extend_id(Id,Id1),
7404 ( memberchk_eq(NID,IDs2) ->
7405 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7406 ;
7407 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7408 ),
7409 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7410 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7412 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7413 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7414 Heads = [Head|RHeads],
7415 inc_id(Id,Id1),
7416 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7417 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7418 ( memberchk_eq(ID,IDs2) ->
7419 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7420 ;
7421 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7422 ).
7424 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7425 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7426 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7427 build_head(F,A,Id1,VarsSusp,ClauseHead),
7428 get_constraint_mode(F/A,Mode),
7429 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7431 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7433 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7435 extend_id(Id1,DelegateId),
7436 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7437 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7438 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7440 PreludeClause =
7441 ( ClauseHead :-
7442 FirstMatching,
7443 ModConstraintsGoal,
7444 !,
7445 ConstraintAllocationGoal,
7446 Delegate
7447 ),
7448 add_dummy_location(PreludeClause,LocatedPreludeClause),
7449 L = [LocatedPreludeClause|T].
7451 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7452 Term =.. [_|Args],
7453 delegate_variables(Term,Terms,VarDict,Args,Vars).
7455 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7456 term_variables(PrevTerms,PrevVars),
7457 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7459 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7460 term_variables(Term,V1),
7461 term_variables(Terms,V2),
7462 intersect_eq(V1,V2,V3),
7463 list_difference_eq(V3,PrevVars,V4),
7464 translate(V4,VarDict,Vars).
7467 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7468 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7469 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7470 Rule = rule(_,_,Guard,Body),
7471 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7473 gen_var(OtherSusp),
7474 gen_var(OtherSusps),
7476 functor(CurrentHead,OtherF,OtherA),
7477 gen_vars(OtherA,OtherVars),
7478 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7479 get_constraint_mode(OtherF/OtherA,Mode),
7480 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7482 delay_phase_end(validate_store_type_assumptions,
7483 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7484 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7485 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7486 )
7487 ),
7488 % create_get_mutable_ref(active,State,GetMutable),
7489 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7490 CurrentSuspTest = (
7491 OtherSusp = OtherSuspension,
7492 GetState,
7493 DiffSuspGoals,
7494 FirstMatching
7495 ),
7497 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7498 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7500 guard_splitting(Rule,GuardList0),
7501 ( is_stored_in_guard(F/A, RuleNb) ->
7502 GuardList = [Hole1|GuardList0]
7503 ;
7504 GuardList = GuardList0
7505 ),
7506 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7508 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7509 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7510 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7512 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7514 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7515 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7516 RecursiveVars2 = [[]|PreVarsAndSusps],
7517 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7519 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7520 ( is_stored_in_guard(F/A, RuleNb) ->
7521 GuardCopyList = [GuardAttachment|_] % once( ) ??
7522 ;
7523 true
7524 ),
7526 ( is_observed(F/A,O) ->
7527 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7528 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7529 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7530 ;
7531 Attachment = true,
7532 ConditionalRecursiveCall = RecursiveCall,
7533 ConditionalRecursiveCall2 = RecursiveCall2
7534 ),
7536 ( chr_pp_flag(debugable,on) ->
7537 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7538 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7539 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7540 ;
7541 DebugTry = true,
7542 DebugApply = true
7543 ),
7545 ( is_stored_in_guard(F/A, RuleNb) ->
7546 GuardAttachment = Attachment,
7547 BodyAttachment = true
7548 ;
7549 GuardAttachment = true,
7550 BodyAttachment = Attachment % will be true if not observed at all
7551 ),
7553 ( member(unique(ID1,UniqueKeys), Pragmas),
7554 check_unique_keys(UniqueKeys,VarDict) ->
7555 Clause =
7556 ( ClauseHead :-
7557 ( CurrentSuspTest ->
7558 ( RescheduledTest,
7559 DebugTry ->
7560 DebugApply,
7561 Susps1Detachments,
7562 BodyAttachment,
7563 BodyCopy,
7564 ConditionalRecursiveCall2
7565 ;
7566 RecursiveCall2
7567 )
7568 ;
7569 RecursiveCall
7570 )
7571 )
7572 ;
7573 Clause =
7574 ( ClauseHead :-
7575 ( CurrentSuspTest,
7576 RescheduledTest,
7577 DebugTry ->
7578 DebugApply,
7579 Susps1Detachments,
7580 BodyAttachment,
7581 BodyCopy,
7582 ConditionalRecursiveCall
7583 ;
7584 RecursiveCall
7585 )
7586 )
7587 ),
7588 add_location(Clause,RuleNb,LocatedClause),
7589 L = [LocatedClause | T].
7591 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7592 ( may_trigger(FA) ->
7593 does_use_field(FA,generation),
7594 delay_phase_end(validate_store_type_assumptions,
7595 ( static_suspension_term(FA,Suspension),
7596 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7597 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7598 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7599 )
7600 )
7601 ;
7602 delay_phase_end(validate_store_type_assumptions,
7603 ( static_suspension_term(FA,Suspension),
7604 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7605 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7606 )
7607 ),
7608 GetGeneration = true
7609 ),
7610 ConditionalCall =
7611 ( Susp = Suspension,
7612 GetState,
7613 GetGeneration ->
7614 UpdateState,
7615 Call
7616 ;
7617 true
7618 ).
7620 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7623 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7624 %% ____ _ _
7625 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7626 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7627 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7628 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7629 %% |_| |___/
7631 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7632 ( RestHeads == [] ->
7633 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7634 ;
7635 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7636 ).
7637 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7638 %% Single headed propagation
7639 %% everything in a single clause
7640 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7641 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7642 build_head(F,A,Id,VarsSusp,ClauseHead),
7644 inc_id(Id,NextId),
7645 build_head(F,A,NextId,VarsSusp,NextHead),
7647 get_constraint_mode(F/A,Mode),
7648 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7649 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7651 % - recursive call -
7652 RecursiveCall = NextHead,
7654 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7655 ActualCut = true
7656 ;
7657 ActualCut = !
7658 ),
7660 Rule = rule(_,_,Guard,Body),
7661 ( chr_pp_flag(debugable,on) ->
7662 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7663 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7664 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7665 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7666 ;
7667 Cut = ActualCut
7668 ),
7669 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7670 use_auxiliary_predicate(novel_production),
7671 use_auxiliary_predicate(extend_history),
7672 does_use_history(F/A,O),
7673 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7675 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7676 ( HistoryIDs == [] ->
7677 empty_named_history_novel_production(HistoryName,NovelProduction),
7678 empty_named_history_extend_history(HistoryName,ExtendHistory)
7679 ;
7680 Tuple = HistoryName
7681 )
7682 ;
7683 Tuple = RuleNb
7684 ),
7686 ( var(NovelProduction) ->
7687 NovelProduction = '$novel_production'(Susp,Tuple),
7688 ExtendHistory = '$extend_history'(Susp,Tuple)
7689 ;
7690 true
7691 ),
7693 ( is_observed(F/A,O) ->
7694 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7695 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7696 ;
7697 Attachment = true,
7698 ConditionalRecursiveCall = RecursiveCall
7699 )
7700 ;
7701 Allocation = true,
7702 NovelProduction = true,
7703 ExtendHistory = true,
7705 ( is_observed(F/A,O) ->
7706 get_allocation_occurrence(F/A,AllocO),
7707 ( O == AllocO ->
7708 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7709 Generation = 0
7710 ; % more room for improvement?
7711 Attachment = (Attachment1, Attachment2),
7712 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7713 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7714 ),
7715 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7716 ;
7717 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7718 ConditionalRecursiveCall = RecursiveCall
7719 )
7720 ),
7722 ( is_stored_in_guard(F/A, RuleNb) ->
7723 GuardAttachment = Attachment,
7724 BodyAttachment = true
7725 ;
7726 GuardAttachment = true,
7727 BodyAttachment = Attachment % will be true if not observed at all
7728 ),
7730 Clause = (
7731 ClauseHead :-
7732 HeadMatching,
7733 Allocation,
7734 NovelProduction,
7735 GuardAttachment,
7736 GuardCopy,
7737 Cut,
7738 ExtendHistory,
7739 BodyAttachment,
7740 BodyCopy,
7741 ConditionalRecursiveCall
7742 ),
7743 add_location(Clause,RuleNb,LocatedClause),
7744 ProgramList = [LocatedClause | ProgramTail].
7746 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7747 %% multi headed propagation
7748 %% prelude + predicates to accumulate the necessary combinations of suspended
7749 %% constraints + predicate to execute the body
7750 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7751 RestHeads = [First|Rest],
7752 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7753 extend_id(Id,ExtendedId),
7754 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7756 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7757 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7758 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7759 build_head(F,A,Id,VarsSusp,PreludeHead),
7760 get_constraint_mode(F/A,Mode),
7761 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7762 Rule = rule(_,_,Guard,Body),
7763 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7765 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7767 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7769 extend_id(Id,NestedId),
7770 append([Susps|VarsSusp],ExtraVars,NestedVars),
7771 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7772 NestedCall = NestedHead,
7774 Prelude = (
7775 PreludeHead :-
7776 FirstMatching,
7777 FirstSuspGoal,
7778 !,
7779 CondAllocation,
7780 NestedCall
7781 ),
7782 add_dummy_location(Prelude,LocatedPrelude),
7783 L = [LocatedPrelude|T].
7785 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7786 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7787 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7788 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7790 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7791 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7792 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7793 inc_id(Id,IncId),
7794 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7796 %check_fd_lookup_condition(_,_,_,_) :- fail.
7797 check_fd_lookup_condition(F,A,_,_) :-
7798 get_store_type(F/A,global_singleton), !.
7799 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7800 \+ may_trigger(F/A),
7801 get_functional_dependency(F/A,1,P,K),
7802 copy_term(P-K,CurrentHead-Key),
7803 term_variables(PreHeads,PreVars),
7804 intersect_eq(Key,PreVars,Key),!.
7806 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7807 Rule = rule(_,H2,Guard,Body),
7808 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7809 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7810 init(AllSusps,RestSusps),
7811 last(AllSusps,Susp),
7812 gen_var(OtherSusp),
7813 gen_var(OtherSusps),
7814 functor(CurrentHead,OtherF,OtherA),
7815 gen_vars(OtherA,OtherVars),
7816 delay_phase_end(validate_store_type_assumptions,
7817 ( static_suspension_term(OtherF/OtherA,Suspension),
7818 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7819 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7820 )
7821 ),
7822 % create_get_mutable_ref(active,State,GetMutable),
7823 CurrentSuspTest = (
7824 OtherSusp = Suspension,
7825 GetState
7826 ),
7827 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7828 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7829 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7830 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7831 RecursiveVars = PreVarsAndSusps1
7832 ;
7833 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7834 PrevId0 = Id
7835 ),
7836 ( PrevId0 = [_] ->
7837 PrevId = PrevId0
7838 ;
7839 PrevId = [O|PrevId0]
7840 ),
7841 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7842 RecursiveCall = RecursiveHead,
7843 CurrentHead =.. [_|OtherArgs],
7844 pairup(OtherArgs,OtherVars,OtherPairs),
7845 get_constraint_mode(OtherF/OtherA,Mode),
7846 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7848 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7849 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7850 get_occurrence(F/A,O,_,ID),
7852 ( is_observed(F/A,O) ->
7853 init(FirstVarsSusp,FirstVars),
7854 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7855 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7856 ;
7857 Attachment = true,
7858 ConditionalRecursiveCall = RecursiveCall
7859 ),
7860 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7861 NovelProduction = true,
7862 ExtendHistory = true
7863 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7864 NovelProduction = true,
7865 ExtendHistory = true
7866 ;
7867 get_occurrence(F/A,O,_,ID),
7868 use_auxiliary_predicate(novel_production),
7869 use_auxiliary_predicate(extend_history),
7870 does_use_history(F/A,O),
7871 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7872 ( HistoryIDs == [] ->
7873 empty_named_history_novel_production(HistoryName,NovelProduction),
7874 empty_named_history_extend_history(HistoryName,ExtendHistory)
7875 ;
7876 reverse([OtherSusp|RestSusps],NamedSusps),
7877 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7878 HistorySusps = [HistorySusp|_],
7880 ( length(HistoryIDs, 1) ->
7881 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7882 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7883 ;
7884 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7885 Tuple =.. [t,HistoryName|HistorySusps]
7886 )
7887 )
7888 ;
7889 HistorySusp = Susp,
7890 maplist(extract_symbol,H2,ConstraintSymbols),
7891 sort([ID|RestIDs],HistoryIDs),
7892 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7893 Tuple =.. [t,RuleNb|HistorySusps]
7894 ),
7896 ( var(NovelProduction) ->
7897 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7898 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7899 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7900 ;
7901 true
7902 )
7903 ),
7906 ( chr_pp_flag(debugable,on) ->
7907 Rule = rule(_,_,Guard,Body),
7908 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7909 get_occurrence(F/A,O,_,ID),
7910 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7911 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7912 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7913 ;
7914 DebugTry = true,
7915 DebugApply = true
7916 ),
7918 ( is_stored_in_guard(F/A, RuleNb) ->
7919 GuardAttachment = Attachment,
7920 BodyAttachment = true
7921 ;
7922 GuardAttachment = true,
7923 BodyAttachment = Attachment % will be true if not observed at all
7924 ),
7926 Clause = (
7927 ClauseHead :-
7928 ( CurrentSuspTest,
7929 DiffSuspGoals,
7930 Matching,
7931 NovelProduction,
7932 GuardAttachment,
7933 GuardCopy,
7934 DebugTry ->
7935 DebugApply,
7936 ExtendHistory,
7937 BodyAttachment,
7938 BodyCopy,
7939 ConditionalRecursiveCall
7940 ; RecursiveCall
7941 )
7942 ),
7943 add_location(Clause,RuleNb,LocatedClause),
7944 L = [LocatedClause|T].
7946 extract_symbol(Head,F/A) :-
7947 functor(Head,F,A).
7949 novel_production_calls([],[],[],_,_,true).
7950 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7951 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7952 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7953 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7955 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7956 reverse(ReversedRestSusps,RestSusps),
7957 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7959 named_history_susps([],_,_,[]).
7960 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7961 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7962 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7966 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7967 !,
7968 functor(Head,F,A),
7969 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7970 get_constraint_mode(F/A,Mode),
7971 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7972 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7973 append(VarsSusp,ExtraVars,HeadVars).
7974 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7975 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7976 functor(Head,F,A),
7977 gen_var(Susps),
7978 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7979 get_constraint_mode(F/A,Mode),
7980 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7981 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7982 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7984 % returns
7985 % VarDict for the copies of variables in the original heads
7986 % VarsSuspsList list of lists of arguments for the successive heads
7987 % FirstVarsSusp top level arguments
7988 % SuspList list of all suspensions
7989 % Iterators list of all iterators
7990 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7991 !,
7992 functor(Head,F,A),
7993 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7994 get_constraint_mode(F/A,Mode),
7995 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7996 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7997 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7998 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7999 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
8000 functor(Head,F,A),
8001 gen_var(Susps),
8002 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8003 get_constraint_mode(F/A,Mode),
8004 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8005 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8006 append(HeadVars,[Susp,Susps],Vars).
8008 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8009 !,
8010 functor(Head,F,A),
8011 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8012 get_constraint_mode(F/A,Mode),
8013 head_arg_matches(Pairs,Mode,[],_,VarDict),
8014 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8015 append(VarsSusp,ExtraVars,HeadVars).
8016 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8017 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8018 functor(Head,F,A),
8019 gen_var(Susps),
8020 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8021 get_constraint_mode(F/A,Mode),
8022 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8023 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8024 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8026 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8028 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8029 %% ____ _ _ _ _
8030 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8031 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8032 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8033 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8034 %%
8035 %% ____ _ _ _
8036 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8037 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8038 %% | _ < __/ |_| | | | __/\ V / (_| | |
8039 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8040 %%
8041 %% ____ _ _
8042 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8043 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8044 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8045 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8046 %% |___/
8048 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8049 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8050 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8051 ;
8052 NRestHeads = RestHeads,
8053 NRestIDs = RestIDs
8054 ).
8056 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8057 term_variables(Head,Vars),
8058 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8059 copy_term_nat(InitialData,InitialDataCopy),
8060 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8061 InitialDataCopy = InitialData,
8062 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8063 reverse(RNRestHeads,NRestHeads),
8064 reverse(RNRestIDs,NRestIDs).
8066 final_data(Entry) :-
8067 Entry = entry(_,_,_,_,[],_).
8069 expand_data(Entry,NEntry,Cost) :-
8070 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8071 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8072 term_variables([Head1|Vars],Vars1),
8073 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8074 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8076 % Assigns score to head based on known variables and heads to lookup
8077 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8078 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8079 functor(Head,F,A),
8080 get_store_type(F/A,StoreType),
8081 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8082 % }}}
8084 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8085 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8086 term_variables(Head,HeadVars0),
8087 term_variables(RestHeads,RestVars),
8088 ground_vars([Head],GroundVars),
8089 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8090 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8091 NScore is min(CScore,Score).
8092 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8093 ( CScore =< 100 ->
8094 Score = CScore
8095 ;
8096 order_score_indexes(Indexes,Head,KnownVars,Score)
8097 ).
8098 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8099 ( CScore =< 100 ->
8100 Score = CScore
8101 ;
8102 order_score_indexes(Indexes,Head,KnownVars,Score)
8103 ).
8104 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8105 term_variables(Head,HeadVars),
8106 term_variables(RestHeads,RestVars),
8107 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8108 Score is Score_ * 200,
8109 NScore is min(CScore,Score).
8110 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8111 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8112 Score = 1. % guaranteed O(1)
8113 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8114 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8115 multi_order_score([],_,_,_,_,_,Score,Score).
8116 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8117 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8118 ; Score1 = Score0
8119 ),
8120 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8122 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8123 Score is min(CScore,10).
8124 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8125 Score is min(CScore,10).
8126 % }}}
8129 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8130 order_score_indexes(Indexes,Head,Vars,Score) :-
8131 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8132 numbervars(VarsCopy,0,_),
8133 order_score_indexes(Indexes,HeadCopy,Score).
8135 order_score_indexes([I|Is],Head,Score) :-
8136 args(I,Head,Args),
8137 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8138 Score = 100
8139 ;
8140 order_score_indexes(Is,Head,Score)
8141 ).
8142 % }}}
8144 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8146 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8147 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8148 ( K-R-O == 0-0-0 ->
8149 Score = 0
8150 ; K > 0 ->
8151 Score is max(10 - K,0)
8152 ; R > 0 ->
8153 Score is max(10 - R,1) * 100
8154 ;
8155 Score is max(10-O,1) * 1000
8156 ).
8157 order_score_count_vars([],_,_,0-0-0).
8158 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8159 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8160 ( memberchk_eq(V,KnownVars) ->
8161 NK is K + 1,
8162 NR = R, NO = O
8163 ; memberchk_eq(V,RestVars) ->
8164 NR is R + 1,
8165 NK = K, NO = O
8166 ;
8167 NO is O + 1,
8168 NK = K, NR = R
8169 ).
8171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8172 %% ___ _ _ _
8173 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8174 %% | || '_ \| | | '_ \| | '_ \ / _` |
8175 %% | || | | | | | | | | | | | | (_| |
8176 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8177 %% |___/
8179 %% SWI begin
8180 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8181 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8182 %% SWI end
8184 %% SICStus begin
8185 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8186 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8187 %% SICStus end
8189 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8191 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8192 %% _ _ _ _ _ _ _
8193 %% | | | | |_(_) (_) |_ _ _
8194 %% | | | | __| | | | __| | | |
8195 %% | |_| | |_| | | | |_| |_| |
8196 %% \___/ \__|_|_|_|\__|\__, |
8197 %% |___/
8199 % Create a fresh variable.
8200 gen_var(_).
8202 % Create =N= fresh variables.
8203 gen_vars(N,Xs) :-
8204 length(Xs,N).
8206 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8207 vars_susp(A,Vars,Susp,VarsSusp),
8208 Head =.. [_|Args],
8209 pairup(Args,Vars,HeadPairs).
8211 inc_id([N|Ns],[O|Ns]) :-
8212 O is N + 1.
8213 dec_id([N|Ns],[M|Ns]) :-
8214 M is N - 1.
8216 extend_id(Id,[0|Id]).
8218 next_id([_,N|Ns],[O|Ns]) :-
8219 O is N + 1.
8221 % return clause Head
8222 % for F/A constraint symbol, predicate identifier Id and arguments Head
8223 build_head(F,A,Id,Args,Head) :-
8224 buildName(F,A,Id,Name),
8225 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8226 ( may_trigger(F/A) ;
8227 get_allocation_occurrence(F/A,AO),
8228 get_max_occurrence(F/A,MO),
8229 MO >= AO ) ) ->
8230 Head =.. [Name|Args]
8231 ;
8232 init(Args,ArgsWOSusp), % XXX not entirely correct!
8233 Head =.. [Name|ArgsWOSusp]
8234 ).
8236 % return predicate name Result
8237 % for Fct/Aty constraint symbol and predicate identifier List
8238 buildName(Fct,Aty,List,Result) :-
8239 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8240 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8241 MO >= AO ) ; List \= [0])) ) ) ->
8242 atom_concat(Fct, '___' ,FctSlash),
8243 atomic_concat(FctSlash,Aty,FctSlashAty),
8244 buildName_(List,FctSlashAty,Result)
8245 ;
8246 Result = Fct
8247 ).
8249 buildName_([],Name,Name).
8250 buildName_([N|Ns],Name,Result) :-
8251 buildName_(Ns,Name,Name1),
8252 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8253 atomic_concat(NameDash,N,Result).
8255 vars_susp(A,Vars,Susp,VarsSusp) :-
8256 length(Vars,A),
8257 append(Vars,[Susp],VarsSusp).
8259 or_pattern(Pos,Pat) :-
8260 Pow is Pos - 1,
8261 Pat is 1 << Pow. % was 2 ** X
8263 and_pattern(Pos,Pat) :-
8264 X is Pos - 1,
8265 Y is 1 << X, % was 2 ** X
8266 Pat is (-1)*(Y + 1).
8268 make_name(Prefix,F/A,Name) :-
8269 atom_concat_list([Prefix,F,'___',A],Name).
8271 %===============================================================================
8272 % Attribute for attributed variables
8274 make_attr(N,Mask,SuspsList,Attr) :-
8275 length(SuspsList,N),
8276 Attr =.. [v,Mask|SuspsList].
8278 get_all_suspensions2(N,Attr,SuspensionsList) :-
8279 chr_pp_flag(dynattr,off), !,
8280 make_attr(N,_,SuspensionsList,Attr).
8282 % NEW
8283 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8284 % writeln(get_all_suspensions2),
8285 length(SuspensionsList,N),
8286 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8289 % NEW
8290 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8291 % writeln(normalize_attr),
8292 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8294 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8295 chr_pp_flag(dynattr,off), !,
8296 make_attr(N,_,SuspsList,Attr),
8297 nth1(Position,SuspsList,Suspensions).
8299 % NEW
8300 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8301 % writeln(get_suspensions),
8302 Goal =
8303 ( memberchk(Position-Suspensions,TAttr) ->
8304 true
8305 ;
8306 Suspensions = []
8307 ).
8309 %-------------------------------------------------------------------------------
8310 % +N: number of constraint symbols
8311 % +Suspension: source-level variable, for suspension
8312 % +Position: constraint symbol number
8313 % -Attr: source-level term, for new attribute
8314 singleton_attr(N,Suspension,Position,Attr) :-
8315 chr_pp_flag(dynattr,off), !,
8316 or_pattern(Position,Pattern),
8317 make_attr(N,Pattern,SuspsList,Attr),
8318 nth1(Position,SuspsList,[Suspension]),
8319 chr_delete(SuspsList,[Suspension],RestSuspsList),
8320 set_elems(RestSuspsList,[]).
8322 % NEW
8323 singleton_attr(N,Suspension,Position,Attr) :-
8324 % writeln(singleton_attr),
8325 Attr = [Position-[Suspension]].
8327 %-------------------------------------------------------------------------------
8328 % +N: number of constraint symbols
8329 % +Suspension: source-level variable, for suspension
8330 % +Position: constraint symbol number
8331 % +TAttr: source-level variable, for old attribute
8332 % -Goal: goal for creating new attribute
8333 % -NTAttr: source-level variable, for new attribute
8334 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8335 chr_pp_flag(dynattr,off), !,
8336 make_attr(N,Mask,SuspsList,Attr),
8337 or_pattern(Position,Pattern),
8338 nth1(Position,SuspsList,Susps),
8339 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8340 make_attr(N,Mask,SuspsList1,NewAttr1),
8341 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8342 make_attr(N,NewMask,SuspsList2,NewAttr2),
8343 Goal = (
8344 TAttr = Attr,
8345 ( Mask /\ Pattern =:= Pattern ->
8346 NTAttr = NewAttr1
8347 ;
8348 NewMask is Mask \/ Pattern,
8349 NTAttr = NewAttr2
8350 )
8351 ), !.
8353 % NEW
8354 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8355 % writeln(add_attr),
8356 Goal =
8357 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8358 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8359 ;
8360 NTAttr = [Position-[Suspension]|TAttr]
8361 ).
8363 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8364 chr_pp_flag(dynattr,off), !,
8365 or_pattern(Position,Pattern),
8366 and_pattern(Position,DelPattern),
8367 make_attr(N,Mask,SuspsList,Attr),
8368 nth1(Position,SuspsList,Susps),
8369 substitute_eq(Susps,SuspsList,[],SuspsList1),
8370 make_attr(N,NewMask,SuspsList1,Attr1),
8371 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8372 make_attr(N,Mask,SuspsList2,Attr2),
8373 get_target_module(Mod),
8374 Goal = (
8375 TAttr = Attr,
8376 ( Mask /\ Pattern =:= Pattern ->
8377 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8378 ( NewSusps == [] ->
8379 NewMask is Mask /\ DelPattern,
8380 ( NewMask == 0 ->
8381 del_attr(Var,Mod)
8382 ;
8383 put_attr(Var,Mod,Attr1)
8384 )
8385 ;
8386 put_attr(Var,Mod,Attr2)
8387 )
8388 ;
8389 true
8390 )
8391 ), !.
8393 % NEW
8394 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8395 % writeln(rem_attr),
8396 get_target_module(Mod),
8397 Goal =
8398 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8399 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8400 ( NSuspensions == [] ->
8401 ( RAttr == [] ->
8402 del_attr(Var,Mod)
8403 ;
8404 put_attr(Var,Mod,RAttr)
8405 )
8406 ;
8407 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8408 )
8409 ;
8410 true
8411 ).
8413 %-------------------------------------------------------------------------------
8414 % +N: number of constraint symbols
8415 % +TAttr1: source-level variable, for attribute
8416 % +TAttr2: source-level variable, for other attribute
8417 % -Goal: goal for merging the two attributes
8418 % -Attr: source-level term, for merged attribute
8419 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8420 chr_pp_flag(dynattr,off), !,
8421 make_attr(N,Mask1,SuspsList1,Attr1),
8422 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8423 Goal = (
8424 TAttr1 = Attr1,
8425 Goal2
8426 ).
8428 % NEW
8429 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8430 % writeln(merge_attributes),
8431 Goal = (
8432 sort(TAttr1,Sorted1),
8433 sort(TAttr2,Sorted2),
8434 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8435 ).
8438 %-------------------------------------------------------------------------------
8439 % +N: number of constraint symbols
8440 % +Mask1: ...
8441 % +SuspsList1: static term, for suspensions list
8442 % +TAttr2: source-level variable, for other attribute
8443 % -Goal: goal for merging the two attributes
8444 % -Attr: source-level term, for merged attribute
8445 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8446 make_attr(N,Mask2,SuspsList2,Attr2),
8447 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8448 list2conj(Gs,SortGoals),
8449 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8450 make_attr(N,Mask,SuspsList,Attr),
8451 Goal = (
8452 TAttr2 = Attr2,
8453 SortGoals,
8454 Mask is Mask1 \/ Mask2
8455 ).
8458 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8459 % Storetype dependent lookup
8461 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8462 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8463 %% -Goal,-SuspensionList) is det.
8464 %
8465 % Create a universal lookup goal for given head.
8466 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8467 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8468 functor(Head,F,A),
8469 get_store_type(F/A,StoreType),
8470 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8472 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8473 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8474 %% -Goal,-SuspensionList) is det.
8475 %
8476 % Create a universal lookup goal for given head.
8477 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8478 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8479 functor(Head,F,A),
8480 get_store_type(F/A,StoreType),
8481 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8483 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8484 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8485 %% +GroundVars,-Goal,-SuspensionList) is det.
8486 %
8487 % Create a universal lookup goal for given head.
8488 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8489 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8490 functor(Head,F,A),
8491 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8492 update_store_type(F/A,default).
8493 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8494 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8495 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8496 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8497 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8498 functor(Head,F,A),
8499 global_ground_store_name(F/A,StoreName),
8500 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8501 update_store_type(F/A,global_ground).
8502 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8503 arg(VarIndex,Head,OVar),
8504 arg(KeyIndex,Head,OKey),
8505 translate([OVar,OKey],VarDict,[Var,Key]),
8506 get_target_module(Module),
8507 Goal = (
8508 get_attr(Var,Module,AssocStore),
8509 lookup_assoc_store(AssocStore,Key,AllSusps)
8510 ).
8511 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8512 functor(Head,F,A),
8513 global_singleton_store_name(F/A,StoreName),
8514 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8515 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8516 update_store_type(F/A,global_singleton).
8517 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8518 once((
8519 member(ST,StoreTypes),
8520 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8521 )).
8522 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8523 functor(Head,F,A),
8524 arg(Index,Head,Var),
8525 translate([Var],VarDict,[KeyVar]),
8526 delay_phase_end(validate_store_type_assumptions,
8527 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8528 ),
8529 update_store_type(F/A,identifier_store(Index)),
8530 get_identifier_index(F/A,Index,_).
8531 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8532 functor(Head,F,A),
8533 arg(Index,Head,Var),
8534 ( var(Var) ->
8535 translate([Var],VarDict,[KeyVar]),
8536 Goal = StructGoal
8537 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8538 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8539 Goal = (LookupGoal,StructGoal)
8540 ),
8541 delay_phase_end(validate_store_type_assumptions,
8542 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8543 ),
8544 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8545 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8547 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8548 get_identifier_size(ISize),
8549 functor(Struct,struct,ISize),
8550 get_identifier_index(C,Index,IIndex),
8551 arg(IIndex,Struct,AllSusps),
8552 Goal = (KeyVar = Struct).
8554 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8555 type_indexed_identifier_structure(IndexType,Struct),
8556 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8557 arg(IIndex,Struct,AllSusps),
8558 Goal = (KeyVar = Struct).
8560 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8561 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8562 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8563 %
8564 % Create a universal hash lookup goal for given head.
8565 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8566 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8567 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8568 ( KeyArgCopies = [KeyCopy] ->
8569 true
8570 ;
8571 KeyCopy =.. [k|KeyArgCopies]
8572 ),
8573 functor(Head,F,A),
8574 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8576 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8577 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8579 Goal = (GroundCheck,LookupGoal),
8581 ( HashType == inthash ->
8582 update_store_type(F/A,multi_inthash([Index]))
8583 ;
8584 update_store_type(F/A,multi_hash([Index]))
8585 ).
8587 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8588 member(Index,Indexes),
8589 args(Index,Head,KeyArgs),
8590 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8591 !.
8593 % check whether we can copy the given terms
8594 % with the given dictionary, and, if so, do so
8595 key_in_scope([],VarDict,[]).
8596 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8597 term_variables(Arg,Vars),
8598 translate(Vars,VarDict,VarCopies),
8599 copy_term(Arg/Vars,ArgCopy/VarCopies),
8600 key_in_scope(Args,VarDict,ArgCopies).
8602 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8603 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8604 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8605 %% +VarArgDict,-NewVarArgDict) is det.
8606 %
8607 % Create existential lookup goal for given head.
8608 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8609 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8610 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8611 sbag_member_call(Susp,AllSusps,Sbag),
8612 functor(Head,F,A),
8613 delay_phase_end(validate_store_type_assumptions,
8614 ( static_suspension_term(F/A,SuspTerm),
8615 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8616 )
8617 ),
8618 Goal = (
8619 UniversalGoal,
8620 Sbag,
8621 Susp = SuspTerm,
8622 GetState
8623 ).
8624 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8625 functor(Head,F,A),
8626 global_singleton_store_name(F/A,StoreName),
8627 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8628 Goal = (
8629 GetStoreGoal, % nb_getval(StoreName,Susp),
8630 Susp \== [],
8631 Susp = SuspTerm
8632 ),
8633 update_store_type(F/A,global_singleton).
8634 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8635 once((
8636 member(ST,StoreTypes),
8637 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8638 )).
8639 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8640 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8641 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8642 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8643 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8644 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8645 hash_index_filter(Pairs,Index,NPairs),
8647 functor(Head,F,A),
8648 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8649 Sbag = (AllSusps = [Susp])
8650 ;
8651 sbag_member_call(Susp,AllSusps,Sbag)
8652 ),
8653 delay_phase_end(validate_store_type_assumptions,
8654 ( static_suspension_term(F/A,SuspTerm),
8655 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8656 )
8657 ),
8658 Goal = (
8659 LookupGoal,
8660 Sbag,
8661 Susp = SuspTerm, % not inlined
8662 GetState
8663 ).
8664 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8665 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8666 hash_index_filter(Pairs,Index,NPairs),
8668 functor(Head,F,A),
8669 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8670 Sbag = (AllSusps = [Susp])
8671 ;
8672 sbag_member_call(Susp,AllSusps,Sbag)
8673 ),
8674 delay_phase_end(validate_store_type_assumptions,
8675 ( static_suspension_term(F/A,SuspTerm),
8676 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8677 )
8678 ),
8679 Goal = (
8680 LookupGoal,
8681 Sbag,
8682 Susp = SuspTerm, % not inlined
8683 GetState
8684 ).
8685 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8686 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8687 sbag_member_call(Susp,Susps,Sbag),
8688 functor(Head,F,A),
8689 delay_phase_end(validate_store_type_assumptions,
8690 ( static_suspension_term(F/A,SuspTerm),
8691 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8692 )
8693 ),
8694 Goal = (
8695 UGoal,
8696 Sbag,
8697 Susp = SuspTerm, % not inlined
8698 GetState
8699 ).
8701 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8702 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8703 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8704 %% +VarArgDict,-NewVarArgDict) is det.
8705 %
8706 % Create existential hash lookup goal for given head.
8707 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8708 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8709 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8711 hash_index_filter(Pairs,Index,NPairs),
8713 functor(Head,F,A),
8714 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8715 Sbag = (AllSusps = [Susp])
8716 ;
8717 sbag_member_call(Susp,AllSusps,Sbag)
8718 ),
8719 delay_phase_end(validate_store_type_assumptions,
8720 ( static_suspension_term(F/A,SuspTerm),
8721 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8722 )
8723 ),
8724 Goal = (
8725 LookupGoal,
8726 Sbag,
8727 Susp = SuspTerm, % not inlined
8728 GetState
8729 ).
8731 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8732 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8733 %
8734 % Filter out pairs already covered by given hash index.
8735 % makes them 'silent'
8736 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8737 hash_index_filter(Pairs,Index,NPairs) :-
8738 hash_index_filter(Pairs,Index,1,NPairs).
8740 hash_index_filter([],_,_,[]).
8741 hash_index_filter([P|Ps],Index,N,NPairs) :-
8742 ( Index = [I|Is] ->
8743 NN is N + 1,
8744 ( I > N ->
8745 NPairs = [P|NPs],
8746 hash_index_filter(Ps,[I|Is],NN,NPs)
8747 ; I == N ->
8748 NPairs = [silent(P)|NPs],
8749 hash_index_filter(Ps,Is,NN,NPs)
8750 )
8751 ;
8752 NPairs = [P|Ps]
8753 ).
8755 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8756 %------------------------------------------------------------------------------%
8757 %% assume_constraint_stores(+ConstraintSymbols) is det.
8758 %
8759 % Compute all constraint store types that are possible for the given
8760 % =ConstraintSymbols=.
8761 %------------------------------------------------------------------------------%
8762 assume_constraint_stores([]).
8763 assume_constraint_stores([C|Cs]) :-
8764 ( chr_pp_flag(debugable,off),
8765 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8766 is_stored(C),
8767 get_store_type(C,default) ->
8768 get_indexed_arguments(C,AllIndexedArgs),
8769 get_constraint_mode(C,Modes),
8770 aggregate_all(bag(Index)-count,
8771 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8772 IndexedArgs-NbIndexedArgs),
8773 % Construct Index Combinations
8774 ( NbIndexedArgs > 10 ->
8775 findall([Index],member(Index,IndexedArgs),Indexes)
8776 ;
8777 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8778 predsort(longer_list,UnsortedIndexes,Indexes)
8779 ),
8780 % EXPERIMENTAL HEURISTIC
8781 % findall(Index, (
8782 % member(Arg1,IndexedArgs),
8783 % member(Arg2,IndexedArgs),
8784 % Arg1 =< Arg2,
8785 % sort([Arg1,Arg2], Index)
8786 % ), UnsortedIndexes),
8787 % predsort(longer_list,UnsortedIndexes,Indexes),
8788 % Choose Index Type
8789 ( get_functional_dependency(C,1,Pattern,Key),
8790 all_distinct_var_args(Pattern), Key == [] ->
8791 assumed_store_type(C,global_singleton)
8792 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8793 get_constraint_type_det(C,ArgTypes),
8794 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8796 ( IntHashIndexes = [] ->
8797 Stores = Stores1
8798 ;
8799 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8800 ),
8801 ( HashIndexes = [] ->
8802 Stores1 = Stores2
8803 ;
8804 Stores1 = [multi_hash(HashIndexes)|Stores2]
8805 ),
8806 ( IdentifierIndexes = [] ->
8807 Stores2 = Stores3
8808 ;
8809 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8810 append(WrappedIdentifierIndexes,Stores3,Stores2)
8811 ),
8812 append(CompoundIdentifierIndexes,Stores4,Stores3),
8813 ( only_ground_indexed_arguments(C)
8814 -> Stores4 = [global_ground]
8815 ; Stores4 = [default]
8816 ),
8817 assumed_store_type(C,multi_store(Stores))
8818 ; true
8819 )
8820 ;
8821 true
8822 ),
8823 assume_constraint_stores(Cs).
8825 %------------------------------------------------------------------------------%
8826 %% partition_indexes(+Indexes,+Types,
8827 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8828 %------------------------------------------------------------------------------%
8829 partition_indexes([],_,[],[],[],[]).
8830 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8831 ( Index = [I],
8832 nth1(I,Types,Type),
8833 unalias_type(Type,UnAliasedType),
8834 UnAliasedType == chr_identifier ->
8835 IdentifierIndexes = [I|RIdentifierIndexes],
8836 IntHashIndexes = RIntHashIndexes,
8837 HashIndexes = RHashIndexes,
8838 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8839 ; Index = [I],
8840 nth1(I,Types,Type),
8841 unalias_type(Type,UnAliasedType),
8842 nonvar(UnAliasedType),
8843 UnAliasedType = chr_identifier(IndexType) ->
8844 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8845 IdentifierIndexes = RIdentifierIndexes,
8846 IntHashIndexes = RIntHashIndexes,
8847 HashIndexes = RHashIndexes
8848 ; Index = [I],
8849 nth1(I,Types,Type),
8850 unalias_type(Type,UnAliasedType),
8851 UnAliasedType == dense_int ->
8852 IntHashIndexes = [Index|RIntHashIndexes],
8853 HashIndexes = RHashIndexes,
8854 IdentifierIndexes = RIdentifierIndexes,
8855 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8856 ; member(I,Index),
8857 nth1(I,Types,Type),
8858 unalias_type(Type,UnAliasedType),
8859 nonvar(UnAliasedType),
8860 UnAliasedType = chr_identifier(_) ->
8861 % don't use chr_identifiers in hash indexes
8862 IntHashIndexes = RIntHashIndexes,
8863 HashIndexes = RHashIndexes,
8864 IdentifierIndexes = RIdentifierIndexes,
8865 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8866 ;
8867 IntHashIndexes = RIntHashIndexes,
8868 HashIndexes = [Index|RHashIndexes],
8869 IdentifierIndexes = RIdentifierIndexes,
8870 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8871 ),
8872 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8874 longer_list(R,L1,L2) :-
8875 length(L1,N1),
8876 length(L2,N2),
8877 compare(Rt,N2,N1),
8878 ( Rt == (=) ->
8879 compare(R,L1,L2)
8880 ;
8881 R = Rt
8882 ).
8884 all_distinct_var_args(Term) :-
8885 copy_term_nat(Term,TermCopy),
8886 functor(Term,F,A),
8887 functor(Pattern,F,A),
8888 Pattern =@= TermCopy.
8890 get_indexed_arguments(C,IndexedArgs) :-
8891 C = F/A,
8892 get_indexed_arguments(1,A,C,IndexedArgs).
8894 get_indexed_arguments(I,N,C,L) :-
8895 ( I > N ->
8896 L = []
8897 ; ( is_indexed_argument(C,I) ->
8898 L = [I|T]
8899 ;
8900 L = T
8901 ),
8902 J is I + 1,
8903 get_indexed_arguments(J,N,C,T)
8904 ).
8906 validate_store_type_assumptions([]).
8907 validate_store_type_assumptions([C|Cs]) :-
8908 validate_store_type_assumption(C),
8909 validate_store_type_assumptions(Cs).
8911 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8912 % new code generation
8913 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8914 Rule = rule(H1,_,Guard,Body),
8915 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8916 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8917 flatten(VarsAndSuspsList,VarsAndSusps),
8918 Vars = [ [] | VarsAndSusps],
8919 build_head(F,A,[O|Id],Vars,Head),
8920 ( PrevId0 = [_] ->
8921 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8922 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8923 PrevId = [PredictedPrevId] % PrevId = PrevId0
8924 ;
8925 PrevId = [O|PrevId0]
8926 ),
8927 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8928 Clause = ( Head :- PredecessorCall),
8929 add_dummy_location(Clause,LocatedClause),
8930 L = [LocatedClause | T].
8931 % ( H1 == [],
8932 % functor(CurrentHead,CF,CA),
8933 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8934 % L = T
8935 % ;
8936 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8937 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8938 % flatten(VarsAndSuspsList,VarsAndSusps),
8939 % Vars = [ [] | VarsAndSusps],
8940 % build_head(F,A,Id,Vars,Head),
8941 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8942 % Clause = ( Head :- PredecessorCall),
8943 % L = [Clause | T]
8944 % ).
8946 % skips back intelligently over global_singleton lookups
8947 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8948 ( Id = [0|_] ->
8949 % TOM: add partial success continuation optimization here!
8950 next_id(Id,PrevId),
8951 PrevVarsAndSusps = BaseCallArgs
8952 ;
8953 VarsAndSuspsList = [_|AllButFirstList],
8954 dec_id(Id,PrevId1),
8955 ( PrevHeads = [PrevHead|PrevHeads1],
8956 functor(PrevHead,F,A),
8957 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8958 PrevIterators = [_|PrevIterators1],
8959 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8960 ;
8961 PrevId = PrevId1,
8962 flatten(AllButFirstList,AllButFirst),
8963 PrevIterators = [PrevIterator|_],
8964 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8965 )
8966 ).
8968 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8969 Rule = rule(_,_,Guard,Body),
8970 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8971 init(AllSusps,PreSusps),
8972 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8973 gen_var(OtherSusps),
8974 functor(CurrentHead,OtherF,OtherA),
8975 gen_vars(OtherA,OtherVars),
8976 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8977 get_constraint_mode(OtherF/OtherA,Mode),
8978 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8980 delay_phase_end(validate_store_type_assumptions,
8981 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8982 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8983 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8984 )
8985 ),
8987 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8988 % create_get_mutable_ref(active,State,GetMutable),
8989 CurrentSuspTest = (
8990 OtherSusp = OtherSuspension,
8991 GetState,
8992 DiffSuspGoals,
8993 FirstMatching
8994 ),
8995 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8996 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8997 inc_id(Id,NestedId),
8998 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8999 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
9000 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
9001 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
9002 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9004 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9005 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9006 RecursiveVars = PreVarsAndSusps1
9007 ;
9008 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9009 PrevId0 = Id
9010 ),
9011 ( PrevId0 = [_] ->
9012 PrevId = PrevId0
9013 ;
9014 PrevId = [O|PrevId0]
9015 ),
9016 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9018 Clause = (
9019 ClauseHead :-
9020 ( CurrentSuspTest,
9021 NextSuspGoal
9022 ->
9023 NestedHead
9024 ; RecursiveHead
9025 )
9026 ),
9027 add_dummy_location(Clause,LocatedClause),
9028 L = [LocatedClause|T].
9030 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9032 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9033 % Observation Analysis
9034 %
9035 % CLASSIFICATION
9036 % Enabled
9037 %
9038 % Analysis based on Abstract Interpretation paper.
9039 %
9040 % TODO:
9041 % stronger analysis domain [research]
9043 :- chr_constraint
9044 initial_call_pattern/1,
9045 call_pattern/1,
9046 call_pattern_worker/1,
9047 final_answer_pattern/2,
9048 abstract_constraints/1,
9049 depends_on/2,
9050 depends_on_ap/4,
9051 depends_on_goal/2,
9052 ai_observed_internal/2,
9053 % ai_observed/2,
9054 ai_not_observed_internal/2,
9055 ai_not_observed/2,
9056 ai_is_observed/2,
9057 depends_on_as/3,
9058 ai_observation_gather_results/0.
9060 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9061 :- chr_type program_point == any.
9063 :- chr_option(mode,initial_call_pattern(+)).
9064 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9066 :- chr_option(mode,call_pattern(+)).
9067 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9069 :- chr_option(mode,call_pattern_worker(+)).
9070 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9072 :- chr_option(mode,final_answer_pattern(+,+)).
9073 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9075 :- chr_option(mode,abstract_constraints(+)).
9076 :- chr_option(type_declaration,abstract_constraints(list)).
9078 :- chr_option(mode,depends_on(+,+)).
9079 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9081 :- chr_option(mode,depends_on_as(+,+,+)).
9082 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9083 :- chr_option(mode,depends_on_goal(+,+)).
9084 :- chr_option(mode,ai_is_observed(+,+)).
9085 :- chr_option(mode,ai_not_observed(+,+)).
9086 % :- chr_option(mode,ai_observed(+,+)).
9087 :- chr_option(mode,ai_not_observed_internal(+,+)).
9088 :- chr_option(mode,ai_observed_internal(+,+)).
9091 abstract_constraints_fd @
9092 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9094 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9095 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9096 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9098 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9099 ai_is_observed(_,_) <=> true.
9101 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9102 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9103 ai_observation_gather_results <=> true.
9105 %------------------------------------------------------------------------------%
9106 % Main Analysis Entry
9107 %------------------------------------------------------------------------------%
9108 ai_observation_analysis(ACs) :-
9109 ( chr_pp_flag(ai_observation_analysis,on),
9110 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9111 list_to_ord_set(ACs,ACSet),
9112 abstract_constraints(ACSet),
9113 ai_observation_schedule_initial_calls(ACSet,ACSet),
9114 ai_observation_gather_results
9115 ;
9116 true
9117 ).
9119 ai_observation_schedule_initial_calls([],_).
9120 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9121 ai_observation_schedule_initial_call(AC,ACs),
9122 ai_observation_schedule_initial_calls(RACs,ACs).
9124 ai_observation_schedule_initial_call(AC,ACs) :-
9125 ai_observation_top(AC,CallPattern),
9126 % ai_observation_bot(AC,ACs,CallPattern),
9127 initial_call_pattern(CallPattern).
9129 ai_observation_schedule_new_calls([],AP).
9130 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9131 AP = odom(_,Set),
9132 initial_call_pattern(odom(AC,Set)),
9133 ai_observation_schedule_new_calls(ACs,AP).
9135 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9136 <=>
9137 ai_observation_leq(AP2,AP1)
9138 |
9139 true.
9141 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9143 initial_call_pattern(CP) ==> call_pattern(CP).
9145 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9146 ==>
9147 ai_observation_schedule_new_calls(ACs,AP)
9148 pragma
9149 passive(ID3).
9151 call_pattern(CP) \ call_pattern(CP) <=> true.
9153 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9154 final_answer_pattern(CP1,AP).
9156 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9158 call_pattern(CP) ==> call_pattern_worker(CP).
9160 %------------------------------------------------------------------------------%
9161 % Abstract Goal
9162 %------------------------------------------------------------------------------%
9164 % AbstractGoala
9165 %call_pattern(odom([],Set)) ==>
9166 % final_answer_pattern(odom([],Set),odom([],Set)).
9168 call_pattern_worker(odom([],Set)) <=>
9169 % writeln(' - AbstractGoal'(odom([],Set))),
9170 final_answer_pattern(odom([],Set),odom([],Set)).
9172 % AbstractGoalb
9173 call_pattern_worker(odom([G|Gs],Set)) <=>
9174 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9175 CP1 = odom(G,Set),
9176 depends_on_goal(odom([G|Gs],Set),CP1),
9177 call_pattern(CP1).
9179 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9180 <=> true pragma passive(ID).
9181 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9182 ==>
9183 CP1 = odom([_|Gs],_),
9184 AP2 = odom([],Set),
9185 CCP = odom(Gs,Set),
9186 call_pattern(CCP),
9187 depends_on(CP1,CCP).
9189 %------------------------------------------------------------------------------%
9190 % Abstract Disjunction
9191 %------------------------------------------------------------------------------%
9193 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9194 CP = odom((AG1;AG2),Set),
9195 InitialAnswerApproximation = odom([],Set),
9196 final_answer_pattern(CP,InitialAnswerApproximation),
9197 CP1 = odom(AG1,Set),
9198 CP2 = odom(AG2,Set),
9199 call_pattern(CP1),
9200 call_pattern(CP2),
9201 depends_on_as(CP,CP1,CP2).
9203 %------------------------------------------------------------------------------%
9204 % Abstract Solve
9205 %------------------------------------------------------------------------------%
9206 call_pattern_worker(odom(builtin,Set)) <=>
9207 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9208 ord_empty(EmptySet),
9209 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9211 %------------------------------------------------------------------------------%
9212 % Abstract Drop
9213 %------------------------------------------------------------------------------%
9214 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9215 <=>
9216 O > MO
9217 |
9218 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9219 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9220 pragma
9221 passive(ID2).
9223 %------------------------------------------------------------------------------%
9224 % Abstract Activate
9225 %------------------------------------------------------------------------------%
9226 call_pattern_worker(odom(AC,Set))
9227 <=>
9228 AC = _ / _
9229 |
9230 % writeln(' - AbstractActivate'(odom(AC,Set))),
9231 CP = odom(occ(AC,1),Set),
9232 call_pattern(CP),
9233 depends_on(odom(AC,Set),CP).
9235 %------------------------------------------------------------------------------%
9236 % Abstract Passive
9237 %------------------------------------------------------------------------------%
9238 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9239 <=>
9240 is_passive(RuleNb,ID)
9241 |
9242 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9243 % DEFAULT
9244 NO is O + 1,
9245 DCP = odom(occ(C,NO),Set),
9246 call_pattern(DCP),
9247 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9248 depends_on(odom(occ(C,O),Set),DCP)
9249 pragma
9250 passive(ID2).
9251 %------------------------------------------------------------------------------%
9252 % Abstract Simplify
9253 %------------------------------------------------------------------------------%
9255 % AbstractSimplify
9256 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9257 <=>
9258 \+ is_passive(RuleNb,ID)
9259 |
9260 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9261 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9262 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9263 ai_observation_memo_abstract_goal(RuleNb,AG),
9264 call_pattern(odom(AG,Set2)),
9265 % DEFAULT
9266 NO is O + 1,
9267 DCP = odom(occ(C,NO),Set),
9268 call_pattern(DCP),
9269 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9270 % DEADLOCK AVOIDANCE
9271 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9272 pragma
9273 passive(ID2).
9275 depends_on_as(CP,CPS,CPD),
9276 final_answer_pattern(CPS,APS),
9277 final_answer_pattern(CPD,APD) ==>
9278 ai_observation_lub(APS,APD,AP),
9279 final_answer_pattern(CP,AP).
9282 :- chr_constraint
9283 ai_observation_memo_simplification_rest_heads/3,
9284 ai_observation_memoed_simplification_rest_heads/3.
9286 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9287 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9289 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9290 <=>
9291 QRH = RH.
9292 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9293 <=>
9294 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9295 once(select2(ID,_,IDs1,H1,_,RestH1)),
9296 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9297 ai_observation_abstract_constraints(H2,ACs,AH2),
9298 append(ARestHeads,AH2,AbstractHeads),
9299 sort(AbstractHeads,QRH),
9300 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9301 pragma
9302 passive(ID1),
9303 passive(ID2),
9304 passive(ID3).
9306 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9308 %------------------------------------------------------------------------------%
9309 % Abstract Propagate
9310 %------------------------------------------------------------------------------%
9313 % AbstractPropagate
9314 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9315 <=>
9316 \+ is_passive(RuleNb,ID)
9317 |
9318 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9319 % observe partners
9320 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9321 ai_observation_observe_set(Set,AHs,Set2),
9322 ord_add_element(Set2,C,Set3),
9323 ai_observation_memo_abstract_goal(RuleNb,AG),
9324 call_pattern(odom(AG,Set3)),
9325 ( ord_memberchk(C,Set2) ->
9326 Delete = no
9327 ;
9328 Delete = yes
9329 ),
9330 % DEFAULT
9331 NO is O + 1,
9332 DCP = odom(occ(C,NO),Set),
9333 call_pattern(DCP),
9334 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9335 pragma
9336 passive(ID2).
9338 :- chr_constraint
9339 ai_observation_memo_propagation_rest_heads/3,
9340 ai_observation_memoed_propagation_rest_heads/3.
9342 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9343 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9345 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9346 <=>
9347 QRH = RH.
9348 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9349 <=>
9350 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9351 once(select2(ID,_,IDs2,H2,_,RestH2)),
9352 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9353 ai_observation_abstract_constraints(H1,ACs,AH1),
9354 append(ARestHeads,AH1,AbstractHeads),
9355 sort(AbstractHeads,QRH),
9356 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9357 pragma
9358 passive(ID1),
9359 passive(ID2),
9360 passive(ID3).
9362 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9364 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9365 final_answer_pattern(CP,APD).
9366 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9367 final_answer_pattern(CPD,APD) ==>
9368 true |
9369 CP = odom(occ(C,O),_),
9370 ( ai_observation_is_observed(APP,C) ->
9371 ai_observed_internal(C,O)
9372 ;
9373 ai_not_observed_internal(C,O)
9374 ),
9375 ( Delete == yes ->
9376 APP = odom([],Set0),
9377 ord_del_element(Set0,C,Set),
9378 NAPP = odom([],Set)
9379 ;
9380 NAPP = APP
9381 ),
9382 ai_observation_lub(NAPP,APD,AP),
9383 final_answer_pattern(CP,AP).
9385 %------------------------------------------------------------------------------%
9386 % Catch All
9387 %------------------------------------------------------------------------------%
9389 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9391 %------------------------------------------------------------------------------%
9392 % Auxiliary Predicates
9393 %------------------------------------------------------------------------------%
9395 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9396 ord_intersection(S1,S2,S3).
9398 ai_observation_bot(AG,AS,odom(AG,AS)).
9400 ai_observation_top(AG,odom(AG,EmptyS)) :-
9401 ord_empty(EmptyS).
9403 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9404 ord_subset(S2,S1).
9406 ai_observation_observe_set(S,ACSet,NS) :-
9407 ord_subtract(S,ACSet,NS).
9409 ai_observation_abstract_constraint(C,ACs,AC) :-
9410 functor(C,F,A),
9411 AC = F/A,
9412 memberchk(AC,ACs).
9414 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9415 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9417 %------------------------------------------------------------------------------%
9418 % Abstraction of Rule Bodies
9419 %------------------------------------------------------------------------------%
9421 :- chr_constraint
9422 ai_observation_memoed_abstract_goal/2,
9423 ai_observation_memo_abstract_goal/2.
9425 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9426 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9428 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9429 <=>
9430 QAG = AG
9431 pragma
9432 passive(ID1).
9434 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9435 <=>
9436 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9437 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9438 QAG = AG,
9439 ai_observation_memoed_abstract_goal(RuleNb,AG)
9440 pragma
9441 passive(ID1),
9442 passive(ID2).
9444 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9445 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9446 term_variables((H1,H2,Guard),HVars),
9447 append(H1,H2,Heads),
9448 % variables that are declared to be ground are safe,
9449 ground_vars(Heads,GroundVars),
9450 % so we remove them from the list of 'dangerous' head variables
9451 list_difference_eq(HVars,GroundVars,HV),
9452 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9453 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9454 % HV are 'dangerous' variables, all others are fresh and safe
9456 ground_vars([],[]).
9457 ground_vars([H|Hs],GroundVars) :-
9458 functor(H,F,A),
9459 get_constraint_mode(F/A,Mode),
9460 % TOM: fix this code!
9461 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9462 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9463 ground_vars(Hs,GroundVars2),
9464 append(GroundVars1,GroundVars2,GroundVars).
9466 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9467 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9468 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9469 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9470 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9471 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9472 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9473 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9474 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9475 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9476 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9477 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9478 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9479 % non-CHR constraint is safe if it only binds fresh variables
9480 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9481 builtin_binds_b(G,Vars),
9482 intersect_eq(Vars,HV,[]),
9483 !.
9484 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9485 AG = builtin. % default case if goal is not recognized/safe
9487 ai_observation_is_observed(odom(_,ACSet),AC) :-
9488 \+ ord_memberchk(AC,ACSet).
9490 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9491 unconditional_occurrence(C,O) :-
9492 get_occurrence(C,O,RuleNb,ID),
9493 get_rule(RuleNb,PRule),
9494 PRule = pragma(ORule,_,_,_,_),
9495 copy_term_nat(ORule,Rule),
9496 Rule = rule(H1,H2,Guard,_),
9497 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9498 once((
9499 H1 = [Head], H2 == []
9500 ;
9501 H2 = [Head], H1 == [], \+ may_trigger(C)
9502 )),
9503 all_distinct_var_args(Head).
9505 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9507 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9508 % Partial wake analysis
9509 %
9510 % In a Var = Var unification do not wake up constraints of both variables,
9511 % but rather only those of one variable.
9512 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9514 :- chr_constraint partial_wake_analysis/0.
9515 :- chr_constraint no_partial_wake/1.
9516 :- chr_option(mode,no_partial_wake(+)).
9517 :- chr_constraint wakes_partially/1.
9518 :- chr_option(mode,wakes_partially(+)).
9520 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9521 ==>
9522 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9523 ( is_passive(RuleNb,ID) ->
9524 true
9525 ; Type == simplification ->
9526 select(H,H1,RestH1),
9527 H =.. [_|Args],
9528 term_variables(Guard,Vars),
9529 partial_wake_args(Args,ArgModes,Vars,FA)
9530 ; % Type == propagation ->
9531 select(H,H2,RestH2),
9532 H =.. [_|Args],
9533 term_variables(Guard,Vars),
9534 partial_wake_args(Args,ArgModes,Vars,FA)
9535 ).
9537 partial_wake_args([],_,_,_).
9538 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9539 ( Mode \== (+) ->
9540 ( nonvar(Arg) ->
9541 no_partial_wake(C)
9542 ; memberchk_eq(Arg,Vars) ->
9543 no_partial_wake(C)
9544 ;
9545 true
9546 )
9547 ;
9548 true
9549 ),
9550 partial_wake_args(Args,Modes,Vars,C).
9552 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9554 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9556 wakes_partially(C) <=> true.
9559 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9560 % Generate rules that implement chr_show_store/1 functionality.
9561 %
9562 % CLASSIFICATION
9563 % Experimental
9564 % Unused
9565 %
9566 % Generates additional rules:
9567 %
9568 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9569 % ...
9570 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9571 % $show <=> true.
9573 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9574 ( chr_pp_flag(show,on) ->
9575 Constraints = ['$show'/0|Constraints0],
9576 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9577 inc_rule_count(RuleNb),
9578 Rule = pragma(
9579 rule(['$show'],[],true,true),
9580 ids([0],[]),
9581 [],
9582 no,
9583 RuleNb
9584 )
9585 ;
9586 Constraints = Constraints0,
9587 Rules = Rules0
9588 ).
9590 generate_show_rules([],Rules,Rules).
9591 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9592 functor(C,F,A),
9593 inc_rule_count(RuleNb),
9594 Rule = pragma(
9595 rule([],['$show',C],true,writeln(C)),
9596 ids([],[0,1]),
9597 [passive(1)],
9598 no,
9599 RuleNb
9600 ),
9601 generate_show_rules(Rest,Tail,Rules).
9603 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9604 % Custom supension term layout
9606 static_suspension_term(F/A,Suspension) :-
9607 suspension_term_base(F/A,Base),
9608 Arity is Base + A,
9609 functor(Suspension,suspension,Arity).
9611 has_suspension_field(FA,Field) :-
9612 suspension_term_base_fields(FA,Fields),
9613 memberchk(Field,Fields).
9615 suspension_term_base(FA,Base) :-
9616 suspension_term_base_fields(FA,Fields),
9617 length(Fields,Base).
9619 suspension_term_base_fields(FA,Fields) :-
9620 ( chr_pp_flag(debugable,on) ->
9621 % 1. ID
9622 % 2. State
9623 % 3. Propagation History
9624 % 4. Generation Number
9625 % 5. Continuation Goal
9626 % 6. Functor
9627 Fields = [id,state,history,generation,continuation,functor]
9628 ;
9629 ( uses_history(FA) ->
9630 Fields = [id,state,history|Fields2]
9631 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9632 Fields = [state|Fields2]
9633 ;
9634 Fields = [id,state|Fields2]
9635 ),
9636 ( only_ground_indexed_arguments(FA) ->
9637 get_store_type(FA,StoreType),
9638 basic_store_types(StoreType,BasicStoreTypes),
9639 ( memberchk(global_ground,BasicStoreTypes) ->
9640 % 1. ID
9641 % 2. State
9642 % 3. Propagation History
9643 % 4. Global List Prev
9644 Fields2 = [global_list_prev|Fields3]
9645 ;
9646 % 1. ID
9647 % 2. State
9648 % 3. Propagation History
9649 Fields2 = Fields3
9650 ),
9651 ( chr_pp_flag(ht_removal,on)
9652 -> ht_prev_fields(BasicStoreTypes,Fields3)
9653 ; Fields3 = []
9654 )
9655 ; may_trigger(FA) ->
9656 % 1. ID
9657 % 2. State
9658 % 3. Propagation History
9659 ( uses_field(FA,generation) ->
9660 % 4. Generation Number
9661 % 5. Global List Prev
9662 Fields2 = [generation,global_list_prev|Fields3]
9663 ;
9664 Fields2 = [global_list_prev|Fields3]
9665 ),
9666 ( chr_pp_flag(mixed_stores,on),
9667 chr_pp_flag(ht_removal,on)
9668 -> get_store_type(FA,StoreType),
9669 basic_store_types(StoreType,BasicStoreTypes),
9670 ht_prev_fields(BasicStoreTypes,Fields3)
9671 ; Fields3 = []
9672 )
9673 ;
9674 % 1. ID
9675 % 2. State
9676 % 3. Propagation History
9677 % 4. Global List Prev
9678 Fields2 = [global_list_prev|Fields3],
9679 ( chr_pp_flag(mixed_stores,on),
9680 chr_pp_flag(ht_removal,on)
9681 -> get_store_type(FA,StoreType),
9682 basic_store_types(StoreType,BasicStoreTypes),
9683 ht_prev_fields(BasicStoreTypes,Fields3)
9684 ; Fields3 = []
9685 )
9686 )
9687 ).
9689 ht_prev_fields(Stores,Prevs) :-
9690 ht_prev_fields_int(Stores,PrevsList),
9691 append(PrevsList,Prevs).
9692 ht_prev_fields_int([],[]).
9693 ht_prev_fields_int([H|T],Fields) :-
9694 ( H = multi_hash(Indexes)
9695 -> maplist(ht_prev_field,Indexes,FH),
9696 Fields = [FH|FT]
9697 ; Fields = FT
9698 ),
9699 ht_prev_fields_int(T,FT).
9701 ht_prev_field(Index,Field) :-
9702 concat_atom(['multi_hash_prev-'|Index],Field).
9704 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9705 suspension_term_base_fields(FA,Fields),
9706 nth1(Index,Fields,FieldName), !,
9707 arg(Index,StaticSuspension,Field).
9708 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9709 suspension_term_base(FA,Base),
9710 StaticSuspension =.. [_|Args],
9711 drop(Base,Args,Field).
9712 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9713 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9716 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9717 suspension_term_base_fields(FA,Fields),
9718 nth1(Index,Fields,FieldName), !,
9719 Goal = arg(Index,DynamicSuspension,Field).
9720 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9721 static_suspension_term(FA,StaticSuspension),
9722 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9723 Goal = (DynamicSuspension = StaticSuspension).
9724 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9725 suspension_term_base(FA,Base),
9726 Index is I + Base,
9727 Goal = arg(Index,DynamicSuspension,Field).
9728 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9729 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9732 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9733 suspension_term_base_fields(FA,Fields),
9734 nth1(Index,Fields,FieldName), !,
9735 Goal = setarg(Index,DynamicSuspension,Field).
9736 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9737 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9739 basic_store_types(multi_store(Types),Types) :- !.
9740 basic_store_types(Type,[Type]).
9742 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9743 %
9745 :- chr_constraint
9746 phase_end/1,
9747 delay_phase_end/2.
9749 :- chr_option(mode,phase_end(+)).
9750 :- chr_option(mode,delay_phase_end(+,?)).
9752 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9753 % phase_end(Phase) <=> true.
9756 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9757 :- chr_constraint
9758 does_use_history/2,
9759 uses_history/1,
9760 novel_production_call/4.
9762 :- chr_option(mode,uses_history(+)).
9763 :- chr_option(mode,does_use_history(+,+)).
9764 :- chr_option(mode,novel_production_call(+,+,?,?)).
9766 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9767 does_use_history(FA,_) \ uses_history(FA) <=> true.
9768 uses_history(_FA) <=> fail.
9770 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9771 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9773 :- chr_constraint
9774 does_use_field/2,
9775 uses_field/2.
9777 :- chr_option(mode,uses_field(+,+)).
9778 :- chr_option(mode,does_use_field(+,+)).
9780 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9781 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9782 uses_field(_FA,_Field) <=> fail.
9784 :- chr_constraint
9785 uses_state/2,
9786 if_used_state/5,
9787 used_states_known/0.
9789 :- chr_option(mode,uses_state(+,+)).
9790 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9793 % states ::= not_stored_yet | passive | active | triggered | removed
9794 %
9795 % allocate CREATES not_stored_yet
9796 % remove CHECKS not_stored_yet
9797 % activate CHECKS not_stored_yet
9798 %
9799 % ==> no allocate THEN no not_stored_yet
9801 % recurs CREATES inactive
9802 % lookup CHECKS inactive
9804 % insert CREATES active
9805 % activate CREATES active
9806 % lookup CHECKS active
9807 % recurs CHECKS active
9809 % runsusp CREATES triggered
9810 % lookup CHECKS triggered
9811 %
9812 % ==> no runsusp THEN no triggered
9814 % remove CREATES removed
9815 % runsusp CHECKS removed
9816 % lookup CHECKS removed
9817 % recurs CHECKS removed
9818 %
9819 % ==> no remove THEN no removed
9821 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9823 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9825 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9826 <=> ResultGoal = Used.
9827 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9828 <=> ResultGoal = NotUsed.
9830 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9831 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9832 % (Feature for SSS)
9833 %
9834 % 1. Checking
9835 % ~~~~~~~~~~~
9836 %
9837 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9838 %
9839 % :- chr_option(declare_stored_constraints,on).
9840 %
9841 % the compiler will check for the storedness of constraints.
9842 %
9843 % By default, the compiler assumes that the programmer wants his constraints to
9844 % be never-stored. Hence, a warning will be issues when a constraint is actually
9845 % stored.
9846 %
9847 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9848 % to a constraint declaration, i.e. writes
9849 %
9850 % :- chr_constraint c(...) # stored.
9851 %
9852 % In that case a warning is issued when the constraint is never-stored.
9853 %
9854 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9855 % constraints are stored anyway.
9856 %
9857 %
9858 % 2. Rule Generation
9859 % ~~~~~~~~~~~~~~~~~~
9860 %
9861 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9862 %
9863 % :- chr_option(declare_stored_constraints,on).
9864 %
9865 % the compiler will generate default simplification rules for constraints.
9866 %
9867 % By default, no default rule is generated for a constraint. However, if the
9868 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9869 %
9870 % :- chr_constraint c(...) # default(Goal).
9871 %
9872 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9873 % the compiler generates a rule:
9874 %
9875 % c(_,...,_) <=> Goal.
9876 %
9877 % at the end of the program. If multiple default rules are generated, for several constraints,
9878 % then the order of the default rules is not specified.
9881 :- chr_constraint stored_assertion/1.
9882 :- chr_option(mode,stored_assertion(+)).
9883 :- chr_option(type_declaration,stored_assertion(constraint)).
9885 :- chr_constraint never_stored_default/2.
9886 :- chr_option(mode,never_stored_default(+,?)).
9887 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9889 % Rule Generation
9890 % ~~~~~~~~~~~~~~~
9892 generate_never_stored_rules(Constraints,Rules) :-
9893 ( chr_pp_flag(declare_stored_constraints,on) ->
9894 never_stored_rules(Constraints,Rules)
9895 ;
9896 Rules = []
9897 ).
9899 :- chr_constraint never_stored_rules/2.
9900 :- chr_option(mode,never_stored_rules(+,?)).
9901 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9903 never_stored_rules([],Rules) <=> Rules = [].
9904 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9905 Constraint = F/A,
9906 functor(Head,F,A),
9907 inc_rule_count(RuleNb),
9908 Rule = pragma(
9909 rule([Head],[],true,Goal),
9910 ids([0],[]),
9911 [],
9912 no,
9913 RuleNb
9914 ),
9915 Rules = [Rule|Tail],
9916 never_stored_rules(Constraints,Tail).
9917 never_stored_rules([_|Constraints],Rules) <=>
9918 never_stored_rules(Constraints,Rules).
9920 % Checking
9921 % ~~~~~~~~
9923 check_storedness_assertions(Constraints) :-
9924 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9925 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9926 ;
9927 true
9928 ).
9931 :- chr_constraint check_storedness_assertion/1.
9932 :- chr_option(mode,check_storedness_assertion(+)).
9933 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9935 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9936 <=> ( is_stored(Constraint) ->
9937 true
9938 ;
9939 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9940 ).
9941 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9942 <=> ( is_finally_stored(Constraint) ->
9943 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9944 ; is_stored(Constraint) ->
9945 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9946 ;
9947 true
9948 ).
9949 % never-stored, no default goal
9950 check_storedness_assertion(Constraint)
9951 <=> ( is_finally_stored(Constraint) ->
9952 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9953 ; is_stored(Constraint) ->
9954 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9955 ;
9956 true
9957 ).
9959 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9960 % success continuation analysis
9962 % TODO
9963 % also use for forward jumping improvement!
9964 % use Prolog indexing for generated code
9965 %
9966 % EXPORTED
9967 %
9968 % should_skip_to_next_id(C,O)
9969 %
9970 % get_occurrence_code_id(C,O,Id)
9971 %
9972 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9974 continuation_analysis(ConstraintSymbols) :-
9975 maplist(analyse_continuations,ConstraintSymbols).
9977 analyse_continuations(C) :-
9978 % 1. compute success continuations of the
9979 % occurrences of constraint C
9980 continuation_analysis(C,1),
9981 % 2. determine for which occurrences
9982 % to skip to next code id
9983 get_max_occurrence(C,MO),
9984 LO is MO + 1,
9985 bulk_propagation(C,1,LO),
9986 % 3. determine code id for each occurrence
9987 set_occurrence_code_id(C,1,0).
9989 % 1. Compute the success continuations of constrait C
9990 %-------------------------------------------------------------------------------
9992 continuation_analysis(C,O) :-
9993 get_max_occurrence(C,MO),
9994 ( O > MO ->
9995 true
9996 ; O == MO ->
9997 NextO is O + 1,
9998 continuation_occurrence(C,O,NextO)
9999 ;
10000 constraint_continuation(C,O,MO,NextO),
10001 continuation_occurrence(C,O,NextO),
10002 NO is O + 1,
10003 continuation_analysis(C,NO)
10004 ).
10006 constraint_continuation(C,O,MO,NextO) :-
10007 ( get_occurrence_head(C,O,Head) ->
10008 NO is O + 1,
10009 ( between(NO,MO,NextO),
10010 get_occurrence_head(C,NextO,NextHead),
10011 unifiable(Head,NextHead,_) ->
10012 true
10013 ;
10014 NextO is MO + 1
10015 )
10016 ; % current occurrence is passive
10017 NextO = MO
10018 ).
10020 get_occurrence_head(C,O,Head) :-
10021 get_occurrence(C,O,RuleNb,Id),
10022 \+ is_passive(RuleNb,Id),
10023 get_rule(RuleNb,Rule),
10024 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10025 ( select2(Id,Head,Ids1,H1,_,_) -> true
10026 ; select2(Id,Head,Ids2,H2,_,_)
10027 ).
10029 :- chr_constraint continuation_occurrence/3.
10030 :- chr_option(mode,continuation_occurrence(+,+,+)).
10032 :- chr_constraint get_success_continuation_occurrence/3.
10033 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10035 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10036 <=>
10037 X = NO.
10039 get_success_continuation_occurrence(C,O,X)
10040 <=>
10041 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10043 % 2. figure out when to skip to next code id
10044 %-------------------------------------------------------------------------------
10045 % don't go beyond the last occurrence
10046 % we have to go to next id for storage here
10048 :- chr_constraint skip_to_next_id/2.
10049 :- chr_option(mode,skip_to_next_id(+,+)).
10051 :- chr_constraint should_skip_to_next_id/2.
10052 :- chr_option(mode,should_skip_to_next_id(+,+)).
10054 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10055 <=>
10056 true.
10058 should_skip_to_next_id(_,_)
10059 <=>
10060 fail.
10062 :- chr_constraint bulk_propagation/3.
10063 :- chr_option(mode,bulk_propagation(+,+,+)).
10065 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10066 <=>
10067 O >= MO
10068 |
10069 skip_to_next_id(C,O).
10070 % we have to go to the next id here because
10071 % a predecessor needs it
10072 bulk_propagation(C,O,LO)
10073 <=>
10074 LO =:= O + 1
10075 |
10076 skip_to_next_id(C,O),
10077 get_max_occurrence(C,MO),
10078 NLO is MO + 1,
10079 bulk_propagation(C,LO,NLO).
10080 % we have to go to the next id here because
10081 % we're running into a simplification rule
10082 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10083 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10084 <=>
10085 NO =:= O + 1
10086 |
10087 skip_to_next_id(C,O),
10088 get_max_occurrence(C,MO),
10089 NLO is MO + 1,
10090 bulk_propagation(C,NO,NLO).
10091 % we skip the next id here
10092 % and go to the next occurrence
10093 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10094 <=>
10095 NextO > O + 1
10096 |
10097 NLO is min(LO,NextO),
10098 NO is O + 1,
10099 bulk_propagation(C,NO,NLO).
10100 % default case
10101 % err on the safe side
10102 bulk_propagation(C,O,LO)
10103 <=>
10104 skip_to_next_id(C,O),
10105 get_max_occurrence(C,MO),
10106 NLO is MO + 1,
10107 NO is O + 1,
10108 bulk_propagation(C,NO,NLO).
10110 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10112 % if this occurrence is passive, but has to skip,
10113 % then the previous one must skip instead...
10114 % IMPROVE reasoning is conservative
10115 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10116 ==>
10117 O > 1
10118 |
10119 PO is O - 1,
10120 skip_to_next_id(C,PO).
10122 % 3. determine code id of each occurrence
10123 %-------------------------------------------------------------------------------
10125 :- chr_constraint set_occurrence_code_id/3.
10126 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10128 :- chr_constraint occurrence_code_id/3.
10129 :- chr_option(mode,occurrence_code_id(+,+,+)).
10131 % stop at the end
10132 set_occurrence_code_id(C,O,IdNb)
10133 <=>
10134 get_max_occurrence(C,MO),
10135 O > MO
10136 |
10137 occurrence_code_id(C,O,IdNb).
10139 % passive occurrences don't change the code id
10140 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10141 <=>
10142 occurrence_code_id(C,O,IdNb),
10143 NO is O + 1,
10144 set_occurrence_code_id(C,NO,IdNb).
10146 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10147 <=>
10148 occurrence_code_id(C,O,IdNb),
10149 NO is O + 1,
10150 set_occurrence_code_id(C,NO,IdNb).
10152 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10153 <=>
10154 occurrence_code_id(C,O,IdNb),
10155 NO is O + 1,
10156 NIdNb is IdNb + 1,
10157 set_occurrence_code_id(C,NO,NIdNb).
10159 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10160 <=>
10161 occurrence_code_id(C,O,IdNb),
10162 NO is O + 1,
10163 set_occurrence_code_id(C,NO,IdNb).
10165 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10167 :- chr_constraint get_occurrence_code_id/3.
10168 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10170 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10171 <=>
10172 X = IdNb.
10174 get_occurrence_code_id(C,O,X)
10175 <=>
10176 ( O == 0 ->
10177 true % X = 0
10178 ;
10179 format('no occurrence code for ~w!\n',[C:O])
10180 ).
10182 get_success_continuation_code_id(C,O,NextId) :-
10183 get_success_continuation_occurrence(C,O,NextO),
10184 get_occurrence_code_id(C,NextO,NextId).
10186 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10187 % COLLECT CONSTANTS FOR INLINING
10188 %
10189 % for SSS
10191 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10193 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10194 collect_constants(Rules,Constraints,Clauses0) :-
10195 ( not_restarted, chr_pp_flag(experiment,on) ->
10196 ( chr_pp_flag(sss,on) ->
10197 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10198 copy_term_nat(Clauses0,Clauses),
10199 flatten_clauses(Clauses,Dictionary,FlatClauses),
10200 install_new_declarations_and_restart(FlatClauses)
10201 ;
10202 maplist(collect_rule_constants(Constraints),Rules),
10203 ( chr_pp_flag(verbose,on) ->
10204 print_chr_constants
10205 ;
10206 true
10207 ),
10208 ( chr_pp_flag(experiment,on) ->
10209 flattening_dictionary(Constraints,Dictionary),
10210 copy_term_nat(Clauses0,Clauses),
10211 flatten_clauses(Clauses,Dictionary,FlatClauses),
10212 install_new_declarations_and_restart(FlatClauses)
10213 ;
10214 true
10215 )
10216 )
10217 ;
10218 true
10219 ).
10221 :- chr_constraint chr_constants/1.
10222 :- chr_option(mode,chr_constants(+)).
10224 :- chr_constraint get_chr_constants/1.
10226 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10228 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10230 % collect_rule_constants(+constraint_symbols,+rule) {{{
10231 collect_rule_constants(Constraints,Rule) :-
10232 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10233 maplist(collect_head_constants,H1),
10234 maplist(collect_head_constants,H2),
10235 collect_body_constants(B,Constraints).
10237 collect_body_constants(Body,Constraints) :-
10238 conj2list(Body,Goals),
10239 maplist(collect_goal_constants(Constraints),Goals).
10241 collect_goal_constants(Constraints,Goal) :-
10242 ( nonvar(Goal),
10243 functor(Goal,C,N),
10244 memberchk(C/N,Constraints) ->
10245 collect_head_constants(Goal)
10246 ; nonvar(Goal),
10247 Goal = Mod : TheGoal,
10248 get_target_module(Module),
10249 Mod == Module,
10250 nonvar(TheGoal),
10251 functor(TheGoal,C,N),
10252 memberchk(C/N,Constraints) ->
10253 collect_head_constants(TheGoal)
10254 ;
10255 true
10256 ).
10258 collect_head_constants(Head) :-
10259 functor(Head,C,N),
10260 get_constraint_type_det(C/N,Types),
10261 Head =.. [_|Args],
10262 collect_all_arg_constants(Args,Types,[]).
10264 collect_all_arg_constants([],[],Constants) :-
10265 ( Constants \== [] ->
10266 add_chr_constants(Constants)
10267 ;
10268 true
10269 ).
10270 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10271 unalias_type(Type,NormalizedType),
10272 ( is_chr_constants_type(NormalizedType,Key,_) ->
10273 ( ground(Arg) ->
10274 collect_all_arg_constants(Args,Types,[Key-Arg|Constants0])
10275 ; % no useful information here
10276 true
10277 )
10278 ;
10279 collect_all_arg_constants(Args,Types,Constants0)
10280 ).
10282 add_chr_constants(Pairs) :-
10283 keysort(Pairs,SortedPairs),
10284 add_chr_constants_(SortedPairs).
10286 :- chr_constraint add_chr_constants_/1.
10287 :- chr_option(mode,add_chr_constants_(+)).
10289 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10290 sort([Constants|MoreConstants],NConstants),
10291 chr_constants(NConstants).
10293 add_chr_constants_(Constants) <=>
10294 chr_constants([Constants]).
10296 % }}}
10298 :- chr_constraint print_chr_constants/0. % {{{
10300 print_chr_constants, chr_constants(Constants) # Id ==>
10301 format('\t* chr_constants : ~w.\n',[Constants])
10302 pragma passive(Id).
10304 print_chr_constants <=>
10305 true.
10307 % }}}
10309 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10310 flattening_dictionary([],[]).
10311 flattening_dictionary([CS|CSs],Dictionary) :-
10312 ( flattening_dictionary_entry(CS,Entry) ->
10313 Dictionary = [Entry|Rest]
10314 ;
10315 Dictionary = Rest
10316 ),
10317 flattening_dictionary(CSs,Rest).
10319 flattening_dictionary_entry(CS,Entry) :-
10320 get_constraint_type_det(CS,Types),
10321 constant_positions(Types,1,Positions,Keys,Handler),
10322 Positions \== [], % there are chr_constant arguments
10323 pairup(Keys,Constants,Pairs0),
10324 keysort(Pairs0,Pairs),
10325 Entry = CS-Positions-Specs-Handler,
10326 get_chr_constants(ConstantsList),
10327 findall(Spec,
10328 ( member(Pairs,ConstantsList)
10329 , flat_spec(CS,Positions,Constants,Spec)
10330 ),
10331 Specs).
10333 constant_positions([],_,[],[],no).
10334 constant_positions([Type|Types],I,Positions,Keys,Handler) :-
10335 unalias_type(Type,NormalizedType),
10336 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10337 compose_error_handlers(ErrorHandler,NHandler,Handler),
10338 Positions = [I|NPositions],
10339 Keys = [Key|NKeys]
10340 ;
10341 NPositions = Positions,
10342 NKeys = Keys,
10343 NHandler = Handler
10344 ),
10345 J is I + 1,
10346 constant_positions(Types,J,NPositions,NKeys,NHandler).
10348 compose_error_handlers(no,Handler,Handler).
10349 compose_error_handlers(yes(Handler),_,yes(Handler)).
10351 flat_spec(C/N,Positions,Terms,Spec) :-
10352 Spec = Terms - Functor,
10353 term_to_atom(Terms,TermsAtom),
10354 term_to_atom(Positions,PositionsAtom),
10355 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10357 % }}}
10359 % }}}
10360 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10361 % RESTART AFTER FLATTENING {{{
10363 restart_after_flattening(Declarations,Declarations) :-
10364 nb_setval('$chr_restart_after_flattening',started).
10365 restart_after_flattening(_,Declarations) :-
10366 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10367 nb_setval('$chr_restart_after_flattening',restarted).
10369 not_restarted :-
10370 nb_getval('$chr_restart_after_flattening',started).
10372 install_new_declarations_and_restart(Declarations) :-
10373 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10374 fail. /* fails to choicepoint of restart_after_flattening */
10375 % }}}
10376 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10377 % FLATTENING {{{
10379 % DONE
10380 % -) generate dictionary from collected chr_constants
10381 % enable with :- chr_option(experiment,on).
10382 % -) issue constraint declarations for constraints not present in
10383 % dictionary
10384 % -) integrate with CHR compiler
10385 % -) pass Mike's test code (full syntactic support for current CHR code)
10386 % -) rewrite the body using the inliner
10387 %
10388 % TODO:
10389 % -) refined semantics correctness issue
10390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10392 flatten_clauses(Clauses,Dict,NClauses) :-
10393 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10394 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10396 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10397 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10398 dispatching_rules(Dict,NClauses1),
10399 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10400 flatten_rules(Clauses,Dict,NClauses3),
10401 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10403 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10404 % Declarations for non-flattened constraints
10406 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10407 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10408 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10409 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10410 flatten(DeclarationsList,Declarations).
10412 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10413 [(:- chr_constraint ConstraintSymbol),
10414 (:- chr_option(mode,ModeDeclPattern)),
10415 (:- chr_option(type_declaration,TypeDeclPattern))
10416 ]) :-
10417 ConstraintSymbol = Functor / Arity,
10418 % print optional mode declaration
10419 functor(ModeDeclPattern,Functor,Arity),
10420 ( memberchk(ModeDeclPattern,ModeDecls) ->
10421 true
10422 ;
10423 replicate(Arity,(?),Modes),
10424 ModeDeclPattern =.. [_|Modes]
10425 ),
10426 % print optional type declaration
10427 functor(TypeDeclPattern,Functor,Arity),
10428 ( memberchk(TypeDeclPattern,TypeDecls) ->
10429 true
10430 ;
10431 replicate(Arity,any,Types),
10432 TypeDeclPattern =.. [_|Types]
10433 ).
10434 % }}}
10435 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10436 % read clauses from file
10437 % CHR are returned
10438 % declared constaints are returned
10439 % type definitions are returned and printed
10440 % mode declarations are returned
10441 % other clauses are returned
10443 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10444 flatten_readcontent([],[],[],[],[],[],[]).
10445 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10446 % read(Clause),
10447 ( Clause == end_of_file ->
10448 Rules = [],
10449 ConstraintSymbols = [],
10450 ModeDecls = [],
10451 TypeDecls = [],
10452 TypeDefs = [],
10453 RestClauses = []
10454 ; crude_is_rule(Clause) ->
10455 Rules = [Clause|RestRules],
10456 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10457 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10458 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10459 append(SomeModeDecls,RestModeDecls,ModeDecls),
10460 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10461 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10462 ; is_mode_declaration(Clause,ModeDecl) ->
10463 ModeDecls = [ModeDecl|RestModeDecls],
10464 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10465 ; is_type_declaration(Clause,TypeDecl) ->
10466 TypeDecls = [TypeDecl|RestTypeDecls],
10467 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10468 ; is_type_definition(Clause,TypeDef) ->
10469 RestClauses = [Clause|NRestClauses],
10470 TypeDefs = [TypeDef|RestTypeDefs],
10471 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10472 ; ( Clause = (:- op(A,B,C)) ->
10473 % assert operators in order to read and print them out properly
10474 op(A,B,C)
10475 ;
10476 true
10477 ),
10478 RestClauses = [Clause|NRestClauses],
10479 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10480 ).
10482 crude_is_rule(_ @ _).
10483 crude_is_rule(_ pragma _).
10484 crude_is_rule(_ ==> _).
10485 crude_is_rule(_ <=> _).
10487 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10488 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10489 conj2list(Cs,Constraints0),
10490 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10492 pure_extract_type_mode([],[],[],[]).
10493 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10494 pure_extract_type_mode(R,R2,Modes,Types).
10495 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10496 functor(C,F,A),
10497 ConstraintSymbol = F/A,
10498 C =.. [_|Args],
10499 extract_types_and_modes(Args,ArgTypes,ArgModes),
10500 Mode =.. [F|ArgModes],
10501 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10502 Types = RTypes
10503 ;
10504 Types = [Type|RTypes],
10505 Type =.. [F|ArgTypes]
10506 ),
10507 pure_extract_type_mode(R,R2,Modes,RTypes).
10509 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10511 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10512 % }}}
10513 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10514 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10515 % including mode and type declarations
10517 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10518 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10519 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10520 flatten(ConstraintSpecs0,ConstraintSpecs).
10522 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10523 [(:- chr_constraint ConstraintSpec),
10524 (:- chr_option(mode,NewModeDecl)),
10525 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10526 member(C/N-I-SFs-_,Dict),
10527 arg_modes(C,N,ModeDecls,Modes),
10528 specialize_modes(Modes,I,SpecializedModes),
10529 arg_types(C,N,TypeDecls,Types),
10530 specialize_types(Types,I,SpecializedTypes),
10531 length(I,IndexSize),
10532 AN is N - IndexSize,
10533 member(_Term-F,SFs),
10534 ConstraintSpec = F/AN,
10535 NewModeDecl =.. [F|SpecializedModes],
10536 NewTypeDecl =.. [F|SpecializedTypes].
10538 arg_modes(C,N,ModeDecls,ArgModes) :-
10539 functor(ConstraintPattern,C,N),
10540 ( memberchk(ConstraintPattern,ModeDecls) ->
10541 ConstraintPattern =.. [_|ArgModes]
10542 ;
10543 replicate(N,?,ArgModes)
10544 ).
10546 specialize_modes(Modes,I,SpecializedModes) :-
10547 split_args(I,Modes,_,SpecializedModes).
10549 arg_types(C,N,TypeDecls,ArgTypes) :-
10550 functor(ConstraintPattern,C,N),
10551 ( memberchk(ConstraintPattern,TypeDecls) ->
10552 ConstraintPattern =.. [_|ArgTypes]
10553 ;
10554 replicate(N,any,ArgTypes)
10555 ).
10557 specialize_types(Types,I,SpecializedTypes) :-
10558 split_args(I,Types,_,SpecializedTypes).
10559 % }}}
10560 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10561 % DISPATCHING RULES
10562 %
10563 % dispatching_rules(+dict,-newrules)
10566 % {{{
10568 % This code generates a decision tree for calling the appropriate specialized
10569 % constraint based on the particular value of the argument the constraint
10570 % is being specialized on.
10571 %
10572 % In case an error handler is provided, the handler is called with the
10573 % unexpected constraint.
10575 dispatching_rules([],[]).
10576 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10577 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10578 dispatching_rules(Dict,RestDispatchingRules).
10580 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10581 ( increasing_numbers(I,1) ->
10582 /* index on first arguments */
10583 Rules0 = Rules,
10584 NCN = C/N
10585 ;
10586 /* reorder arguments for 1st argument indexing */
10587 functor(Head,C,N),
10588 Head =.. [_|Args],
10589 split_args(I,Args,GroundArgs,OtherArgs),
10590 append(GroundArgs,OtherArgs,ShuffledArgs),
10591 atom_concat(C,'_$shuffled',NC),
10592 Body =.. [NC|ShuffledArgs],
10593 [(Head :- Body)|Rules0] = Rules,
10594 NCN = NC / N
10595 ),
10596 Context = swap(C,I),
10597 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10599 increasing_numbers([],_).
10600 increasing_numbers([X|Ys],X) :-
10601 Y is X + 1,
10602 increasing_numbers(Ys,Y).
10604 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10605 length(I,IndexLength),
10606 once(pairup(TermLists,Functors,SFs)),
10607 maplist(head_tail,TermLists,Heads,Tails),
10608 Payload is N - IndexLength,
10609 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10610 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10612 dispatching_action(Functor,PayloadArgs,Goal) :-
10613 Goal =.. [Functor|PayloadArgs].
10615 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10616 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10618 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10619 % length MorePatterns == length Patterns == length Results
10620 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10621 MorePatterns = [List|_],
10622 length(List,N),
10623 aggregate_all(set(F/A),
10624 ( member(Pattern,Patterns),
10625 functor(Pattern,F,A)
10626 ),
10627 FAs),
10628 N1 is N + 1,
10629 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10631 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10632 ( MaybeErrorHandler = yes(ErrorHandler) ->
10633 Clauses0 = [ErrorClause|Clauses],
10634 ErrorClause = (Head :- Body),
10635 Arity is N + Payload,
10636 functor(Head,Symbol,Arity),
10637 reconstruct_original_term(Context,Head,Term),
10638 Body =.. [ErrorHandler,Term]
10639 ;
10640 Clauses0 = Clauses
10641 ).
10642 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10643 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10644 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10646 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10647 Clause = (Head :- Cut, Body),
10648 ( MaybeErrorHandler = yes(_) ->
10649 Cut = (!)
10650 ;
10651 Cut = true
10652 ),
10653 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10654 N1 is N + Payload,
10655 functor(Head,Symbol,N1),
10656 arg(1,Head,IndexPattern),
10657 Head =.. [_,_|RestArgs],
10658 length(PayloadArgs,Payload),
10659 once(append(Vs,PayloadArgs,RestArgs)),
10660 /* IndexPattern = F(...) */
10661 functor(IndexPattern,F,A),
10662 Context1 = index_functor(F,A,Context0),
10663 IndexPattern =.. [_|Args],
10664 append(Args,RestArgs,RecArgs),
10665 ( RecArgs == PayloadArgs ->
10666 /* nothing more to match on */
10667 List = Tail,
10668 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10669 MoreActions = [Action],
10670 call(Action,PayloadArgs,Body)
10671 ; /* more things to match on */
10672 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10673 ( MoreActions = [OneMoreAction] ->
10674 /* only one more thing to match on */
10675 MoreCases = [OneMoreCase],
10676 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10677 List = Tail,
10678 call(OneMoreAction,PayloadArgs,Body)
10679 ;
10680 /* more than one thing to match on */
10681 /* [ x1,..., xn]
10682 [xs1,...,xsn]
10683 */
10684 pairup(Cases,MoreCases,CasePairs),
10685 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10686 append(Args,Vs,[First|Rest]),
10687 First-Rest = CommonPatternPair,
10688 Context2 = gct([First|Rest],Context1),
10689 gensym(Prefix,RSymbol),
10690 append(DiffVars,PayloadArgs,RecCallVars),
10691 Body =.. [RSymbol|RecCallVars],
10692 findall(CH-CT,member([CH|CT],Differences),CPairs),
10693 once(pairup(CHs,CTs,CPairs)),
10694 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10695 )
10696 ).
10699 % split(list,int,before,at,after).
10701 split([X|Xs],I,Before,At,After) :-
10702 ( I == 1 ->
10703 Before = [],
10704 At = X,
10705 After = Xs
10706 ;
10707 J is I - 1,
10708 Before = [X|RBefore],
10709 split(Xs,J,RBefore,At,After)
10710 ).
10712 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10713 %
10714 % context ::= swap(functor,positions)
10715 % | index_functor(functor,arity,context)
10716 % | gct(Pattern,Context)
10718 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10719 functor(Term,_,Arity),
10720 functor(OriginalTerm,Functor,Arity),
10721 OriginalTerm =.. [_|OriginalArgs],
10722 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10723 Term =.. [_|Args],
10724 append(IndexArgs,OtherArgs,Args).
10725 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10726 Term0 =.. [Predicate|Args],
10727 split_at(Arity,Args,IndexArgs,RestArgs),
10728 Index =.. [Functor|IndexArgs],
10729 Term1 =.. [Predicate,Index|RestArgs],
10730 reconstruct_original_term(Context,Term1,OriginalTerm).
10731 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10732 copy_term_nat(PatternList,IndexTerms),
10733 term_variables(IndexTerms,Variables),
10734 Term0 =.. [Predicate|Args0],
10735 append(Variables,RestArgs,Args0),
10736 append(IndexTerms,RestArgs,Args1),
10737 Term1 =.. [Predicate|Args1],
10738 reconstruct_original_term(Context,Term1,OriginalTerm).
10739 % }}}
10741 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10742 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10743 %
10744 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10745 %
10746 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
10748 % {{{
10749 flatten_rules(Rules,Dict,FlatRules) :-
10750 flatten_rules1(Rules,Dict,FlatRulesList),
10751 flatten(FlatRulesList,FlatRules).
10753 flatten_rules1([],_,[]).
10754 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10755 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10756 flatten_rules1(Rules,Dict,FlatRulesList).
10758 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10759 flatten_rule(Rule,Dict,NRule).
10760 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10761 flatten_rule(Rule,Dict,NRule).
10762 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10763 flatten_heads(H,Dict,NH),
10764 flatten_body(B,Dict,NB).
10765 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10766 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10767 flatten_body(B,Dict,NB).
10768 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10769 flatten_heads(H,Dict,NH),
10770 flatten_body(B,Dict,NB).
10772 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10773 flatten_heads(H1,Dict,NH1),
10774 flatten_heads(H2,Dict,NH2).
10775 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10776 flatten_heads(H,Dict,NH).
10777 flatten_heads(H,Dict,NH) :-
10778 ( functor(H,C,N),
10779 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
10780 H =.. [_|AllArgs],
10781 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
10782 member(GroundArgs-Name,SFs),
10783 NH =.. [Name|OtherArgs]
10784 ;
10785 NH = H
10786 ).
10788 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
10789 conj2list(Guard,Guards),
10790 maplist(flatten_goal(Dict),Guards,NGuards),
10791 list2conj(NGuards,NGuard),
10792 conj2list(Body,Goals),
10793 maplist(flatten_goal(Dict),Goals,NGoals),
10794 list2conj(NGoals,NBody).
10795 flatten_body(Body,Dict,NBody) :-
10796 conj2list(Body,Goals),
10797 maplist(flatten_goal(Dict),Goals,NGoals),
10798 list2conj(NGoals,NBody).
10800 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
10801 flatten_goal(Dict,Goal,NGoal) :-
10802 ( is_specializable_goal(Goal,Dict,ArgPositions)
10803 ->
10804 specialize_goal(Goal,ArgPositions,NGoal)
10805 ; Goal = Mod : TheGoal,
10806 get_target_module(Module),
10807 Mod == Module,
10808 nonvar(TheGoal),
10809 is_specializable_goal(TheGoal,Dict,ArgPositions)
10810 ->
10811 specialize_goal(TheGoal,ArgPositions,NTheGoal),
10812 NGoal = Mod : NTheGoal
10813 ; partial_eval(Goal,NGoal)
10814 ->
10815 true
10816 ;
10817 NGoal = Goal
10818 ).
10820 %-------------------------------------------------------------------------------%
10821 % Specialize body/guard goal
10822 %-------------------------------------------------------------------------------%
10823 is_specializable_goal(Goal,Dict,ArgPositions) :-
10824 functor(Goal,C,N),
10825 memberchk(C/N-ArgPositions-_-_,Dict),
10826 args(ArgPositions,Goal,Args),
10827 ground(Args).
10829 specialize_goal(Goal,ArgPositions,NGoal) :-
10830 functor(Goal,C,N),
10831 Goal =.. [_|Args],
10832 split_args(ArgPositions,Args,GroundTerms,Others),
10833 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
10834 NGoal =.. [Functor|Others].
10836 %-------------------------------------------------------------------------------%
10837 % Partially evaluate predicates
10838 %-------------------------------------------------------------------------------%
10840 % append([],Y,Z) >--> Y = Z
10841 % append(X,[],Z) >--> X = Z
10842 partial_eval(append(L1,L2,L3),NGoal) :-
10843 ( L1 == [] ->
10844 NGoal = (L3 = L2)
10845 ; L2 == [] ->
10846 NGoal = (L3 = L1)
10848 ).
10849 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
10850 % where flatten(L1,L1')
10851 partial_eval(flatten_path(L1,L2),NGoal) :-
10852 nonvar(L1),
10853 flatten(L1,FlatterL1),
10854 FlatterL1 \== L1 ->
10855 NGoal = flatten_path(FlatterL1,L2).
10858 % }}}
10860 % }}}
10861 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10862 dump_code(Clauses) :-
10863 ( chr_pp_flag(dump,on) ->
10864 maplist(portray_clause,Clauses)
10865 ;
10866 true
10867 ).
10869 chr_banner :-
10870 chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]).