| blob | d545c957148c76147d51b85ee4ef43e92b6aab60 |
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 module_initializer(nb_setval(StoreName,[])).
3649 lookup_identifier_atom(Key,X,IX,Atom) :-
3650 atom_concat('lookup_identifier_',Key,LookupFunctor),
3651 Atom =.. [LookupFunctor,X,IX].
3653 identifier_label_atom(IndexType,IX,X,Atom) :-
3654 type_indexed_identifier_name(IndexType,identifier_label,Name),
3655 Atom =.. [Name,IX,X].
3657 multi_store_generate_attach_code([],_,L,L).
3658 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3659 generate_attach_code(ST,C,L,L1),
3660 multi_store_generate_attach_code(STs,C,L1,T).
3662 multi_inthash_store_initialisations([],_,L,L).
3663 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3664 use_auxiliary_module(chr_integertable_store),
3665 multi_hash_store_name(FA,Index,StoreName),
3666 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3667 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3668 L1 = L,
3669 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3670 multi_hash_store_initialisations([],_,L,L).
3671 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3672 use_auxiliary_module(chr_hashtable_store),
3673 multi_hash_store_name(FA,Index,StoreName),
3674 prolog_global_variable(StoreName),
3675 make_init_store_goal(StoreName,HT,InitStoreGoal),
3676 module_initializer((new_ht(HT),InitStoreGoal)),
3677 L1 = L,
3678 multi_hash_store_initialisations(Indexes,FA,L1,T).
3680 global_list_store_initialisation(C,L,T) :-
3681 ( is_stored(C) ->
3682 global_list_store_name(C,StoreName),
3683 prolog_global_variable(StoreName),
3684 make_init_store_goal(StoreName,[],InitStoreGoal),
3685 module_initializer(InitStoreGoal)
3686 ;
3687 true
3688 ),
3689 L = T.
3690 global_ground_store_initialisation(C,L,T) :-
3691 global_ground_store_name(C,StoreName),
3692 prolog_global_variable(StoreName),
3693 make_init_store_goal(StoreName,[],InitStoreGoal),
3694 module_initializer(InitStoreGoal),
3695 L = T.
3696 global_singleton_store_initialisation(C,L,T) :-
3697 global_singleton_store_name(C,StoreName),
3698 prolog_global_variable(StoreName),
3699 make_init_store_goal(StoreName,[],InitStoreGoal),
3700 module_initializer(InitStoreGoal),
3701 L = T.
3702 identifier_store_initialization(IndexType,L,T) :-
3703 use_auxiliary_module(chr_hashtable_store),
3704 identifier_store_name(IndexType,StoreName),
3705 prolog_global_variable(StoreName),
3706 make_init_store_goal(StoreName,HT,InitStoreGoal),
3707 module_initializer((new_ht(HT),InitStoreGoal)),
3708 L = T.
3711 multi_inthash_via_lookups([],_,L,L).
3712 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3713 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3714 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3715 L = [(Head :- Body)|L1],
3716 multi_inthash_via_lookups(Indexes,C,L1,T).
3717 multi_hash_lookups([],_,L,L).
3718 multi_hash_lookups([Index|Indexes],C,L,T) :-
3719 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3720 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3721 L = [(Head :- Body)|L1],
3722 multi_hash_lookups(Indexes,C,L1,T).
3724 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3725 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3726 Head =.. [Name,Key,SuspsList].
3728 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3729 %
3730 % Returns goal that performs hash table lookup.
3731 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3732 % INLINED:
3733 get_store_type(ConstraintSymbol,multi_store(Stores)),
3734 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3735 ( ground(Key) ->
3736 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3737 Goal = nb_getval(StoreName,SuspsList)
3738 ;
3739 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3740 Lookup =.. [IndexName,Key,StoreName],
3741 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3742 )
3743 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3744 ( ground(Key) ->
3745 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3746 Goal = nb_getval(StoreName,SuspsList)
3747 ;
3748 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3749 Lookup =.. [IndexName,Key,StoreName],
3750 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3751 )
3752 ; memberchk(multi_hash([Index]),Stores) ->
3753 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3754 make_get_store_goal(StoreName,HT,GetStoreGoal),
3755 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3756 Goal =
3757 (
3758 GetStoreGoal, % nb_getval(StoreName,HT),
3759 HashCall, % hash_term(Key,Hash),
3760 lookup_ht1(HT,Hash,Key,SuspsList)
3761 )
3762 ;
3763 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3764 Goal =
3765 (
3766 GetStoreGoal, % nb_getval(StoreName,HT),
3767 Lookup
3768 )
3769 )
3770 ; HashType == inthash ->
3771 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3772 make_get_store_goal(StoreName,HT,GetStoreGoal),
3773 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3774 Goal =
3775 (
3776 GetStoreGoal, % nb_getval(StoreName,HT),
3777 Lookup
3778 )
3779 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3780 % find alternative index
3781 % -> SubIndex + RestIndex
3782 % -> SubKey + RestKeys
3783 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3784 % instantiate rest goal?
3785 % Goal = (SubGoal,RestGoal)
3786 ).
3789 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3790 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3792 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3793 ( ground(Key) ->
3794 % This is based on a property of SWI-Prolog's
3795 % hash_term/2 predicate:
3796 % the hash value is stable over repeated invocations
3797 % of SWI-Prolog
3798 hash_term(Key,Hash),
3799 Call = true
3800 % ; Index = [IndexPos],
3801 % get_constraint_type(Constraint,ArgTypes),
3802 % nth1(IndexPos,ArgTypes,Type),
3803 % unalias_type(Type,NormalType),
3804 % memberchk_eq(NormalType,[int,natural]) ->
3805 % ( NormalType == int ->
3806 % Call = (Hash is abs(Key))
3807 % ;
3808 % Hash = Key,
3809 % Call = true
3810 % )
3811 % ;
3812 % nonvar(Key),
3813 % specialize_hash_term(Key,NewKey),
3814 % NewKey \== Key,
3815 % Call = hash_term(NewKey,Hash)
3816 ).
3818 % specialize_hash_term(Term,NewTerm) :-
3819 % ( ground(Term) ->
3820 % hash_term(Term,NewTerm)
3821 % ; var(Term) ->
3822 % NewTerm = Term
3823 % ;
3824 % Term =.. [F|Args],
3825 % maplist(specialize_hash_term,Args,NewArgs),
3826 % NewTerm =.. [F|NewArgs]
3827 % ).
3829 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3830 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3831 ( /* chr_pp_flag(experiment,off) ->
3832 true
3833 ; */ atomic(Key) ->
3834 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3835 ; ground(Key) ->
3836 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3837 ;
3838 ( Index = [Pos],
3839 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3840 is_chr_constants_type(Type,_,_)
3841 ->
3842 true
3843 ;
3844 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3845 )
3846 ),
3847 delay_phase_end(validate_store_type_assumptions,
3848 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3850 :- chr_constraint actual_atomic_multi_hash_keys/3.
3851 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3853 :- chr_constraint actual_ground_multi_hash_keys/3.
3854 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3856 :- chr_constraint actual_non_ground_multi_hash_key/2.
3857 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3859 /*
3860 actual_atomic_multi_hash_keys(C,Index,Keys)
3861 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3863 actual_ground_multi_hash_keys(C,Index,Keys)
3864 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3866 actual_non_ground_multi_hash_key(C,Index)
3867 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3868 */
3869 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3870 <=> append(Keys1,Keys2,Keys0),
3871 sort(Keys0,Keys),
3872 actual_atomic_multi_hash_keys(C,Index,Keys).
3874 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3875 <=> append(Keys1,Keys2,Keys0),
3876 sort(Keys0,Keys),
3877 actual_ground_multi_hash_keys(C,Index,Keys).
3879 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3880 <=> append(Keys1,Keys2,Keys0),
3881 sort(Keys0,Keys),
3882 actual_ground_multi_hash_keys(C,Index,Keys).
3884 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3885 <=> true.
3887 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3888 <=> true.
3890 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3891 <=> true.
3893 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3894 %
3895 % Returns predicate name of hash table lookup predicate.
3896 multi_hash_lookup_name(F/A,Index,Name) :-
3897 atom_concat_list(Index,IndexName),
3898 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3900 multi_hash_store_name(F/A,Index,Name) :-
3901 get_target_module(Mod),
3902 atom_concat_list(Index,IndexName),
3903 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3905 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3906 ( Index = [I] ->
3907 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3908 ;
3909 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
3910 Key =.. [k|Keys],
3911 list2conj(Bodies,KeyBody)
3912 ).
3914 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3915 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3917 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3918 ( Index = [I] ->
3919 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3920 ;
3921 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
3922 Key =.. [k|Keys],
3923 list2conj(Bodies,KeyBody)
3924 ).
3926 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3927 arg(Index,Head,OriginalArg),
3928 ( term_variables(OriginalArg,OriginalVars),
3929 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
3930 translate(OriginalVars,VarDict,Vars) ->
3931 Goal = true
3932 ;
3933 functor(Head,F,A),
3934 C = F/A,
3935 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3936 ).
3938 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3939 ( Index = [I] ->
3940 UsedVars = [I-Key]
3941 ;
3942 pairup(Index,Keys,UsedVars),
3943 Key =.. [k|Keys]
3944 ).
3946 args(Index,Head,KeyArgs) :-
3947 maplist(arg1(Head),Index,KeyArgs).
3949 split_args(Indexes,Args,IArgs,NIArgs) :-
3950 split_args(Indexes,Args,1,IArgs,NIArgs).
3952 split_args([],Args,_,[],Args).
3953 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
3954 NJ is J + 1,
3955 ( I == J ->
3956 IArgs = [Arg|Rest],
3957 split_args(Is,Args,NJ,Rest,NIArgs)
3958 ;
3959 NIArgs = [Arg|Rest],
3960 split_args([I|Is],Args,NJ,IArgs,Rest)
3961 ).
3964 %-------------------------------------------------------------------------------
3965 atomic_constants_code(C,Index,Constants,L,T) :-
3966 constants_store_index_name(C,Index,IndexName),
3967 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3968 append(Clauses,T,L).
3970 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3971 constants_store_name(C,Index,Constant,StoreName),
3972 Clause =.. [IndexName,Constant,StoreName].
3974 %-------------------------------------------------------------------------------
3975 ground_constants_code(C,Index,Terms,L,T) :-
3976 constants_store_index_name(C,Index,IndexName),
3977 maplist(constants_store_name(C,Index),Terms,StoreNames),
3978 length(Terms,N),
3979 replicate(N,[],More),
3980 trie_index([Terms|More],StoreNames,IndexName,L,T).
3982 constants_store_name(F/A,Index,Term,Name) :-
3983 get_target_module(Mod),
3984 term_to_atom(Term,Constant),
3985 term_to_atom(Index,IndexAtom),
3986 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3988 constants_store_index_name(F/A,Index,Name) :-
3989 get_target_module(Mod),
3990 term_to_atom(Index,IndexAtom),
3991 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3993 % trie index code {{{
3994 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3995 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3997 trie_step([],_,_,[],[],L,L) :- !.
3998 % length MorePatterns == length Patterns == length Results
3999 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
4000 MorePatterns = [List|_],
4001 length(List,N),
4002 aggregate_all(set(F/A),
4003 ( member(Pattern,Patterns),
4004 functor(Pattern,F,A)
4005 ),
4006 FAs),
4007 N1 is N + 1,
4008 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4010 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4011 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4012 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4013 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4015 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4016 Clause = (Head :- Body),
4017 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4018 N1 is N + 1,
4019 functor(Head,Symbol,N1),
4020 arg(1,Head,IndexPattern),
4021 Head =.. [_,_|RestArgs],
4022 once(append(Vs,[Result],RestArgs)),
4023 /* IndexPattern = F() */
4024 functor(IndexPattern,F,A),
4025 IndexPattern =.. [_|Args],
4026 append(Args,RestArgs,RecArgs),
4027 ( RecArgs == [Result] ->
4028 /* nothing more to match on */
4029 List = Tail,
4030 Body = true,
4031 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4032 MoreResults = [Result]
4033 ; /* more things to match on */
4034 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4035 ( MoreCases = [OneMoreCase] ->
4036 /* only one more thing to match on */
4037 List = Tail,
4038 Body = true,
4039 append([Cases,OneMoreCase,MoreResults],RecArgs)
4040 ;
4041 /* more than one thing to match on */
4042 /* [ x1,..., xn]
4043 [xs1,...,xsn]
4044 */
4045 pairup(Cases,MoreCases,CasePairs),
4046 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4047 append(Args,Vs,[First|Rest]),
4048 First-Rest = CommonPatternPair,
4049 % Body = RSymbol(DiffVars,Result)
4050 gensym(Prefix,RSymbol),
4051 append(DiffVars,[Result],RecCallVars),
4052 Body =.. [RSymbol|RecCallVars],
4053 maplist(head_tail,Differences,CHs,CTs),
4054 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4055 )
4056 ).
4058 head_tail([H|T],H,T).
4060 rec_cases([],[],[],_,[],[],[]).
4061 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4062 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4063 Cases = [Case|NCases],
4064 MoreCases = [MoreCase|NMoreCases],
4065 MoreResults = [Result|NMoreResults],
4066 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4067 ;
4068 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4069 ).
4070 % }}}
4072 %% common_pattern(+terms,-term,-vars,-differences) is det.
4073 common_pattern(Ts,T,Vars,Differences) :-
4074 fold1(gct,Ts,T),
4075 term_variables(T,Vars),
4076 findall(Vars,member(T,Ts),Differences).
4078 gct(T1,T2,T) :-
4079 gct_(T1,T2,T,[],_).
4081 gct_(T1,T2,T,Dict0,Dict) :-
4082 ( nonvar(T1),
4083 nonvar(T2),
4084 functor(T1,F1,A1),
4085 functor(T2,F2,A2),
4086 F1 == F2,
4087 A1 == A2 ->
4088 functor(T,F1,A1),
4089 T1 =.. [_|Args1],
4090 T2 =.. [_|Args2],
4091 T =.. [_|Args],
4092 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4093 ;
4094 /* T is a variable */
4095 ( lookup_eq(Dict0,T1+T2,T) ->
4096 /* we already have a variable for this difference */
4097 Dict = Dict0
4098 ;
4099 /* T is a fresh variable */
4100 Dict = [(T1+T2)-T|Dict0]
4101 )
4102 ).
4105 fold1(P,[Head|Tail],Result) :-
4106 fold(Tail,P,Head,Result).
4108 fold([],_,Acc,Acc).
4109 fold([X|Xs],P,Acc,Res) :-
4110 call(P,X,Acc,NAcc),
4111 fold(Xs,P,NAcc,Res).
4113 maplist_dcg(P,L1,L2,L) -->
4114 maplist_dcg_(L1,L2,L,P).
4116 maplist_dcg_([],[],[],_) --> [].
4117 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4118 call(P,X,Y,Z),
4119 maplist_dcg_(Xs,Ys,Zs,P).
4121 %-------------------------------------------------------------------------------
4122 global_list_store_name(F/A,Name) :-
4123 get_target_module(Mod),
4124 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4125 global_ground_store_name(F/A,Name) :-
4126 get_target_module(Mod),
4127 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4128 global_singleton_store_name(F/A,Name) :-
4129 get_target_module(Mod),
4130 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4132 identifier_store_name(TypeName,Name) :-
4133 get_target_module(Mod),
4134 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4136 :- chr_constraint prolog_global_variable/1.
4137 :- chr_option(mode,prolog_global_variable(+)).
4139 :- chr_constraint prolog_global_variables/1.
4140 :- chr_option(mode,prolog_global_variables(-)).
4142 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4144 prolog_global_variables(List), prolog_global_variable(Name) <=>
4145 List = [Name|Tail],
4146 prolog_global_variables(Tail).
4147 prolog_global_variables(List) <=> List = [].
4149 %% SWI begin
4150 prolog_global_variables_code(Code) :-
4151 prolog_global_variables(Names),
4152 ( Names == [] ->
4153 Code = []
4154 ;
4155 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4156 Code = [(:- dynamic user:exception/3),
4157 (:- multifile user:exception/3),
4158 (user:exception(undefined_global_variable,Name,retry) :-
4159 (
4160 '$chr_prolog_global_variable'(Name),
4161 '$chr_initialization'
4162 )
4163 )
4164 |
4165 NameDeclarations
4166 ]
4167 ).
4168 %% SWI end
4169 %% SICStus begin
4170 % prolog_global_variables_code([]).
4171 %% SICStus end
4172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4173 %sbag_member_call(S,L,sysh:mem(S,L)).
4174 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4175 %sbag_member_call(S,L,member(S,L)).
4176 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4177 %update_mutable_call(A,B,setarg(1, B, A)).
4178 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4179 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4181 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4182 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4183 % create_get_mutable(Value,Field,Get1).
4184 %
4185 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4186 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4187 % update_mutable_call(NewValue,Field,Set).
4188 %
4189 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4190 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4191 % create_get_mutable_ref(Value,Field,Get1),
4192 % update_mutable_call(NewValue,Field,Set).
4193 %
4194 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4195 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4196 % create_mutable_call(Value,Field,Create).
4197 %
4198 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4199 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4200 % create_get_mutable(Value,Field,Get).
4201 %
4202 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4203 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4204 % create_get_mutable_ref(Value,Field,Get),
4205 % update_mutable_call(NewValue,Field,Set).
4207 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4208 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4210 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4211 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4213 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4214 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4215 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4217 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4218 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4220 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4221 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4223 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4224 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4225 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4227 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4229 enumerate_stores_code(Constraints,[Clause|List]) :-
4230 Head = '$enumerate_constraints'(Constraint),
4231 Clause = ( Head :- Body),
4232 enumerate_store_bodies(Constraints,Constraint,List),
4233 ( List = [] ->
4234 Body = fail
4235 ;
4236 Body = ( nonvar(Constraint) ->
4237 functor(Constraint,Functor,_),
4238 '$enumerate_constraints'(Functor,Constraint)
4239 ;
4240 '$enumerate_constraints'(_,Constraint)
4241 )
4242 ).
4244 enumerate_store_bodies([],_,[]).
4245 enumerate_store_bodies([C|Cs],Constraint,L) :-
4246 ( is_stored(C) ->
4247 get_store_type(C,StoreType),
4248 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4249 true
4250 ;
4251 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4252 ),
4253 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4254 C = F/_,
4255 Constraint0 =.. [F|Arguments],
4256 Head = '$enumerate_constraints'(F,Constraint),
4257 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4258 L = [(Head :- Body)|T]
4259 ;
4260 L = T
4261 ),
4262 enumerate_store_bodies(Cs,Constraint,T).
4264 enumerate_store_body(default,C,Susp,Body) :-
4265 global_list_store_name(C,StoreName),
4266 sbag_member_call(Susp,List,Sbag),
4267 make_get_store_goal(StoreName,List,GetStoreGoal),
4268 Body =
4269 (
4270 GetStoreGoal, % nb_getval(StoreName,List),
4271 Sbag
4272 ).
4273 % get_constraint_index(C,Index),
4274 % get_target_module(Mod),
4275 % get_max_constraint_index(MaxIndex),
4276 % Body1 =
4277 % (
4278 % 'chr default_store'(GlobalStore),
4279 % get_attr(GlobalStore,Mod,Attr)
4280 % ),
4281 % ( MaxIndex > 1 ->
4282 % NIndex is Index + 1,
4283 % sbag_member_call(Susp,List,Sbag),
4284 % Body2 =
4285 % (
4286 % arg(NIndex,Attr,List),
4287 % Sbag
4288 % )
4289 % ;
4290 % sbag_member_call(Susp,Attr,Sbag),
4291 % Body2 = Sbag
4292 % ),
4293 % Body = (Body1,Body2).
4294 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4295 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4296 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4297 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4298 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4299 Completeness == complete, % fail if incomplete
4300 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4301 list2disj(Disjuncts, Disjunction),
4302 Body = ( Disjunction, member(Susp,Susps) ).
4303 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4304 constants_store_name(C,Index,Constant,StoreName).
4306 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4307 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4308 enumerate_store_body(global_ground,C,Susp,Body) :-
4309 global_ground_store_name(C,StoreName),
4310 sbag_member_call(Susp,List,Sbag),
4311 make_get_store_goal(StoreName,List,GetStoreGoal),
4312 Body =
4313 (
4314 GetStoreGoal, % nb_getval(StoreName,List),
4315 Sbag
4316 ).
4317 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4318 Body = fail.
4319 enumerate_store_body(global_singleton,C,Susp,Body) :-
4320 global_singleton_store_name(C,StoreName),
4321 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4322 Body =
4323 (
4324 GetStoreGoal, % nb_getval(StoreName,Susp),
4325 Susp \== []
4326 ).
4327 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4328 ( memberchk(global_ground,STs) ->
4329 enumerate_store_body(global_ground,C,Susp,Body)
4330 ;
4331 once((
4332 member(ST,STs),
4333 enumerate_store_body(ST,C,Susp,Body)
4334 ))
4335 ).
4336 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4337 Body = fail.
4338 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4339 Body = fail.
4341 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4342 multi_hash_store_name(C,I,StoreName),
4343 B =
4344 (
4345 nb_getval(StoreName,HT),
4346 value_iht(HT,Susp)
4347 ).
4348 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4349 multi_hash_store_name(C,I,StoreName),
4350 make_get_store_goal(StoreName,HT,GetStoreGoal),
4351 B =
4352 (
4353 GetStoreGoal, % nb_getval(StoreName,HT),
4354 value_ht(HT,Susp)
4355 ).
4357 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4358 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4361 :- chr_constraint
4362 background_info/1,
4363 background_info/2,
4364 get_bg_info/1,
4365 get_bg_info/2,
4366 get_bg_info_answer/1.
4368 background_info(X), background_info(Y) <=>
4369 append(X,Y,XY), background_info(XY).
4370 background_info(X) \ get_bg_info(Q) <=> Q=X.
4371 get_bg_info(Q) <=> Q = [].
4373 background_info(T,I), get_bg_info(A,Q) ==>
4374 copy_term_nat(T,T1),
4375 subsumes_chk(T1,A)
4376 |
4377 copy_term_nat(T-I,A-X),
4378 get_bg_info_answer([X]).
4379 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4380 append(X,Y,XY), get_bg_info_answer(XY).
4382 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4383 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4388 :- chr_constraint
4389 prev_guard_list/8,
4390 prev_guard_list/6,
4391 simplify_guards/1,
4392 set_all_passive/1.
4394 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4395 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4396 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4397 :- chr_option(mode,simplify_guards(+)).
4398 :- chr_option(mode,set_all_passive(+)).
4400 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4401 % GUARD SIMPLIFICATION
4402 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4403 % If the negation of the guards of earlier rules entails (part of)
4404 % the current guard, the current guard can be simplified. We can only
4405 % use earlier rules with a head that matches if the head of the current
4406 % rule does, and which make it impossible for the current rule to match
4407 % if they fire (i.e. they shouldn't be propagation rules and their
4408 % head constraints must be subsets of those of the current rule).
4409 % At this point, we know for sure that the negation of the guard
4410 % of such a rule has to be true (otherwise the earlier rule would have
4411 % fired, because of the refined operational semantics), so we can use
4412 % that information to simplify the guard by replacing all entailed
4413 % conditions by true/0. As a consequence, the never-stored analysis
4414 % (in a further phase) will detect more cases of never-stored constraints.
4415 %
4416 % e.g. c(X),d(Y) <=> X > 0 | ...
4417 % e(X) <=> X < 0 | ...
4418 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4419 % \____________/
4420 % true
4422 guard_simplification :-
4423 ( chr_pp_flag(guard_simplification,on) ->
4424 precompute_head_matchings,
4425 simplify_guards(1)
4426 ;
4427 true
4428 ).
4430 % for every rule, we create a prev_guard_list where the last argument
4431 % eventually is a list of the negations of earlier guards
4432 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4433 <=>
4434 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4435 append(Head1,Head2,Heads),
4436 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4437 tree_set_empty(Done),
4438 multiple_occ_constraints_checked(Done),
4439 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4441 append(IDs1,IDs2,IDs),
4442 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4443 empty_q(EmptyHeap),
4444 insert_list_q(HeapData,EmptyHeap,Heap),
4445 next_prev_rule(Heap,_,Heap1),
4446 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4447 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4448 NextRule is RuleNb+1,
4449 simplify_guards(NextRule).
4451 next_prev_rule(Heap,RuleNb,NHeap) :-
4452 ( find_min_q(Heap,_-Priority) ->
4453 Priority = (-RuleNb),
4454 normalize_heap(Heap,Priority,NHeap)
4455 ;
4456 RuleNb = 0,
4457 NHeap = Heap
4458 ).
4460 normalize_heap(Heap,Priority,NHeap) :-
4461 ( find_min_q(Heap,_-Priority) ->
4462 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4463 ( O > 1 ->
4464 NO is O -1,
4465 get_occurrence(C,NO,RuleNb,_),
4466 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4467 ;
4468 Heap2 = Heap1
4469 ),
4470 normalize_heap(Heap2,Priority,NHeap)
4471 ;
4472 NHeap = Heap
4473 ).
4475 % no more rule
4476 simplify_guards(_)
4477 <=>
4478 true.
4480 % The negation of the guard of a non-propagation rule is added
4481 % if its kept head constraints are a subset of the kept constraints of
4482 % the rule we're working on, and its removed head constraints (at least one)
4483 % are a subset of the removed constraints.
4485 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4486 <=>
4487 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4488 H1 \== [],
4489 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4490 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4491 |
4492 append(H1,H2,Heads),
4493 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4494 append(GuardList,DerivedInfo,GL1),
4495 normalize_conj_list(GL1,GL),
4496 append(GH_New1,GH,GH1),
4497 normalize_conj_list(GH1,GH_New),
4498 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4499 % PrevPrevRuleNb is PrevRuleNb-1,
4500 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4502 % if this isn't the case, we skip this one and try the next rule
4503 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4504 <=>
4505 ( N > 0 ->
4506 next_prev_rule(Heap,N1,NHeap),
4507 % N1 is N-1,
4508 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4509 ;
4510 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4511 ).
4513 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4514 <=>
4515 GH \== []
4516 |
4517 head_types_modes_condition(GH,H,TypeInfo),
4518 conj2list(TypeInfo,TI),
4519 term_variables(H,HeadVars),
4520 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4521 normalize_conj_list(Info,InfoL),
4522 append(H,InfoL,RelevantTerms),
4523 add_background_info([G|RelevantTerms],BGInfo),
4524 append(InfoL,BGInfo,AllInfo_),
4525 normalize_conj_list(AllInfo_,AllInfo),
4526 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4528 head_types_modes_condition([],H,true).
4529 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4530 types_modes_condition(H,GH,TI1),
4531 head_types_modes_condition(GHs,H,TI2).
4533 add_background_info(Term,Info) :-
4534 get_bg_info(GeneralInfo),
4535 add_background_info2(Term,TermInfo),
4536 append(GeneralInfo,TermInfo,Info).
4538 add_background_info2(X,[]) :- var(X), !.
4539 add_background_info2([],[]) :- !.
4540 add_background_info2([X|Xs],Info) :- !,
4541 add_background_info2(X,Info1),
4542 add_background_info2(Xs,Infos),
4543 append(Info1,Infos,Info).
4545 add_background_info2(X,Info) :-
4546 (functor(X,_,A), A>0 ->
4547 X =.. [_|XArgs],
4548 add_background_info2(XArgs,XArgInfo)
4549 ;
4550 XArgInfo = []
4551 ),
4552 get_bg_info(X,XInfo),
4553 append(XInfo,XArgInfo,Info).
4555 %%
4556 % when all earlier guards are added or skipped, we simplify the guard.
4557 % if it's different from the original one, we change the rule
4559 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4560 <=>
4561 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4562 G \== true, % let's not try to simplify this ;)
4563 append(M,GuardList,Info),
4564 (% if guard + context is a contradiction, it should be simplified to "fail"
4565 conj2list(G,GL), append(Info,GL,GuardWithContext),
4566 guard_entailment:entails_guard(GuardWithContext,fail) ->
4567 SimpleGuard = fail
4568 ;
4569 % otherwise we try to remove redundant conjuncts
4570 simplify_guard(G,B,Info,SimpleGuard,NB)
4571 ),
4572 G \== SimpleGuard % only do this if we can change the guard
4573 |
4574 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4575 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4577 %% normalize_conj_list(+List,-NormalList) is det.
4578 %
4579 % Removes =true= elements and flattens out conjunctions.
4581 normalize_conj_list(List,NormalList) :-
4582 list2conj(List,Conj),
4583 conj2list(Conj,NormalList).
4585 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4586 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4587 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4589 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4590 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4591 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4592 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4593 append(Renaming1,ExtraRenaming,Renaming2),
4594 list2conj(PrevMatchings,Match),
4595 negate_b(Match,HeadsDontMatch),
4596 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4597 list2conj(HeadsMatch,HeadsMatchBut),
4598 term_variables(Renaming2,RenVars),
4599 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4600 new_vars(MGVars,RenVars,ExtraRenaming2),
4601 append(Renaming2,ExtraRenaming2,Renaming),
4602 ( PrevGuard == true -> % true can't fail
4603 Info_ = HeadsDontMatch
4604 ;
4605 negate_b(PrevGuard,TheGuardFailed),
4606 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4607 ),
4608 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4609 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4610 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4611 list2conj(RenamedMatchings_,RenamedMatchings),
4612 apply_guard_wrt_term(H,RenamedG2,GH2),
4613 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4614 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4616 simplify_guard(G,B,Info,SG,NB) :-
4617 conj2list(G,LG),
4618 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4619 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4620 list2conj(SGL,SG).
4623 new_vars([],_,[]).
4624 new_vars([A|As],RV,ER) :-
4625 ( memberchk_eq(A,RV) ->
4626 new_vars(As,RV,ER)
4627 ;
4628 ER = [A-NewA,NewA-A|ER2],
4629 new_vars(As,RV,ER2)
4630 ).
4632 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4633 %
4634 % check if a list of constraints is a subset of another list of constraints
4635 % (multiset-subset), meanwhile computing a variable renaming to convert
4636 % one into the other.
4637 head_subset(H,Head,Renaming) :-
4638 head_subset(H,Head,Renaming,[],_).
4640 head_subset([],Remainder,Renaming,Renaming,Remainder).
4641 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4642 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4643 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4645 % check if A is in the list, remove it from Headleft
4646 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4647 ( variable_replacement(A,X,Acc,Renaming),
4648 Remainder = Xs
4649 ;
4650 Remainder = [X|RRemainder],
4651 head_member(Xs,A,Renaming,Acc,RRemainder)
4652 ).
4653 %-------------------------------------------------------------------------------%
4654 % memoing code to speed up repeated computation
4656 :- chr_constraint precompute_head_matchings/0.
4658 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4659 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4660 append(H1,H2,Heads),
4661 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4662 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4663 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4665 precompute_head_matchings <=> true.
4667 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4668 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4670 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4671 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4673 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4674 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4675 <=>
4676 Q1 = NHeads,
4677 Q2 = Matchings.
4678 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4680 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4681 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4682 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4683 %-------------------------------------------------------------------------------%
4685 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4686 extract_arguments(Heads,Arguments),
4687 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4688 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4690 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4691 extract_arguments(Heads,Arguments),
4692 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4693 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4695 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4696 extract_arguments(Heads,Arguments1),
4697 extract_arguments(MatchingFreeHeads,Arguments2),
4698 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4700 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4701 %
4702 % Returns list of arguments of given list of constraints.
4703 extract_arguments([],[]).
4704 extract_arguments([Constraint|Constraints],AllArguments) :-
4705 Constraint =.. [_|Arguments],
4706 append(Arguments,RestArguments,AllArguments),
4707 extract_arguments(Constraints,RestArguments).
4709 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4710 %
4711 % Substitutes arguments of constraints with those in the given list.
4713 substitute_arguments([],[],[]).
4714 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4715 functor(Constraint,F,N),
4716 split_at(N,Variables,Arguments,RestVariables),
4717 NConstraint =.. [F|Arguments],
4718 substitute_arguments(Constraints,RestVariables,NConstraints).
4720 make_matchings_explicit([],[],_,MC,MC,[]).
4721 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4722 ( var(Arg) ->
4723 ( memberchk_eq(Arg,VarAcc) ->
4724 list2disj(MatchingCondition,MatchingCondition_disj),
4725 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4726 NVarAcc = VarAcc
4727 ;
4728 Matchings = RestMatchings,
4729 NewVar = Arg,
4730 NVarAcc = [Arg|VarAcc]
4731 ),
4732 MatchingCondition2 = MatchingCondition
4733 ;
4734 functor(Arg,F,A),
4735 Arg =.. [F|RecArgs],
4736 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4737 FlatArg =.. [F|RecVars],
4738 ( RecMatchings == [] ->
4739 Matchings = [functor(NewVar,F,A)|RestMatchings]
4740 ;
4741 list2conj(RecMatchings,ArgM_conj),
4742 list2disj(MatchingCondition,MatchingCondition_disj),
4743 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4744 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4745 ),
4746 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4747 term_variables(Args,ArgVars),
4748 append(ArgVars,VarAcc,NVarAcc)
4749 ),
4750 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4753 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4754 %
4755 % Returns list of new variables and list of pairwise unifications between given list and variables.
4757 make_matchings_explicit_not_negated([],[],[]).
4758 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4759 Matchings = [Var = X|RMatchings],
4760 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4762 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4763 %
4764 % (Partially) applies substitutions of =Goal= to given list.
4766 apply_guard_wrt_term([],_Guard,[]).
4767 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4768 ( var(Term) ->
4769 apply_guard_wrt_variable(Guard,Term,NTerm)
4770 ;
4771 Term =.. [F|HArgs],
4772 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4773 NTerm =.. [F|NewHArgs]
4774 ),
4775 apply_guard_wrt_term(RH,Guard,RGH).
4777 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4778 %
4779 % (Partially) applies goal =Guard= wrt variable.
4781 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4782 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4783 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4784 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4785 ( Guard = (X = Y), Variable == X ->
4786 NVariable = Y
4787 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4788 functor(NVariable,Functor,Arity)
4789 ;
4790 NVariable = Variable
4791 ).
4794 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4795 % ALWAYS FAILING GUARDS
4796 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4798 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4799 ==>
4800 chr_pp_flag(check_impossible_rules,on),
4801 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4802 conj2list(G,GL),
4803 append(M,GuardList,Info),
4804 append(Info,GL,GuardWithContext),
4805 guard_entailment:entails_guard(GuardWithContext,fail)
4806 |
4807 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4808 set_all_passive(RuleNb).
4810 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4811 % HEAD SIMPLIFICATION
4812 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4814 % now we check the head matchings (guard may have been simplified meanwhile)
4815 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4816 <=>
4817 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4818 simplify_heads(M,GuardList,G,B,NewM,NewB),
4819 NewM \== [],
4820 extract_arguments(Head1,VH1),
4821 extract_arguments(Head2,VH2),
4822 extract_arguments(H,VH),
4823 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4824 substitute_arguments(Head1,H1,NewH1),
4825 substitute_arguments(Head2,H2,NewH2),
4826 append(NewB,NewB_,NewBody),
4827 list2conj(NewBody,BodyMatchings),
4828 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4829 (Head1 \== NewH1 ; Head2 \== NewH2 )
4830 |
4831 rule(RuleNb,NewRule).
4833 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4834 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4835 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4837 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4838 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4839 ( NH == M ->
4840 H2_ = M,
4841 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4842 ;
4843 (M = functor(X,F,A), NH == X ->
4844 length(A_args,A),
4845 (var(H2) ->
4846 NewB1 = [],
4847 H2_ =.. [F|A_args]
4848 ;
4849 H2 =.. [F|OrigArgs],
4850 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4851 H2_ =.. [F|A_args_]
4852 ),
4853 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4854 append(NewB1,NewB2,NewB)
4855 ;
4856 H2_ = H2,
4857 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4858 )
4859 ).
4861 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4862 ( NH == M ->
4863 H1_ = M,
4864 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4865 ;
4866 (M = functor(X,F,A), NH == X ->
4867 length(A_args,A),
4868 (var(H1) ->
4869 NewB1 = [],
4870 H1_ =.. [F|A_args]
4871 ;
4872 H1 =.. [F|OrigArgs],
4873 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4874 H1_ =.. [F|A_args_]
4875 ),
4876 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4877 append(NewB1,NewB2,NewB)
4878 ;
4879 H1_ = H1,
4880 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4881 )
4882 ).
4884 use_same_args([],[],[],_,_,[]).
4885 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4886 var(OA),!,
4887 Out = OA,
4888 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4889 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4890 nonvar(OA),!,
4891 ( common_variables(OA,Body) ->
4892 NewB = [NA = OA|NextB]
4893 ;
4894 NewB = NextB
4895 ),
4896 Out = NA,
4897 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4900 simplify_heads([],_GuardList,_G,_Body,[],[]).
4901 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4902 M = (A = B),
4903 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4904 guard_entailment:entails_guard(GuardList,(A=B)) ->
4905 ( common_variables(B,G-RM-GuardList) ->
4906 NewB = NextB,
4907 NewM = NextM
4908 ;
4909 ( common_variables(B,Body) ->
4910 NewB = [A = B|NextB]
4911 ;
4912 NewB = NextB
4913 ),
4914 NewM = [A|NextM]
4915 )
4916 ;
4917 ( nonvar(B), functor(B,BFu,BAr),
4918 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4919 NewB = NextB,
4920 ( common_variables(B,G-RM-GuardList) ->
4921 NewM = NextM
4922 ;
4923 NewM = [functor(A,BFu,BAr)|NextM]
4924 )
4925 ;
4926 NewM = NextM,
4927 NewB = NextB
4928 )
4929 ),
4930 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4932 common_variables(B,G) :-
4933 term_variables(B,BVars),
4934 term_variables(G,GVars),
4935 intersect_eq(BVars,GVars,L),
4936 L \== [].
4939 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4940 set_all_passive(_) <=> true.
4944 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4945 % OCCURRENCE SUBSUMPTION
4946 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4948 :- chr_constraint
4949 first_occ_in_rule/4,
4950 next_occ_in_rule/6.
4952 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4953 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4955 :- chr_constraint multiple_occ_constraints_checked/1.
4956 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4958 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4959 occurrence(C,O,RuleNb,ID,_),
4960 occurrence(C,O2,RuleNb,ID2,_),
4961 rule(RuleNb,Rule)
4962 \
4963 multiple_occ_constraints_checked(Done)
4964 <=>
4965 O < O2,
4966 chr_pp_flag(occurrence_subsumption,on),
4967 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4968 H1 \== [],
4969 \+ tree_set_memberchk(C,Done)
4970 |
4971 first_occ_in_rule(RuleNb,C,O,ID),
4972 tree_set_add(Done,C,NDone),
4973 multiple_occ_constraints_checked(NDone).
4975 % Find first occurrence of constraint =C= in rule =RuleNb=
4976 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4977 <=>
4978 O < O2
4979 |
4980 first_occ_in_rule(RuleNb,C,O,ID).
4982 first_occ_in_rule(RuleNb,C,O,ID_o1)
4983 <=>
4984 C = F/A,
4985 functor(FreshHead,F,A),
4986 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4988 % Skip passive occurrences.
4989 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4990 <=>
4991 O2 is O+1
4992 |
4993 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4995 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)
4996 <=>
4997 O2 is O+1,
4998 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4999 |
5000 append(H1,H2,Heads),
5001 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5002 ( ExtraCond == [chr_pp_void_info] ->
5003 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5004 ;
5005 append(ExtraCond,Cond,NewCond),
5006 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5007 copy_term(GuardList,FGuardList),
5008 variable_replacement(GuardList,FGuardList,GLRepl),
5009 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5010 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5011 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5012 append(NewCond,GuardList2,BigCond),
5013 append(BigCond,GuardList3,BigCond2),
5014 copy_with_variable_replacement(M,M2,Repl),
5015 copy_with_variable_replacement(M,M3,Repl2),
5016 append(M3,BigCond2,BigCond3),
5017 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5018 list2conj(CheckCond,OccSubsum),
5019 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5020 ( OccSubsum \= chr_pp_void_info ->
5021 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5022 passive(RuleNb,ID_o2)
5023 ;
5024 true
5025 )
5026 ;
5027 true
5028 ),!,
5029 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5030 ).
5033 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5034 <=>
5035 true.
5037 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5038 <=>
5039 true.
5041 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5042 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5043 append(ID2,ID1,IDs),
5044 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5045 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5046 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5047 copy_with_variable_replacement(G,FG,Repl),
5048 extract_explicit_matchings(FG,FG2),
5049 negate_b(FG2,NotFG),
5050 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5051 ( subsumes(FH,FH2) ->
5052 FailCond = [(NotFG;FMPCond)]
5053 ;
5054 % in this case, not much can be done
5055 % e.g. c(f(...)), c(g(...)) <=> ...
5056 FailCond = [chr_pp_void_info]
5057 ).
5059 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5060 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5061 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5062 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5063 Cond = (chr_pp_not_in_store(H);Cond1),
5064 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5066 extract_explicit_matchings((A,B),D) :- !,
5067 ( extract_explicit_matchings(A) ->
5068 extract_explicit_matchings(B,D)
5069 ;
5070 D = (A,E),
5071 extract_explicit_matchings(B,E)
5072 ).
5073 extract_explicit_matchings(A,D) :- !,
5074 ( extract_explicit_matchings(A) ->
5075 D = true
5076 ;
5077 D = A
5078 ).
5080 extract_explicit_matchings(A=B) :-
5081 var(A), var(B), !, A=B.
5082 extract_explicit_matchings(A==B) :-
5083 var(A), var(B), !, A=B.
5085 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5086 % TYPE INFORMATION
5087 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5089 :- chr_constraint
5090 type_definition/2,
5091 type_alias/2,
5092 constraint_type/2,
5093 get_type_definition/2,
5094 get_constraint_type/2.
5097 :- chr_option(mode,type_definition(?,?)).
5098 :- chr_option(mode,get_type_definition(?,?)).
5099 :- chr_option(mode,type_alias(?,?)).
5100 :- chr_option(mode,constraint_type(+,+)).
5101 :- chr_option(mode,get_constraint_type(+,-)).
5103 assert_constraint_type(Constraint,ArgTypes) :-
5104 ( ground(ArgTypes) ->
5105 constraint_type(Constraint,ArgTypes)
5106 ;
5107 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5108 ).
5110 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5111 % Consistency checks of type aliases
5113 type_alias(T1,T2) <=>
5114 var(T1)
5115 |
5116 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5118 type_alias(T1,T2) <=>
5119 var(T2)
5120 |
5121 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5123 type_alias(T,T2) <=>
5124 functor(T,F,A),
5125 functor(T2,F,A),
5126 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5127 |
5128 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5130 type_alias(T1,A1), type_alias(T2,A2) <=>
5131 functor(T1,F,A),
5132 functor(T2,F,A),
5133 \+ (T1\=T2)
5134 |
5135 copy_term_nat(T1,T1_),
5136 copy_term_nat(T2,T2_),
5137 T1_ = T2_,
5138 chr_error(type_error,
5139 '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_]).
5141 type_alias(T,B) \ type_alias(X,T2) <=>
5142 functor(T,F,A),
5143 functor(T2,F,A),
5144 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5145 subsumes(T1,T3)
5146 |
5147 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5148 type_alias(X2,D1).
5150 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5151 % Consistency checks of type definitions
5153 type_definition(T1,_), type_definition(T2,_)
5154 <=>
5155 functor(T1,F,A), functor(T2,F,A)
5156 |
5157 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5159 type_definition(T1,_), type_alias(T2,_)
5160 <=>
5161 functor(T1,F,A), functor(T2,F,A)
5162 |
5163 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5165 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5166 %% get_type_definition(+Type,-Definition) is semidet.
5167 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5169 get_type_definition(T,Def)
5170 <=>
5171 \+ ground(T)
5172 |
5173 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5175 type_alias(T,D) \ get_type_definition(T2,Def)
5176 <=>
5177 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5178 copy_term_nat((T,D),(T1,D1)),T1=T2
5179 |
5180 ( get_type_definition(D1,Def) ->
5181 true
5182 ;
5183 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5184 ).
5186 type_definition(T,D) \ get_type_definition(T2,Def)
5187 <=>
5188 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5189 copy_term_nat((T,D),(T1,D1)),T1=T2
5190 |
5191 Def = D1.
5193 get_type_definition(Type,Def)
5194 <=>
5195 atomic_builtin_type(Type,_,_)
5196 |
5197 Def = [Type].
5199 get_type_definition(Type,Def)
5200 <=>
5201 compound_builtin_type(Type,_,_,_)
5202 |
5203 Def = [Type].
5205 get_type_definition(X,Y) <=> fail.
5207 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5208 %% get_type_definition_det(+Type,-Definition) is det.
5209 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5210 get_type_definition_det(Type,Definition) :-
5211 ( get_type_definition(Type,Definition) ->
5212 true
5213 ;
5214 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5215 ).
5217 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5218 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5219 %
5220 % Return argument types of =ConstraintSymbol=, but fails if none where
5221 % declared.
5222 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5223 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5224 get_constraint_type(_,_) <=> fail.
5226 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5227 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5228 %
5229 % Like =get_constraint_type/2=, but returns list of =any= types when
5230 % no types are declared.
5231 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5232 get_constraint_type_det(ConstraintSymbol,Types) :-
5233 ( get_constraint_type(ConstraintSymbol,Types) ->
5234 true
5235 ;
5236 ConstraintSymbol = _ / N,
5237 replicate(N,any,Types)
5238 ).
5239 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5240 %% unalias_type(+Alias,-Type) is det.
5241 %
5242 % Follows alias chain until base type is reached.
5243 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5244 :- chr_constraint unalias_type/2.
5246 unalias_var @
5247 unalias_type(Alias,BaseType)
5248 <=>
5249 var(Alias)
5250 |
5251 BaseType = Alias.
5253 unalias_alias @
5254 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5255 <=>
5256 nonvar(AliasProtoType),
5257 nonvar(Alias),
5258 functor(AliasProtoType,F,A),
5259 functor(Alias,F,A),
5260 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5261 Alias = AliasInstance
5262 |
5263 unalias_type(Type,BaseType).
5265 unalias_type_definition @
5266 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5267 <=>
5268 nonvar(ProtoType),
5269 nonvar(Alias),
5270 functor(ProtoType,F,A),
5271 functor(Alias,F,A)
5272 |
5273 BaseType = Alias.
5275 unalias_atomic_builtin @
5276 unalias_type(Alias,BaseType)
5277 <=>
5278 atomic_builtin_type(Alias,_,_)
5279 |
5280 BaseType = Alias.
5282 unalias_compound_builtin @
5283 unalias_type(Alias,BaseType)
5284 <=>
5285 compound_builtin_type(Alias,_,_,_)
5286 |
5287 BaseType = Alias.
5289 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5290 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5291 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5292 :- chr_constraint types_modes_condition/3.
5293 :- chr_option(mode,types_modes_condition(+,+,?)).
5294 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5296 types_modes_condition([],[],T) <=> T=true.
5298 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5299 <=>
5300 functor(Head,F,A)
5301 |
5302 Head =.. [_|Args],
5303 Condition = (ModesCondition, TypesCondition, RestCondition),
5304 modes_condition(Modes,Args,ModesCondition),
5305 get_constraint_type_det(F/A,Types),
5306 UnrollHead =.. [_|RealArgs],
5307 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5308 types_modes_condition(Heads,UnrollHeads,RestCondition).
5310 types_modes_condition([Head|_],_,_)
5311 <=>
5312 functor(Head,F,A),
5313 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5316 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5317 %% modes_condition(+Modes,+Args,-Condition) is det.
5318 %
5319 % Return =Condition= on =Args= that checks =Modes=.
5320 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5321 modes_condition([],[],true).
5322 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5323 ( Mode == (+) ->
5324 Condition = ( ground(Arg) , RCondition )
5325 ; Mode == (-) ->
5326 Condition = ( var(Arg) , RCondition )
5327 ;
5328 Condition = RCondition
5329 ),
5330 modes_condition(Modes,Args,RCondition).
5332 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5333 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5334 %
5335 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5336 % =UnrollArgs= controls the depth of type definition unrolling.
5337 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5338 types_condition([],[],[],[],true).
5339 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5340 ( Mode == (-) ->
5341 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5342 ;
5343 get_type_definition_det(Type,Def),
5344 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5345 ( Mode == (+) ->
5346 TypeConditionList = TypeConditionList1
5347 ;
5348 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5349 )
5350 ),
5351 list2disj(TypeConditionList,DisjTypeConditionList),
5352 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5354 type_condition([],_,_,_,[]).
5355 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5356 ( var(DefCase) ->
5357 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5358 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5359 true
5360 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5361 true
5362 ;
5363 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5364 ),
5365 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5367 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5368 :- chr_type atomic_builtin_type ---> any
5369 ; number
5370 ; float
5371 ; int
5372 ; natural
5373 ; dense_int
5374 ; chr_identifier
5375 ; chr_identifier(any)
5376 ; /* all possible values are given */
5377 chr_enum(list(any))
5378 ; /* all possible values appear in rule heads;
5379 to distinguish between multiple chr_constants
5380 we have a key*/
5381 chr_constants(any)
5382 ; /* all relevant values appear in rule heads;
5383 for other values a handler is provided */
5384 chr_constants(any,any).
5385 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5387 atomic_builtin_type(any,_Arg,true).
5388 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5389 atomic_builtin_type(int,Arg,integer(Arg)).
5390 atomic_builtin_type(number,Arg,number(Arg)).
5391 atomic_builtin_type(float,Arg,float(Arg)).
5392 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5393 atomic_builtin_type(chr_identifier,_Arg,true).
5395 compound_builtin_type(chr_constants(_),_Arg,true,true).
5396 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5397 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5398 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5399 once(( member(Constant,Constants),
5400 unifiable(Arg,Constant,_)
5401 )
5402 )
5403 ).
5405 is_chr_constants_type(chr_constants(Key),Key,no).
5406 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5408 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5409 ( nonvar(DefCase) ->
5410 functor(DefCase,F,A),
5411 ( A == 0 ->
5412 Condition = (Arg = DefCase)
5413 ; var(UnrollArg) ->
5414 Condition = functor(Arg,F,A)
5415 ; functor(UnrollArg,F,A) ->
5416 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5417 DefCase =.. [_|ArgTypes],
5418 UnrollArg =.. [_|UnrollArgs],
5419 functor(Template,F,A),
5420 Template =.. [_|TemplateArgs],
5421 replicate(A,Mode,ArgModes),
5422 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5423 ;
5424 Condition = functor(Arg,F,A)
5425 )
5426 ;
5427 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5428 ).
5431 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5432 % STATIC TYPE CHECKING
5433 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5434 % Checks head constraints and CHR constraint calls in bodies.
5435 %
5436 % TODO:
5437 % - type clashes involving built-in types
5438 % - Prolog built-ins in guard and body
5439 % - indicate position in terms in error messages
5440 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5441 :- chr_constraint
5442 static_type_check/0.
5445 % 1. Check the declared types
5447 constraint_type(Constraint,ArgTypes), static_type_check
5448 ==>
5449 forall(
5450 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5451 ( get_type_definition(Type,_) ->
5452 true
5453 ;
5454 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5455 )
5456 ).
5458 % 2. Check the rules
5460 :- chr_type type_error_src ---> head(any) ; body(any).
5462 rule(_,Rule), static_type_check
5463 ==>
5464 copy_term_nat(Rule,RuleCopy),
5465 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5466 (
5467 catch(
5468 ( static_type_check_heads(Head1),
5469 static_type_check_heads(Head2),
5470 conj2list(Body,GoalList),
5471 static_type_check_body(GoalList)
5472 ),
5473 type_error(Error),
5474 ( Error = invalid_functor(Src,Term,Type) ->
5475 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5476 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5477 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5478 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5479 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5480 )
5481 ),
5482 fail % cleanup constraints
5483 ;
5484 true
5485 ).
5488 static_type_check <=> true.
5490 static_type_check_heads([]).
5491 static_type_check_heads([Head|Heads]) :-
5492 static_type_check_head(Head),
5493 static_type_check_heads(Heads).
5495 static_type_check_head(Head) :-
5496 functor(Head,F,A),
5497 get_constraint_type_det(F/A,Types),
5498 Head =..[_|Args],
5499 maplist(static_type_check_term(head(Head)),Args,Types).
5501 static_type_check_body([]).
5502 static_type_check_body([Goal|Goals]) :-
5503 functor(Goal,F,A),
5504 get_constraint_type_det(F/A,Types),
5505 Goal =..[_|Args],
5506 maplist(static_type_check_term(body(Goal)),Args,Types),
5507 static_type_check_body(Goals).
5509 :- chr_constraint static_type_check_term/3.
5510 :- chr_option(mode,static_type_check_term(?,?,?)).
5511 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5513 static_type_check_term(Src,Term,Type)
5514 <=>
5515 var(Term)
5516 |
5517 static_type_check_var(Src,Term,Type).
5518 static_type_check_term(Src,Term,Type)
5519 <=>
5520 atomic_builtin_type(Type,Term,Goal)
5521 |
5522 ( call(Goal) ->
5523 true
5524 ;
5525 throw(type_error(invalid_functor(Src,Term,Type)))
5526 ).
5527 static_type_check_term(Src,Term,Type)
5528 <=>
5529 compound_builtin_type(Type,Term,_,Goal)
5530 |
5531 ( call(Goal) ->
5532 true
5533 ;
5534 throw(type_error(invalid_functor(Src,Term,Type)))
5535 ).
5536 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5537 <=>
5538 functor(Type,F,A),
5539 functor(AType,F,A)
5540 |
5541 copy_term_nat(AType-ADef,Type-Def),
5542 static_type_check_term(Src,Term,Def).
5544 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5545 <=>
5546 functor(Type,F,A),
5547 functor(AType,F,A)
5548 |
5549 copy_term_nat(AType-ADef,Type-Variants),
5550 functor(Term,TF,TA),
5551 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5552 Term =.. [_|Args],
5553 Variant =.. [_|Types],
5554 maplist(static_type_check_term(Src),Args,Types)
5555 ;
5556 throw(type_error(invalid_functor(Src,Term,Type)))
5557 ).
5559 static_type_check_term(Src,Term,Type)
5560 <=>
5561 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5563 :- chr_constraint static_type_check_var/3.
5564 :- chr_option(mode,static_type_check_var(?,-,?)).
5565 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5567 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5568 <=>
5569 functor(AType,F,A),
5570 functor(Type,F,A)
5571 |
5572 copy_term_nat(AType-ADef,Type-Def),
5573 static_type_check_var(Src,Var,Def).
5575 static_type_check_var(Src,Var,Type)
5576 <=>
5577 atomic_builtin_type(Type,_,_)
5578 |
5579 static_atomic_builtin_type_check_var(Src,Var,Type).
5581 static_type_check_var(Src,Var,Type)
5582 <=>
5583 compound_builtin_type(Type,_,_,_)
5584 |
5585 true.
5588 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5589 <=>
5590 Type1 \== Type2
5591 |
5592 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5594 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5595 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5596 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5597 :- chr_constraint static_atomic_builtin_type_check_var/3.
5598 :- chr_option(mode,static_type_check_var(?,-,+)).
5599 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5601 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5602 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5603 <=>
5604 true.
5605 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5606 <=>
5607 true.
5608 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5609 <=>
5610 true.
5611 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5612 <=>
5613 true.
5614 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5615 <=>
5616 true.
5617 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5618 <=>
5619 true.
5620 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5621 <=>
5622 true.
5623 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5624 <=>
5625 true.
5626 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5627 <=>
5628 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5630 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5631 %% format_src(+type_error_src) is det.
5632 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5633 format_src(head(Head)) :- format('head ~w',[Head]).
5634 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5636 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5637 % Dynamic type checking
5638 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5640 :- chr_constraint
5641 dynamic_type_check/0,
5642 dynamic_type_check_clauses/1,
5643 get_dynamic_type_check_clauses/1.
5645 generate_dynamic_type_check_clauses(Clauses) :-
5646 ( chr_pp_flag(debugable,on) ->
5647 dynamic_type_check,
5648 get_dynamic_type_check_clauses(Clauses0),
5649 append(Clauses0,
5650 [('$dynamic_type_check'(Type,Term) :-
5651 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5652 )],
5653 Clauses)
5654 ;
5655 Clauses = []
5656 ).
5658 type_definition(T,D), dynamic_type_check
5659 ==>
5660 copy_term_nat(T-D,Type-Definition),
5661 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5662 dynamic_type_check_clauses(DynamicChecks).
5663 type_alias(A,B), dynamic_type_check
5664 ==>
5665 copy_term_nat(A-B,Alias-Body),
5666 dynamic_type_check_alias_clause(Alias,Body,Clause),
5667 dynamic_type_check_clauses([Clause]).
5669 dynamic_type_check <=>
5670 findall(
5671 ('$dynamic_type_check'(Type,Term) :- Goal),
5672 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5673 BuiltinChecks
5674 ),
5675 dynamic_type_check_clauses(BuiltinChecks).
5677 dynamic_type_check_clause(T,DC,Clause) :-
5678 copy_term(T-DC,Type-DefinitionClause),
5679 functor(DefinitionClause,F,A),
5680 functor(Term,F,A),
5681 DefinitionClause =.. [_|DCArgs],
5682 Term =.. [_|TermArgs],
5683 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5684 list2conj(RecursiveCallList,RecursiveCalls),
5685 Clause = (
5686 '$dynamic_type_check'(Type,Term) :-
5687 RecursiveCalls
5688 ).
5690 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5691 Clause = (
5692 '$dynamic_type_check'(Alias,Term) :-
5693 '$dynamic_type_check'(Body,Term)
5694 ).
5696 dynamic_type_check_call(Type,Term,Call) :-
5697 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5698 % Call = when(nonvar(Term),Goal)
5699 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5700 % Call = when(nonvar(Term),Goal)
5701 % ;
5702 ( Type == any ->
5703 Call = true
5704 ;
5705 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5706 )
5707 % )
5708 .
5710 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5711 <=>
5712 append(C1,C2,C),
5713 dynamic_type_check_clauses(C).
5715 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5716 <=>
5717 Q = C.
5718 get_dynamic_type_check_clauses(Q)
5719 <=>
5720 Q = [].
5722 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5723 % Atomic Types
5724 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5725 % Some optimizations can be applied for atomic types...
5726 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5728 atomic_types_suspended_constraint(C) :-
5729 C = _/N,
5730 get_constraint_type(C,ArgTypes),
5731 get_constraint_mode(C,ArgModes),
5732 numlist(1,N,Indexes),
5733 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5735 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5736 ( is_indexed_argument(C,Index) ->
5737 ( Mode == (?) ->
5738 atomic_type(Type)
5739 ;
5740 true
5741 )
5742 ;
5743 true
5744 ).
5746 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5747 %% atomic_type(+Type) is semidet.
5748 %
5749 % Succeeds when all values of =Type= are atomic.
5750 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5751 :- chr_constraint atomic_type/1.
5753 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5755 type_definition(TypePat,Def) \ atomic_type(Type)
5756 <=>
5757 functor(Type,F,A), functor(TypePat,F,A)
5758 |
5759 maplist(atomic,Def).
5761 type_alias(TypePat,Alias) \ atomic_type(Type)
5762 <=>
5763 functor(Type,F,A), functor(TypePat,F,A)
5764 |
5765 atomic(Alias),
5766 copy_term_nat(TypePat-Alias,Type-NType),
5767 atomic_type(NType).
5769 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5770 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5771 %
5772 % Succeeds when all values of =Type= are atomic
5773 % and the atom values are finitely enumerable.
5774 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5775 :- chr_constraint enumerated_atomic_type/2.
5777 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5779 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5780 <=>
5781 functor(Type,F,A), functor(TypePat,F,A)
5782 |
5783 maplist(atomic,Def),
5784 Atoms = Def.
5786 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5787 <=>
5788 functor(Type,F,A), functor(TypePat,F,A)
5789 |
5790 atomic(Alias),
5791 copy_term_nat(TypePat-Alias,Type-NType),
5792 enumerated_atomic_type(NType,Atoms).
5793 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5795 :- chr_constraint
5796 stored/3, % constraint,occurrence,(yes/no/maybe)
5797 stored_completing/3,
5798 stored_complete/3,
5799 is_stored/1,
5800 is_finally_stored/1,
5801 check_all_passive/2.
5803 :- chr_option(mode,stored(+,+,+)).
5804 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5805 :- chr_type storedinfo ---> yes ; no ; maybe.
5806 :- chr_option(mode,stored_complete(+,+,+)).
5807 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5808 :- chr_option(mode,guard_list(+,+,+,+)).
5809 :- chr_option(mode,check_all_passive(+,+)).
5810 :- chr_option(type_declaration,check_all_passive(any,list)).
5812 % change yes in maybe when yes becomes passive
5813 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5814 stored(C,O,yes), stored_complete(C,RO,Yesses)
5815 <=> O < RO | NYesses is Yesses - 1,
5816 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5817 % change yes in maybe when not observed
5818 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5819 <=> O < RO |
5820 NYesses is Yesses - 1,
5821 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5823 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5824 ==> RO =< MO2 | % C2 is never stored
5825 passive(RuleNb,ID).
5830 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5832 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5833 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5834 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5836 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5837 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5838 check_all_passive(RuleNb,IDs2).
5840 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5841 check_all_passive(RuleNb,IDs).
5843 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5844 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5846 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5848 % collect the storage information
5849 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5850 <=> NO is O + 1, NYesses is Yesses + 1,
5851 stored_completing(C,NO,NYesses).
5852 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5853 <=> NO is O + 1,
5854 stored_completing(C,NO,Yesses).
5856 stored(C,O,no) \ stored_completing(C,O,Yesses)
5857 <=> stored_complete(C,O,Yesses).
5858 stored_completing(C,O,Yesses)
5859 <=> stored_complete(C,O,Yesses).
5861 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5862 O2 > O | passive(RuleNb,Id).
5864 % decide whether a constraint is stored
5865 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5866 <=> RO =< MO | fail.
5867 is_stored(C) <=> true.
5869 % decide whether a constraint is suspends after occurrences
5870 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5871 <=> RO =< MO | fail.
5872 is_finally_stored(C) <=> true.
5874 storage_analysis(Constraints) :-
5875 ( chr_pp_flag(storage_analysis,on) ->
5876 check_constraint_storages(Constraints)
5877 ;
5878 true
5879 ).
5881 check_constraint_storages([]).
5882 check_constraint_storages([C|Cs]) :-
5883 check_constraint_storage(C),
5884 check_constraint_storages(Cs).
5886 check_constraint_storage(C) :-
5887 get_max_occurrence(C,MO),
5888 check_occurrences_storage(C,1,MO).
5890 check_occurrences_storage(C,O,MO) :-
5891 ( O > MO ->
5892 stored_completing(C,1,0)
5893 ;
5894 check_occurrence_storage(C,O),
5895 NO is O + 1,
5896 check_occurrences_storage(C,NO,MO)
5897 ).
5899 check_occurrence_storage(C,O) :-
5900 get_occurrence(C,O,RuleNb,ID),
5901 ( is_passive(RuleNb,ID) ->
5902 stored(C,O,maybe)
5903 ;
5904 get_rule(RuleNb,PragmaRule),
5905 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5906 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5907 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5908 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5909 check_storage_head2(Head2,O,Heads1,Body)
5910 )
5911 ).
5913 check_storage_head1(Head,O,H1,H2,G) :-
5914 functor(Head,F,A),
5915 C = F/A,
5916 ( H1 == [Head],
5917 H2 == [],
5918 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5919 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5920 Head =.. [_|L],
5921 no_matching(L,[]) ->
5922 stored(C,O,no)
5923 ;
5924 stored(C,O,maybe)
5925 ).
5927 no_matching([],_).
5928 no_matching([X|Xs],Prev) :-
5929 var(X),
5930 \+ memberchk_eq(X,Prev),
5931 no_matching(Xs,[X|Prev]).
5933 check_storage_head2(Head,O,H1,B) :-
5934 functor(Head,F,A),
5935 C = F/A,
5936 ( %(
5937 ( H1 \== [], B == true )
5938 %;
5939 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5940 %)
5941 ->
5942 stored(C,O,maybe)
5943 ;
5944 stored(C,O,yes)
5945 ).
5947 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5949 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5950 %% ____ _ ____ _ _ _ _
5951 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5952 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5953 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5954 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5955 %% |_|
5957 constraints_code(Constraints,Clauses) :-
5958 (chr_pp_flag(reduced_indexing,on),
5959 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5960 none_suspended_on_variables
5961 ;
5962 true
5963 ),
5964 constraints_code1(Constraints,Clauses,[]).
5966 %===============================================================================
5967 :- chr_constraint constraints_code1/3.
5968 :- chr_option(mode,constraints_code1(+,+,+)).
5969 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5970 %-------------------------------------------------------------------------------
5971 constraints_code1([],L,T) <=> L = T.
5972 constraints_code1([C|RCs],L,T)
5973 <=>
5974 constraint_code(C,L,T1),
5975 constraints_code1(RCs,T1,T).
5976 %===============================================================================
5977 :- chr_constraint constraint_code/3.
5978 :- chr_option(mode,constraint_code(+,+,+)).
5979 %-------------------------------------------------------------------------------
5980 %% Generate code for a single CHR constraint
5981 constraint_code(Constraint, L, T)
5982 <=> true
5983 | ( (chr_pp_flag(debugable,on) ;
5984 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5985 ( may_trigger(Constraint) ;
5986 get_allocation_occurrence(Constraint,AO),
5987 get_max_occurrence(Constraint,MO), MO >= AO ) )
5988 ->
5989 constraint_prelude(Constraint,Clause),
5990 add_dummy_location(Clause,LocatedClause),
5991 L = [LocatedClause | L1]
5992 ;
5993 L = L1
5994 ),
5995 Id = [0],
5996 occurrences_code(Constraint,1,Id,NId,L1,L2),
5997 gen_cond_attach_clause(Constraint,NId,L2,T).
5999 %===============================================================================
6000 %% Generate prelude predicate for a constraint.
6001 %% f(...) :- f/a_0(...,Susp).
6002 constraint_prelude(F/A, Clause) :-
6003 vars_susp(A,Vars,Susp,VarsSusp),
6004 Head =.. [ F | Vars],
6005 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6006 build_head(F,A,[0],VarsSusp,Delegate),
6007 ( chr_pp_flag(debugable,on) ->
6008 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6009 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6010 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6011 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6013 ( get_constraint_type(F/A,ArgTypeList) ->
6014 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6015 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6016 ;
6017 DynamicTypeChecks = true
6018 ),
6020 Clause =
6021 ( Head :-
6022 DynamicTypeChecks,
6023 InsertGoal,
6024 InsertCall,
6025 AttachCall,
6026 Inactive,
6027 'chr debug_event'(insert(Head#Susp)),
6028 (
6029 'chr debug_event'(call(Susp)),
6030 Delegate
6031 ;
6032 'chr debug_event'(fail(Susp)), !,
6033 fail
6034 ),
6035 (
6036 'chr debug_event'(exit(Susp))
6037 ;
6038 'chr debug_event'(redo(Susp)),
6039 fail
6040 )
6041 )
6042 ; get_allocation_occurrence(F/A,0) ->
6043 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6044 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6045 Clause = ( Head :- Goal, Inactive, Delegate )
6046 ;
6047 Clause = ( Head :- Delegate )
6048 ).
6050 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6051 ( may_trigger(F/A) ->
6052 build_head(F,A,[0],VarsSusp,Delegate),
6053 ( chr_pp_flag(debugable,off) ->
6054 Goal = Delegate
6055 ;
6056 get_target_module(Mod),
6057 Goal = Mod:Delegate
6058 )
6059 ;
6060 Goal = true
6061 ).
6063 %===============================================================================
6064 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6065 :- chr_option(mode,has_active_occurrence(+)).
6066 :- chr_option(mode,has_active_occurrence(+,+)).
6068 :- chr_constraint memo_has_active_occurrence/1.
6069 :- chr_option(mode,memo_has_active_occurrence(+)).
6070 %-------------------------------------------------------------------------------
6071 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6072 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6074 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6075 O > MO | fail.
6076 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6077 has_active_occurrence(C,O) <=>
6078 NO is O + 1,
6079 has_active_occurrence(C,NO).
6080 has_active_occurrence(C,O) <=> true.
6081 %===============================================================================
6083 gen_cond_attach_clause(F/A,Id,L,T) :-
6084 ( is_finally_stored(F/A) ->
6085 get_allocation_occurrence(F/A,AllocationOccurrence),
6086 get_max_occurrence(F/A,MaxOccurrence),
6087 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6088 ( only_ground_indexed_arguments(F/A) ->
6089 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6090 ;
6091 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6092 )
6093 ; vars_susp(A,Args,Susp,AllArgs),
6094 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6095 ),
6096 build_head(F,A,Id,AllArgs,Head),
6097 Clause = ( Head :- Body ),
6098 add_dummy_location(Clause,LocatedClause),
6099 L = [LocatedClause | T]
6100 ;
6101 L = T
6102 ).
6104 :- chr_constraint use_auxiliary_predicate/1.
6105 :- chr_option(mode,use_auxiliary_predicate(+)).
6107 :- chr_constraint use_auxiliary_predicate/2.
6108 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6110 :- chr_constraint is_used_auxiliary_predicate/1.
6111 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6113 :- chr_constraint is_used_auxiliary_predicate/2.
6114 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6117 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6119 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6121 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6123 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6125 is_used_auxiliary_predicate(P) <=> fail.
6127 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6128 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6130 is_used_auxiliary_predicate(P,C) <=> fail.
6132 %------------------------------------------------------------------------------%
6133 % Only generate import statements for actually used modules.
6134 %------------------------------------------------------------------------------%
6136 :- chr_constraint use_auxiliary_module/1.
6137 :- chr_option(mode,use_auxiliary_module(+)).
6139 :- chr_constraint is_used_auxiliary_module/1.
6140 :- chr_option(mode,is_used_auxiliary_module(+)).
6143 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6145 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6147 is_used_auxiliary_module(P) <=> fail.
6149 % only called for constraints with
6150 % at least one
6151 % non-ground indexed argument
6152 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6153 vars_susp(A,Args,Susp,AllArgs),
6154 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6155 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6156 Attach = true
6157 ;
6158 attach_constraint_atom(F/A,Vars,Susp,Attach)
6159 ),
6160 FTerm =.. [F|Args],
6161 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6162 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6163 ( may_trigger(F/A) ->
6164 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6165 Goal =
6166 (
6167 ( var(Susp) ->
6168 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6169 InsertCall,
6170 Attach
6171 ;
6172 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6173 )
6174 )
6175 ;
6176 Goal =
6177 (
6178 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6179 InsertCall,
6180 Attach
6181 )
6182 ).
6184 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6185 vars_susp(A,Args,Susp,AllArgs),
6186 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6187 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6188 attach_constraint_atom(F/A,Vars,Susp,Attach)
6189 ;
6190 Attach = true
6191 ),
6192 FTerm =.. [F|Args],
6193 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6194 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6195 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6196 Goal =
6197 (
6198 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6199 InsertCall
6200 )
6201 ;
6202 Goal =
6203 (
6204 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6205 InsertCall,
6206 Attach
6207 )
6208 ).
6210 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6211 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6212 attach_constraint_atom(FA,Vars,Susp,Attach)
6213 ;
6214 Attach = true
6215 ),
6216 insert_constraint_goal(FA,Susp,Args,InsertCall),
6217 ( chr_pp_flag(late_allocation,on) ->
6218 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6219 ;
6220 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6221 ).
6223 %-------------------------------------------------------------------------------
6224 :- chr_constraint occurrences_code/6.
6225 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6226 %-------------------------------------------------------------------------------
6227 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6228 <=> O > MO
6229 | NId = Id, L = T.
6230 occurrences_code(C,O,Id,NId,L,T)
6231 <=>
6232 occurrence_code(C,O,Id,Id1,L,L1),
6233 NO is O + 1,
6234 occurrences_code(C,NO,Id1,NId,L1,T).
6235 %-------------------------------------------------------------------------------
6236 :- chr_constraint occurrence_code/6.
6237 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6238 %-------------------------------------------------------------------------------
6239 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6240 <=>
6241 ( named_history(RuleNb,_,_) ->
6242 does_use_history(C,O)
6243 ;
6244 true
6245 ),
6246 NId = Id,
6247 L = T.
6248 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6249 <=> true |
6250 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6251 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6252 NId = Id,
6253 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6254 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6256 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6257 ( should_skip_to_next_id(C,O) ->
6258 inc_id(Id,NId),
6259 ( unconditional_occurrence(C,O) ->
6260 L1 = T
6261 ;
6262 gen_alloc_inc_clause(C,O,Id,L1,T)
6263 )
6264 ;
6265 NId = Id,
6266 L1 = T
6267 )
6268 ).
6270 occurrence_code(C,O,_,_,_,_)
6271 <=>
6272 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6273 %-------------------------------------------------------------------------------
6275 %% Generate code based on one removed head of a CHR rule
6276 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6277 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6278 Rule = rule(_,Head2,_,_),
6279 ( Head2 == [] ->
6280 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6281 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6282 ;
6283 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6284 ).
6286 %% Generate code based on one persistent head of a CHR rule
6287 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6288 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6289 Rule = rule(Head1,_,_,_),
6290 ( Head1 == [] ->
6291 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6292 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6293 ;
6294 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6295 ).
6297 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6298 vars_susp(A,Vars,Susp,VarsSusp),
6299 build_head(F,A,Id,VarsSusp,Head),
6300 inc_id(Id,IncId),
6301 build_head(F,A,IncId,VarsSusp,CallHead),
6302 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6303 Clause =
6304 (
6305 Head :-
6306 ConditionalAlloc,
6307 CallHead
6308 ),
6309 add_dummy_location(Clause,LocatedClause),
6310 L = [LocatedClause|T].
6312 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6313 get_allocation_occurrence(FA,AO),
6314 get_occurrence_code_id(FA,AO,AId),
6315 get_occurrence_code_id(FA,O,Id),
6316 ( chr_pp_flag(debugable,off), Id == AId ->
6317 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6318 ( may_trigger(FA) ->
6319 Goal = (var(Susp) -> Goal0 ; true)
6320 ;
6321 Goal = Goal0
6322 )
6323 ;
6324 Goal = true
6325 ).
6327 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6328 get_allocation_occurrence(FA,AO),
6329 ( chr_pp_flag(debugable,off), O < AO ->
6330 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6331 ( may_trigger(FA) ->
6332 Goal = (var(Susp) -> Goal0 ; true)
6333 ;
6334 Goal = Goal0
6335 )
6336 ;
6337 Goal = true
6338 ).
6340 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6342 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6343 %
6344 % Reorders guard goals with respect to partner constraint retrieval goals and
6345 % active constraint. Returns combined partner retrieval + guard goal.
6347 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6348 ( chr_pp_flag(guard_via_reschedule,on) ->
6349 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6350 list2conj(ScheduleSkeleton,GoalSkeleton)
6351 ;
6352 length(Retrievals,RL), length(LookupSkeleton,RL),
6353 length(GuardList,GL), length(GuardListSkeleton,GL),
6354 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6355 list2conj(GoalListSkeleton,GoalSkeleton)
6356 ).
6357 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6358 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6359 initialize_unit_dictionary(ActiveHead,Dict),
6360 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6361 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6362 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6363 dependency_reorder(Units,NUnits),
6364 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6365 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6366 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6368 wrappedunits2lists([],[],[],[]).
6369 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6370 Ss = [GoalCopy|TSs],
6371 ( WrappedGoal = lookup(Goal) ->
6372 Ls = [GoalCopy|TLs],
6373 Gs = TGs
6374 ; WrappedGoal = guard(Goal) ->
6375 Gs = [N-GoalCopy|TGs],
6376 Ls = TLs
6377 ),
6378 wrappedunits2lists(Units,TGs,TLs,TSs).
6380 guard_splitting(Rule,SplitGuardList) :-
6381 Rule = rule(H1,H2,Guard,_),
6382 append(H1,H2,Heads),
6383 conj2list(Guard,GuardList),
6384 term_variables(Heads,HeadVars),
6385 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6386 append(GuardPrefix,[RestGuard],SplitGuardList),
6387 term_variables(RestGuardList,GuardVars1),
6388 % variables that are declared to be ground don't need to be locked
6389 ground_vars(Heads,GroundVars),
6390 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6391 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6392 ( chr_pp_flag(guard_locks,on),
6393 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6394 once(pairup(Locks,Unlocks,LocksUnlocks))
6395 ;
6396 Locks = [],
6397 Unlocks = []
6398 ),
6399 list2conj(Locks,LockPhase),
6400 list2conj(Unlocks,UnlockPhase),
6401 list2conj(RestGuardList,RestGuard1),
6402 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6404 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6405 Rule = rule(_,_,_,Body),
6406 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6407 my_term_copy(Body,VarDict2,BodyCopy).
6410 split_off_simple_guard_new([],_,[],[]).
6411 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6412 ( simple_guard_new(G,VarDict) ->
6413 S = [G|Ss],
6414 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6415 ;
6416 S = [],
6417 C = [G|Gs]
6418 ).
6420 % simple guard: cheap and benign (does not bind variables)
6421 simple_guard_new(G,Vars) :-
6422 builtin_binds_b(G,BoundVars),
6423 not(( member(V,BoundVars),
6424 memberchk_eq(V,Vars)
6425 )).
6427 dependency_reorder(Units,NUnits) :-
6428 dependency_reorder(Units,[],NUnits).
6430 dependency_reorder([],Acc,Result) :-
6431 reverse(Acc,Result).
6433 dependency_reorder([Unit|Units],Acc,Result) :-
6434 Unit = unit(_GID,_Goal,Type,GIDs),
6435 ( Type == fixed ->
6436 NAcc = [Unit|Acc]
6437 ;
6438 dependency_insert(Acc,Unit,GIDs,NAcc)
6439 ),
6440 dependency_reorder(Units,NAcc,Result).
6442 dependency_insert([],Unit,_,[Unit]).
6443 dependency_insert([X|Xs],Unit,GIDs,L) :-
6444 X = unit(GID,_,_,_),
6445 ( memberchk(GID,GIDs) ->
6446 L = [Unit,X|Xs]
6447 ;
6448 L = [X | T],
6449 dependency_insert(Xs,Unit,GIDs,T)
6450 ).
6452 build_units(Retrievals,Guard,InitialDict,Units) :-
6453 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6454 build_guard_units(Guard,N,Dict,Tail).
6456 build_retrieval_units([],N,N,Dict,Dict,L,L).
6457 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6458 term_variables(U,Vs),
6459 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6460 L = [unit(N,U,fixed,GIDs)|L1],
6461 N1 is N + 1,
6462 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6464 initialize_unit_dictionary(Term,Dict) :-
6465 term_variables(Term,Vars),
6466 pair_all_with(Vars,0,Dict).
6468 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6469 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6470 ( lookup_eq(Dict,V,GID) ->
6471 ( (GID == This ; memberchk(GID,GIDs) ) ->
6472 GIDs1 = GIDs
6473 ;
6474 GIDs1 = [GID|GIDs]
6475 ),
6476 Dict1 = Dict
6477 ;
6478 Dict1 = [V - This|Dict],
6479 GIDs1 = GIDs
6480 ),
6481 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6483 build_guard_units(Guard,N,Dict,Units) :-
6484 ( Guard = [Goal] ->
6485 Units = [unit(N,Goal,fixed,[])]
6486 ; Guard = [Goal|Goals] ->
6487 term_variables(Goal,Vs),
6488 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6489 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6490 N1 is N + 1,
6491 build_guard_units(Goals,N1,NDict,RUnits)
6492 ).
6494 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6495 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6496 ( lookup_eq(Dict,V,GID) ->
6497 ( (GID == This ; memberchk(GID,GIDs) ) ->
6498 GIDs1 = GIDs
6499 ;
6500 GIDs1 = [GID|GIDs]
6501 ),
6502 Dict1 = [V - This|Dict]
6503 ;
6504 Dict1 = [V - This|Dict],
6505 GIDs1 = GIDs
6506 ),
6507 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6509 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6511 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6512 %% ____ _ ____ _ _
6513 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6514 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6515 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6516 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6517 %%
6518 %% _ _ _ ___ __
6519 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6520 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6521 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6522 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6523 %% |_|
6524 :- chr_constraint
6525 functional_dependency/4,
6526 get_functional_dependency/4.
6528 :- chr_option(mode,functional_dependency(+,+,?,?)).
6529 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6531 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6532 <=>
6533 RuleNb > 1, AO > O
6534 |
6535 functional_dependency(C,1,Pattern,Key).
6537 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6538 <=>
6539 RuleNb2 >= RuleNb1
6540 |
6541 QPattern = Pattern, QKey = Key.
6542 get_functional_dependency(_,_,_,_)
6543 <=>
6544 fail.
6546 functional_dependency_analysis(Rules) :-
6547 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6548 functional_dependency_analysis_main(Rules)
6549 ;
6550 true
6551 ).
6553 functional_dependency_analysis_main([]).
6554 functional_dependency_analysis_main([PRule|PRules]) :-
6555 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6556 functional_dependency(C,RuleNb,Pattern,Key)
6557 ;
6558 true
6559 ),
6560 functional_dependency_analysis_main(PRules).
6562 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6563 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6564 Rule = rule(H1,H2,Guard,_),
6565 ( H1 = [C1],
6566 H2 = [C2] ->
6567 true
6568 ; H1 = [C1,C2],
6569 H2 == [] ->
6570 true
6571 ),
6572 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6573 term_variables(C1,Vs),
6574 \+ (
6575 member(V1,Vs),
6576 lookup_eq(List,V1,V2),
6577 memberchk_eq(V2,Vs)
6578 ),
6579 select_pragma_unique_variables(Vs,List,Key1),
6580 copy_term_nat(C1-Key1,Pattern-Key),
6581 functor(C1,F,A).
6583 select_pragma_unique_variables([],_,[]).
6584 select_pragma_unique_variables([V|Vs],List,L) :-
6585 ( lookup_eq(List,V,_) ->
6586 L = T
6587 ;
6588 L = [V|T]
6589 ),
6590 select_pragma_unique_variables(Vs,List,T).
6592 % depends on functional dependency analysis
6593 % and shape of rule: C1 \ C2 <=> true.
6594 set_semantics_rules(Rules) :-
6595 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6596 set_semantics_rules_main(Rules)
6597 ;
6598 true
6599 ).
6601 set_semantics_rules_main([]).
6602 set_semantics_rules_main([R|Rs]) :-
6603 set_semantics_rule_main(R),
6604 set_semantics_rules_main(Rs).
6606 set_semantics_rule_main(PragmaRule) :-
6607 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6608 ( Rule = rule([C1],[C2],true,_),
6609 IDs = ids([ID1],[ID2]),
6610 \+ is_passive(RuleNb,ID1),
6611 functor(C1,F,A),
6612 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6613 copy_term_nat(Pattern-Key,C1-Key1),
6614 copy_term_nat(Pattern-Key,C2-Key2),
6615 Key1 == Key2 ->
6616 passive(RuleNb,ID2)
6617 ;
6618 true
6619 ).
6621 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6622 \+ any_passive_head(RuleNb),
6623 variable_replacement(C1-C2,C2-C1,List),
6624 copy_with_variable_replacement(G,OtherG,List),
6625 negate_b(G,NotG),
6626 once(entails_b(NotG,OtherG)).
6628 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6629 % where C1 and C2 are symmteric constraints
6630 symmetry_analysis(Rules) :-
6631 ( chr_pp_flag(check_unnecessary_active,off) ->
6632 true
6633 ;
6634 symmetry_analysis_main(Rules)
6635 ).
6637 symmetry_analysis_main([]).
6638 symmetry_analysis_main([R|Rs]) :-
6639 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6640 Rule = rule(H1,H2,_,_),
6641 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6642 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6643 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6644 ;
6645 true
6646 ),
6647 symmetry_analysis_main(Rs).
6649 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6650 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6651 ( \+ is_passive(RuleNb,ID),
6652 member2(PreHs,PreIDs,PreH-PreID),
6653 \+ is_passive(RuleNb,PreID),
6654 variable_replacement(PreH,H,List),
6655 copy_with_variable_replacement(Rule,Rule2,List),
6656 identical_guarded_rules(Rule,Rule2) ->
6657 passive(RuleNb,ID)
6658 ;
6659 true
6660 ),
6661 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6663 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6664 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6665 ( \+ is_passive(RuleNb,ID),
6666 member2(PreHs,PreIDs,PreH-PreID),
6667 \+ is_passive(RuleNb,PreID),
6668 variable_replacement(PreH,H,List),
6669 copy_with_variable_replacement(Rule,Rule2,List),
6670 identical_rules(Rule,Rule2) ->
6671 passive(RuleNb,ID)
6672 ;
6673 true
6674 ),
6675 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6679 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6680 %% ____ _ _ _ __ _ _ _
6681 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6682 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6683 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6684 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6685 %% |_|
6686 %% {{{
6688 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6689 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6690 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6691 build_head(F,A,Id,HeadVars,ClauseHead),
6692 get_constraint_mode(F/A,Mode),
6693 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6696 guard_splitting(Rule,GuardList0),
6697 ( is_stored_in_guard(F/A, RuleNb) ->
6698 GuardList = [Hole1|GuardList0]
6699 ;
6700 GuardList = GuardList0
6701 ),
6702 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6704 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6706 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6708 ( is_stored_in_guard(F/A, RuleNb) ->
6709 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6710 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6711 GuardCopyList = [Hole1Copy|_],
6712 Hole1Copy = (Allocation, Attachment)
6713 ;
6714 true
6715 ),
6718 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6719 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6721 ( chr_pp_flag(debugable,on) ->
6722 Rule = rule(_,_,Guard,Body),
6723 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6724 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6725 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6726 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6727 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6728 ;
6729 Cut = ActualCut
6730 ),
6731 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6732 Clause = ( ClauseHead :-
6733 FirstMatching,
6734 RescheduledTest,
6735 Cut,
6736 SuspsDetachments,
6737 SuspDetachment,
6738 BodyCopy
6739 ),
6740 add_location(Clause,RuleNb,LocatedClause),
6741 L = [LocatedClause | T].
6743 % }}}
6745 add_location(Clause,RuleNb,NClause) :-
6746 ( chr_pp_flag(line_numbers,on) ->
6747 get_chr_source_file(File),
6748 get_line_number(RuleNb,LineNb),
6749 NClause = '$source_location'(File,LineNb):Clause
6750 ;
6751 NClause = Clause
6752 ).
6754 add_dummy_location(Clause,NClause) :-
6755 ( chr_pp_flag(line_numbers,on) ->
6756 get_chr_source_file(File),
6757 NClause = '$source_location'(File,1):Clause
6758 ;
6759 NClause = Clause
6760 ).
6761 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6762 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6763 %
6764 % Return goal matching newly introduced variables with variables in
6765 % previously looked-up heads.
6766 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6767 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6768 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6771 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6772 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6773 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6774 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6775 list2conj(GoalList,Goal).
6777 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6778 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6779 ( Mode == (+) ->
6780 term_variables(Arg,GroundVars0,GroundVars),
6781 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6782 ;
6783 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6784 ).
6785 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6786 ( var(Arg) ->
6787 ( lookup_eq(VarDict,Arg,OtherVar) ->
6788 ( Mode = (+) ->
6789 ( memberchk_eq(Arg,GroundVars) ->
6790 GoalList = [Var = OtherVar | RestGoalList],
6791 GroundVars1 = GroundVars
6792 ;
6793 GoalList = [Var == OtherVar | RestGoalList],
6794 GroundVars1 = [Arg|GroundVars]
6795 )
6796 ;
6797 GoalList = [Var == OtherVar | RestGoalList],
6798 GroundVars1 = GroundVars
6799 ),
6800 VarDict1 = VarDict
6801 ;
6802 VarDict1 = [Arg-Var | VarDict],
6803 GoalList = RestGoalList,
6804 ( Mode = (+) ->
6805 GroundVars1 = [Arg|GroundVars]
6806 ;
6807 GroundVars1 = GroundVars
6808 )
6809 ),
6810 Pairs = Rest,
6811 RestModes = Modes
6812 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6813 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6814 GoalList = [Goal|RestGoalList],
6815 VarDict = VarDict1,
6816 GroundVars1 = GroundVars,
6817 Pairs = Rest,
6818 RestModes = Modes
6819 ; atomic(Arg) ->
6820 ( Mode = (+) ->
6821 GoalList = [ Var = Arg | RestGoalList]
6822 ;
6823 GoalList = [ Var == Arg | RestGoalList]
6824 ),
6825 VarDict = VarDict1,
6826 GroundVars1 = GroundVars,
6827 Pairs = Rest,
6828 RestModes = Modes
6829 ; Mode == (+), is_ground(GroundVars,Arg) ->
6830 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6831 GoalList = [ Var = ArgCopy | RestGoalList],
6832 VarDict = VarDict1,
6833 GroundVars1 = GroundVars,
6834 Pairs = Rest,
6835 RestModes = Modes
6836 ; Mode == (?), is_ground(GroundVars,Arg) ->
6837 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6838 GoalList = [ Var == ArgCopy | RestGoalList],
6839 VarDict = VarDict1,
6840 GroundVars1 = GroundVars,
6841 Pairs = Rest,
6842 RestModes = Modes
6843 ; Arg =.. [_|Args],
6844 functor(Arg,Fct,N),
6845 functor(Term,Fct,N),
6846 Term =.. [_|Vars],
6847 ( Mode = (+) ->
6848 GoalList = [ Var = Term | RestGoalList ]
6849 ;
6850 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6851 ),
6852 pairup(Args,Vars,NewPairs),
6853 append(NewPairs,Rest,Pairs),
6854 replicate(N,Mode,NewModes),
6855 append(NewModes,Modes,RestModes),
6856 VarDict1 = VarDict,
6857 GroundVars1 = GroundVars
6858 ),
6859 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6861 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6862 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6863 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6864 add_heads_types([],VarTypes,VarTypes).
6865 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6866 add_head_types(Head,VarTypes,VarTypes1),
6867 add_heads_types(Heads,VarTypes1,NVarTypes).
6869 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6870 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6871 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6872 add_head_types(Head,VarTypes,NVarTypes) :-
6873 functor(Head,F,A),
6874 get_constraint_type_det(F/A,ArgTypes),
6875 Head =.. [_|Args],
6876 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6878 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6879 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6880 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6881 add_args_types([],[],VarTypes,VarTypes).
6882 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6883 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6884 add_args_types(Args,Types,VarTypes1,NVarTypes).
6886 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6887 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6888 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6889 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6890 ( var(Term) ->
6891 ( lookup_eq(VarTypes,Term,_) ->
6892 NVarTypes = VarTypes
6893 ;
6894 NVarTypes = [Term-Type|VarTypes]
6895 )
6896 ; ground(Term) ->
6897 NVarTypes = VarTypes
6898 ; % TODO improve approximation!
6899 term_variables(Term,Vars),
6900 length(Vars,VarNb),
6901 replicate(VarNb,any,Types),
6902 add_args_types(Vars,Types,VarTypes,NVarTypes)
6903 ).
6907 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6908 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6909 %
6910 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6911 add_heads_ground_variables([],GroundVars,GroundVars).
6912 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6913 add_head_ground_variables(Head,GroundVars,GroundVars1),
6914 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6916 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6917 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6918 %
6919 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6920 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6921 functor(Head,F,A),
6922 get_constraint_mode(F/A,ArgModes),
6923 Head =.. [_|Args],
6924 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6927 add_arg_ground_variables([],[],GroundVars,GroundVars).
6928 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6929 ( Mode == (+) ->
6930 term_variables(Arg,Vars),
6931 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6932 ;
6933 GroundVars = GroundVars1
6934 ),
6935 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6937 add_var_ground_variables([],GroundVars,GroundVars).
6938 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6939 ( memberchk_eq(Var,GroundVars) ->
6940 GroundVars1 = GroundVars
6941 ;
6942 GroundVars1 = [Var|GroundVars]
6943 ),
6944 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6945 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6946 %% is_ground(+GroundVars,+Term) is semidet.
6947 %
6948 % Determine whether =Term= is always ground.
6949 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6950 is_ground(GroundVars,Term) :-
6951 ( ground(Term) ->
6952 true
6953 ; compound(Term) ->
6954 Term =.. [_|Args],
6955 maplist(is_ground(GroundVars),Args)
6956 ;
6957 memberchk_eq(Term,GroundVars)
6958 ).
6960 %% check_ground(+GroundVars,+Term,-Goal) is det.
6961 %
6962 % Return runtime check to see whether =Term= is ground.
6963 check_ground(GroundVars,Term,Goal) :-
6964 term_variables(Term,Variables),
6965 check_ground_variables(Variables,GroundVars,Goal).
6967 check_ground_variables([],_,true).
6968 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6969 ( memberchk_eq(Var,GroundVars) ->
6970 check_ground_variables(Vars,GroundVars,Goal)
6971 ;
6972 Goal = (ground(Var), RGoal),
6973 check_ground_variables(Vars,GroundVars,RGoal)
6974 ).
6976 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6977 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6979 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6980 ( Heads = [_|_] ->
6981 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6982 ;
6983 GoalList = [],
6984 Susps = [],
6985 VarDict = NVarDict,
6986 GroundVars = NGroundVars
6987 ).
6989 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6990 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6991 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6992 functor(H,F,A),
6993 head_info(H,A,Vars,_,_,Pairs),
6994 get_store_type(F/A,StoreType),
6995 ( StoreType == default ->
6996 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6997 delay_phase_end(validate_store_type_assumptions,
6998 ( static_suspension_term(F/A,Suspension),
6999 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
7000 get_static_suspension_field(F/A,Suspension,state,active,GetState)
7001 )
7002 ),
7003 % create_get_mutable_ref(active,State,GetMutable),
7004 get_constraint_mode(F/A,Mode),
7005 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7006 NPairs = Pairs,
7007 sbag_member_call(Susp,VarSusps,Sbag),
7008 ExistentialLookup = (
7009 ViaGoal,
7010 Sbag,
7011 Susp = Suspension, % not inlined
7012 GetState
7013 )
7014 ;
7015 delay_phase_end(validate_store_type_assumptions,
7016 ( static_suspension_term(F/A,Suspension),
7017 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7018 )
7019 ),
7020 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7021 get_constraint_mode(F/A,Mode),
7022 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7023 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
7024 ),
7025 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7026 filter_append(NPairs,VarDict1,DA_), % order important here
7027 translate(GroundVars1,DA_,GroundVarsA),
7028 translate(GroundVars1,VarDict1,GroundVarsB),
7029 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
7030 Goal =
7031 (
7032 ExistentialLookup,
7033 DiffSuspGoals,
7034 MatchingGoal2
7035 ),
7036 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7038 inline_matching_goal(A==B,true,GVA,GVB) :-
7039 memberchk_eq(A,GVA),
7040 memberchk_eq(B,GVB),
7041 A=B, !.
7043 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7044 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7045 inline_matching_goal(A,A2,GVA,GVB),
7046 inline_matching_goal(B,B2,GVA,GVB).
7047 inline_matching_goal(X,X,_,_).
7050 filter_mode([],_,_,[]).
7051 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7052 ( Var == V ->
7053 Modes = [M|MT],
7054 filter_mode(Rest,R,Ms,MT)
7055 ;
7056 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7057 ).
7059 filter_append([],VarDict,VarDict).
7060 filter_append([X|Xs],VarDict,NVarDict) :-
7061 ( X = silent(_) ->
7062 filter_append(Xs,VarDict,NVarDict)
7063 ;
7064 NVarDict = [X|NVarDict0],
7065 filter_append(Xs,VarDict,NVarDict0)
7066 ).
7068 check_unique_keys([],_).
7069 check_unique_keys([V|Vs],Dict) :-
7070 lookup_eq(Dict,V,_),
7071 check_unique_keys(Vs,Dict).
7073 % Generates tests to ensure the found constraint differs from previously found constraints
7074 % TODO: detect more cases where constraints need be different
7075 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7076 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7077 list2conj(DiffSuspGoalList,DiffSuspGoals).
7079 different_from_other_susps_(_,[],_,_,[]) :- !.
7080 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7081 ( functor(Head,F,A), functor(PreHead,F,A),
7082 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7083 \+ \+ PreHeadCopy = HeadCopy ->
7085 List = [Susp \== PreSusp | Tail]
7086 ;
7087 List = Tail
7088 ),
7089 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7091 % passive_head_via(in,in,in,in,out,out,out) :-
7092 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7093 functor(Head,F,A),
7094 get_constraint_index(F/A,Pos),
7095 /* which static variables may contain runtime variables */
7096 common_variables(Head,PrevHeads,CommonVars0),
7097 ground_vars([Head],GroundVars),
7098 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7099 /********************************************************/
7100 global_list_store_name(F/A,Name),
7101 GlobalGoal = nb_getval(Name,AllSusps),
7102 get_constraint_mode(F/A,ArgModes),
7103 ( Vars == [] ->
7104 Goal = GlobalGoal
7105 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7106 translate([CommonVar],VarDict,[Var]),
7107 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7108 Goal = AttrGoal
7109 ;
7110 translate(CommonVars,VarDict,Vars),
7111 add_heads_types(PrevHeads,[],TypeDict),
7112 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7113 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7114 Goal =
7115 ( ViaGoal ->
7116 AttrGoal
7117 ;
7118 GlobalGoal
7119 )
7120 ).
7122 common_variables(T,Ts,Vs) :-
7123 term_variables(T,V1),
7124 term_variables(Ts,V2),
7125 intersect_eq(V1,V2,Vs).
7127 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7128 via_goal(Vars,TypeDict,ViaGoal,Var),
7129 get_target_module(Mod),
7130 AttrGoal =
7131 ( get_attr(Var,Mod,TSusps),
7132 TSuspsEqSusps % TSusps = Susps
7133 ),
7134 get_max_constraint_index(N),
7135 ( N == 1 ->
7136 TSuspsEqSusps = true, % TSusps = Susps
7137 AllSusps = TSusps
7138 ;
7139 get_constraint_index(FA,Pos),
7140 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7141 ).
7142 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7143 ( Vars = [] ->
7144 ViaGoal = fail
7145 ; Vars = [A] ->
7146 lookup_eq(TypeDict,A,Type),
7147 ( atomic_type(Type) ->
7148 ViaGoal = var(A),
7149 A = Var
7150 ;
7151 ViaGoal = 'chr newvia_1'(A,Var)
7152 )
7153 ; Vars = [A,B] ->
7154 ViaGoal = 'chr newvia_2'(A,B,Var)
7155 ;
7156 ViaGoal = 'chr newvia'(Vars,Var)
7157 ).
7158 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7159 get_target_module(Mod),
7160 AttrGoal =
7161 ( get_attr(Var,Mod,TSusps),
7162 TSuspsEqSusps % TSusps = Susps
7163 ),
7164 get_max_constraint_index(N),
7165 ( N == 1 ->
7166 TSuspsEqSusps = true, % TSusps = Susps
7167 AllSusps = TSusps
7168 ;
7169 get_constraint_index(FA,Pos),
7170 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7171 ).
7173 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7174 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7175 list2conj(GuardCopyList,GuardCopy).
7177 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7178 Rule = rule(_,H,Guard,Body),
7179 conj2list(Guard,GuardList),
7180 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7181 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7183 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7184 term_variables(RestGuardList,GuardVars),
7185 term_variables(RestGuardListCopyCore,GuardCopyVars),
7186 % variables that are declared to be ground don't need to be locked
7187 ground_vars(H,GroundVars),
7188 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7189 ( chr_pp_flag(guard_locks,on),
7190 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7191 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7192 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7193 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7194 ),
7195 LocksUnlocks) ->
7196 once(pairup(Locks,Unlocks,LocksUnlocks))
7197 ;
7198 Locks = [],
7199 Unlocks = []
7200 ),
7201 list2conj(Locks,LockPhase),
7202 list2conj(Unlocks,UnlockPhase),
7203 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7204 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7205 my_term_copy(Body,VarDict2,BodyCopy).
7208 split_off_simple_guard([],_,[],[]).
7209 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7210 ( simple_guard(G,VarDict) ->
7211 S = [G|Ss],
7212 split_off_simple_guard(Gs,VarDict,Ss,C)
7213 ;
7214 S = [],
7215 C = [G|Gs]
7216 ).
7218 % simple guard: cheap and benign (does not bind variables)
7219 simple_guard(G,VarDict) :-
7220 binds_b(G,Vars),
7221 \+ (( member(V,Vars),
7222 lookup_eq(VarDict,V,_)
7223 )).
7225 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7226 functor(Head,F,A),
7227 C = F/A,
7228 ( is_stored(C) ->
7229 (
7230 (
7231 Id == [0], chr_pp_flag(store_in_guards, off)
7232 ;
7233 ( get_allocation_occurrence(C,AO),
7234 get_max_occurrence(C,MO),
7235 MO < AO )
7236 ),
7237 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7238 SuspDetachment = true
7239 ;
7240 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7241 ( chr_pp_flag(late_allocation,on) ->
7242 SuspDetachment =
7243 ( var(Susp) ->
7244 true
7245 ;
7246 UnCondSuspDetachment
7247 )
7248 ;
7249 SuspDetachment = UnCondSuspDetachment
7250 )
7251 )
7252 ;
7253 SuspDetachment = true
7254 ).
7256 partner_constraint_detachments([],[],_,true).
7257 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7258 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7259 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7261 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7262 functor(Head,F,A),
7263 C = F/A,
7264 ( is_stored(C) ->
7265 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7266 ( chr_pp_flag(debugable,on) ->
7267 DebugEvent = 'chr debug_event'(remove(Susp))
7268 ;
7269 DebugEvent = true
7270 ),
7271 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7272 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7273 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7274 detach_constraint_atom(C,Vars,Susp,Detach)
7275 ;
7276 Detach = true
7277 )
7278 ;
7279 SuspDetachment = true
7280 ).
7282 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7284 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7285 %% ____ _ _ _ _
7286 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7287 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7288 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7289 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7290 %% |_| |___/
7291 %% {{{
7293 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7294 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7295 Rule = rule(_Heads,Heads2,Guard,Body),
7297 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7298 get_constraint_mode(F/A,Mode),
7299 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7301 build_head(F,A,Id,HeadVars,ClauseHead),
7303 append(RestHeads,Heads2,Heads),
7304 append(OtherIDs,Heads2IDs,IDs),
7305 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7307 guard_splitting(Rule,GuardList0),
7308 ( is_stored_in_guard(F/A, RuleNb) ->
7309 GuardList = [Hole1|GuardList0]
7310 ;
7311 GuardList = GuardList0
7312 ),
7313 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7315 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7316 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7318 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7320 ( is_stored_in_guard(F/A, RuleNb) ->
7321 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7322 GuardCopyList = [Hole1Copy|_],
7323 Hole1Copy = Attachment
7324 ;
7325 true
7326 ),
7328 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7329 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7330 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7332 ( chr_pp_flag(debugable,on) ->
7333 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7334 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7335 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7336 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7337 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7338 instrument_goal((!),DebugTry,DebugApply,Cut)
7339 ;
7340 Cut = (!)
7341 ),
7343 Clause = ( ClauseHead :-
7344 FirstMatching,
7345 RescheduledTest,
7346 Cut,
7347 SuspsDetachments,
7348 SuspDetachment,
7349 BodyCopy
7350 ),
7351 add_location(Clause,RuleNb,LocatedClause),
7352 L = [LocatedClause | T].
7354 % }}}
7356 split_by_ids([],[],_,[],[]).
7357 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7358 ( memberchk_eq(I,I1s) ->
7359 S1s = [S | R1s],
7360 S2s = R2s
7361 ;
7362 S1s = R1s,
7363 S2s = [S | R2s]
7364 ),
7365 split_by_ids(Is,Ss,I1s,R1s,R2s).
7367 split_by_ids([],[],_,[],[],[],[]).
7368 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7369 ( memberchk_eq(I,I1s) ->
7370 S1s = [S | R1s],
7371 SI1s = [I|RSI1s],
7372 S2s = R2s,
7373 SI2s = RSI2s
7374 ;
7375 S1s = R1s,
7376 SI1s = RSI1s,
7377 S2s = [S | R2s],
7378 SI2s = [I|RSI2s]
7379 ),
7380 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7381 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7384 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7385 %% ____ _ _ _ ____
7386 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7387 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7388 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7389 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7390 %% |_| |___/
7392 %% Genereate prelude + worker predicate
7393 %% prelude calls worker
7394 %% worker iterates over one type of removed constraints
7395 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7396 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7397 Rule = rule(Heads1,_,Guard,Body),
7398 append(Heads1,RestHeads2,Heads),
7399 append(IDs1,RestIDs,IDs),
7400 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7401 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7402 extend_id(Id,Id1),
7403 ( memberchk_eq(NID,IDs2) ->
7404 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7405 ;
7406 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7407 ),
7408 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7409 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7411 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7412 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7413 Heads = [Head|RHeads],
7414 inc_id(Id,Id1),
7415 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7416 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7417 ( memberchk_eq(ID,IDs2) ->
7418 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7419 ;
7420 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7421 ).
7423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7424 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7425 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7426 build_head(F,A,Id1,VarsSusp,ClauseHead),
7427 get_constraint_mode(F/A,Mode),
7428 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7430 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7432 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7434 extend_id(Id1,DelegateId),
7435 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7436 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7437 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7439 PreludeClause =
7440 ( ClauseHead :-
7441 FirstMatching,
7442 ModConstraintsGoal,
7443 !,
7444 ConstraintAllocationGoal,
7445 Delegate
7446 ),
7447 add_dummy_location(PreludeClause,LocatedPreludeClause),
7448 L = [LocatedPreludeClause|T].
7450 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7451 Term =.. [_|Args],
7452 delegate_variables(Term,Terms,VarDict,Args,Vars).
7454 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7455 term_variables(PrevTerms,PrevVars),
7456 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7458 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7459 term_variables(Term,V1),
7460 term_variables(Terms,V2),
7461 intersect_eq(V1,V2,V3),
7462 list_difference_eq(V3,PrevVars,V4),
7463 translate(V4,VarDict,Vars).
7466 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7467 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7468 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7469 Rule = rule(_,_,Guard,Body),
7470 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7472 gen_var(OtherSusp),
7473 gen_var(OtherSusps),
7475 functor(CurrentHead,OtherF,OtherA),
7476 gen_vars(OtherA,OtherVars),
7477 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7478 get_constraint_mode(OtherF/OtherA,Mode),
7479 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7481 delay_phase_end(validate_store_type_assumptions,
7482 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7483 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7484 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7485 )
7486 ),
7487 % create_get_mutable_ref(active,State,GetMutable),
7488 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7489 CurrentSuspTest = (
7490 OtherSusp = OtherSuspension,
7491 GetState,
7492 DiffSuspGoals,
7493 FirstMatching
7494 ),
7496 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7497 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7499 guard_splitting(Rule,GuardList0),
7500 ( is_stored_in_guard(F/A, RuleNb) ->
7501 GuardList = [Hole1|GuardList0]
7502 ;
7503 GuardList = GuardList0
7504 ),
7505 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7507 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7508 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7509 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7511 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7513 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7514 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7515 RecursiveVars2 = [[]|PreVarsAndSusps],
7516 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7518 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7519 ( is_stored_in_guard(F/A, RuleNb) ->
7520 GuardCopyList = [GuardAttachment|_] % once( ) ??
7521 ;
7522 true
7523 ),
7525 ( is_observed(F/A,O) ->
7526 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7527 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7528 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7529 ;
7530 Attachment = true,
7531 ConditionalRecursiveCall = RecursiveCall,
7532 ConditionalRecursiveCall2 = RecursiveCall2
7533 ),
7535 ( chr_pp_flag(debugable,on) ->
7536 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7537 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7538 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7539 ;
7540 DebugTry = true,
7541 DebugApply = true
7542 ),
7544 ( is_stored_in_guard(F/A, RuleNb) ->
7545 GuardAttachment = Attachment,
7546 BodyAttachment = true
7547 ;
7548 GuardAttachment = true,
7549 BodyAttachment = Attachment % will be true if not observed at all
7550 ),
7552 ( member(unique(ID1,UniqueKeys), Pragmas),
7553 check_unique_keys(UniqueKeys,VarDict) ->
7554 Clause =
7555 ( ClauseHead :-
7556 ( CurrentSuspTest ->
7557 ( RescheduledTest,
7558 DebugTry ->
7559 DebugApply,
7560 Susps1Detachments,
7561 BodyAttachment,
7562 BodyCopy,
7563 ConditionalRecursiveCall2
7564 ;
7565 RecursiveCall2
7566 )
7567 ;
7568 RecursiveCall
7569 )
7570 )
7571 ;
7572 Clause =
7573 ( ClauseHead :-
7574 ( CurrentSuspTest,
7575 RescheduledTest,
7576 DebugTry ->
7577 DebugApply,
7578 Susps1Detachments,
7579 BodyAttachment,
7580 BodyCopy,
7581 ConditionalRecursiveCall
7582 ;
7583 RecursiveCall
7584 )
7585 )
7586 ),
7587 add_location(Clause,RuleNb,LocatedClause),
7588 L = [LocatedClause | T].
7590 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7591 ( may_trigger(FA) ->
7592 does_use_field(FA,generation),
7593 delay_phase_end(validate_store_type_assumptions,
7594 ( static_suspension_term(FA,Suspension),
7595 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7596 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7597 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7598 )
7599 )
7600 ;
7601 delay_phase_end(validate_store_type_assumptions,
7602 ( static_suspension_term(FA,Suspension),
7603 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7604 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7605 )
7606 ),
7607 GetGeneration = true
7608 ),
7609 ConditionalCall =
7610 ( Susp = Suspension,
7611 GetState,
7612 GetGeneration ->
7613 UpdateState,
7614 Call
7615 ;
7616 true
7617 ).
7619 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7622 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7623 %% ____ _ _
7624 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7625 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7626 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7627 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7628 %% |_| |___/
7630 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7631 ( RestHeads == [] ->
7632 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7633 ;
7634 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7635 ).
7636 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7637 %% Single headed propagation
7638 %% everything in a single clause
7639 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7640 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7641 build_head(F,A,Id,VarsSusp,ClauseHead),
7643 inc_id(Id,NextId),
7644 build_head(F,A,NextId,VarsSusp,NextHead),
7646 get_constraint_mode(F/A,Mode),
7647 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7648 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7650 % - recursive call -
7651 RecursiveCall = NextHead,
7653 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7654 ActualCut = true
7655 ;
7656 ActualCut = !
7657 ),
7659 Rule = rule(_,_,Guard,Body),
7660 ( chr_pp_flag(debugable,on) ->
7661 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7662 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7663 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7664 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7665 ;
7666 Cut = ActualCut
7667 ),
7668 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7669 use_auxiliary_predicate(novel_production),
7670 use_auxiliary_predicate(extend_history),
7671 does_use_history(F/A,O),
7672 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7674 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7675 ( HistoryIDs == [] ->
7676 empty_named_history_novel_production(HistoryName,NovelProduction),
7677 empty_named_history_extend_history(HistoryName,ExtendHistory)
7678 ;
7679 Tuple = HistoryName
7680 )
7681 ;
7682 Tuple = RuleNb
7683 ),
7685 ( var(NovelProduction) ->
7686 NovelProduction = '$novel_production'(Susp,Tuple),
7687 ExtendHistory = '$extend_history'(Susp,Tuple)
7688 ;
7689 true
7690 ),
7692 ( is_observed(F/A,O) ->
7693 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7694 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7695 ;
7696 Attachment = true,
7697 ConditionalRecursiveCall = RecursiveCall
7698 )
7699 ;
7700 Allocation = true,
7701 NovelProduction = true,
7702 ExtendHistory = true,
7704 ( is_observed(F/A,O) ->
7705 get_allocation_occurrence(F/A,AllocO),
7706 ( O == AllocO ->
7707 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7708 Generation = 0
7709 ; % more room for improvement?
7710 Attachment = (Attachment1, Attachment2),
7711 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7712 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7713 ),
7714 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7715 ;
7716 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7717 ConditionalRecursiveCall = RecursiveCall
7718 )
7719 ),
7721 ( is_stored_in_guard(F/A, RuleNb) ->
7722 GuardAttachment = Attachment,
7723 BodyAttachment = true
7724 ;
7725 GuardAttachment = true,
7726 BodyAttachment = Attachment % will be true if not observed at all
7727 ),
7729 Clause = (
7730 ClauseHead :-
7731 HeadMatching,
7732 Allocation,
7733 NovelProduction,
7734 GuardAttachment,
7735 GuardCopy,
7736 Cut,
7737 ExtendHistory,
7738 BodyAttachment,
7739 BodyCopy,
7740 ConditionalRecursiveCall
7741 ),
7742 add_location(Clause,RuleNb,LocatedClause),
7743 ProgramList = [LocatedClause | ProgramTail].
7745 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7746 %% multi headed propagation
7747 %% prelude + predicates to accumulate the necessary combinations of suspended
7748 %% constraints + predicate to execute the body
7749 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7750 RestHeads = [First|Rest],
7751 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7752 extend_id(Id,ExtendedId),
7753 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7755 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7756 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7757 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7758 build_head(F,A,Id,VarsSusp,PreludeHead),
7759 get_constraint_mode(F/A,Mode),
7760 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7761 Rule = rule(_,_,Guard,Body),
7762 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7764 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7766 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7768 extend_id(Id,NestedId),
7769 append([Susps|VarsSusp],ExtraVars,NestedVars),
7770 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7771 NestedCall = NestedHead,
7773 Prelude = (
7774 PreludeHead :-
7775 FirstMatching,
7776 FirstSuspGoal,
7777 !,
7778 CondAllocation,
7779 NestedCall
7780 ),
7781 add_dummy_location(Prelude,LocatedPrelude),
7782 L = [LocatedPrelude|T].
7784 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7785 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7786 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7787 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7789 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7790 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7791 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7792 inc_id(Id,IncId),
7793 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7795 %check_fd_lookup_condition(_,_,_,_) :- fail.
7796 check_fd_lookup_condition(F,A,_,_) :-
7797 get_store_type(F/A,global_singleton), !.
7798 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7799 \+ may_trigger(F/A),
7800 get_functional_dependency(F/A,1,P,K),
7801 copy_term(P-K,CurrentHead-Key),
7802 term_variables(PreHeads,PreVars),
7803 intersect_eq(Key,PreVars,Key),!.
7805 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7806 Rule = rule(_,H2,Guard,Body),
7807 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7808 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7809 init(AllSusps,RestSusps),
7810 last(AllSusps,Susp),
7811 gen_var(OtherSusp),
7812 gen_var(OtherSusps),
7813 functor(CurrentHead,OtherF,OtherA),
7814 gen_vars(OtherA,OtherVars),
7815 delay_phase_end(validate_store_type_assumptions,
7816 ( static_suspension_term(OtherF/OtherA,Suspension),
7817 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7818 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7819 )
7820 ),
7821 % create_get_mutable_ref(active,State,GetMutable),
7822 CurrentSuspTest = (
7823 OtherSusp = Suspension,
7824 GetState
7825 ),
7826 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7827 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7828 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7829 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7830 RecursiveVars = PreVarsAndSusps1
7831 ;
7832 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7833 PrevId0 = Id
7834 ),
7835 ( PrevId0 = [_] ->
7836 PrevId = PrevId0
7837 ;
7838 PrevId = [O|PrevId0]
7839 ),
7840 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7841 RecursiveCall = RecursiveHead,
7842 CurrentHead =.. [_|OtherArgs],
7843 pairup(OtherArgs,OtherVars,OtherPairs),
7844 get_constraint_mode(OtherF/OtherA,Mode),
7845 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7847 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7848 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7849 get_occurrence(F/A,O,_,ID),
7851 ( is_observed(F/A,O) ->
7852 init(FirstVarsSusp,FirstVars),
7853 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7854 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7855 ;
7856 Attachment = true,
7857 ConditionalRecursiveCall = RecursiveCall
7858 ),
7859 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7860 NovelProduction = true,
7861 ExtendHistory = true
7862 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7863 NovelProduction = true,
7864 ExtendHistory = true
7865 ;
7866 get_occurrence(F/A,O,_,ID),
7867 use_auxiliary_predicate(novel_production),
7868 use_auxiliary_predicate(extend_history),
7869 does_use_history(F/A,O),
7870 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7871 ( HistoryIDs == [] ->
7872 empty_named_history_novel_production(HistoryName,NovelProduction),
7873 empty_named_history_extend_history(HistoryName,ExtendHistory)
7874 ;
7875 reverse([OtherSusp|RestSusps],NamedSusps),
7876 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7877 HistorySusps = [HistorySusp|_],
7879 ( length(HistoryIDs, 1) ->
7880 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7881 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7882 ;
7883 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7884 Tuple =.. [t,HistoryName|HistorySusps]
7885 )
7886 )
7887 ;
7888 HistorySusp = Susp,
7889 maplist(extract_symbol,H2,ConstraintSymbols),
7890 sort([ID|RestIDs],HistoryIDs),
7891 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7892 Tuple =.. [t,RuleNb|HistorySusps]
7893 ),
7895 ( var(NovelProduction) ->
7896 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7897 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7898 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7899 ;
7900 true
7901 )
7902 ),
7905 ( chr_pp_flag(debugable,on) ->
7906 Rule = rule(_,_,Guard,Body),
7907 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7908 get_occurrence(F/A,O,_,ID),
7909 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7910 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7911 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7912 ;
7913 DebugTry = true,
7914 DebugApply = true
7915 ),
7917 ( is_stored_in_guard(F/A, RuleNb) ->
7918 GuardAttachment = Attachment,
7919 BodyAttachment = true
7920 ;
7921 GuardAttachment = true,
7922 BodyAttachment = Attachment % will be true if not observed at all
7923 ),
7925 Clause = (
7926 ClauseHead :-
7927 ( CurrentSuspTest,
7928 DiffSuspGoals,
7929 Matching,
7930 NovelProduction,
7931 GuardAttachment,
7932 GuardCopy,
7933 DebugTry ->
7934 DebugApply,
7935 ExtendHistory,
7936 BodyAttachment,
7937 BodyCopy,
7938 ConditionalRecursiveCall
7939 ; RecursiveCall
7940 )
7941 ),
7942 add_location(Clause,RuleNb,LocatedClause),
7943 L = [LocatedClause|T].
7945 extract_symbol(Head,F/A) :-
7946 functor(Head,F,A).
7948 novel_production_calls([],[],[],_,_,true).
7949 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7950 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7951 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7952 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7954 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7955 reverse(ReversedRestSusps,RestSusps),
7956 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7958 named_history_susps([],_,_,[]).
7959 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7960 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7961 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7965 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7966 !,
7967 functor(Head,F,A),
7968 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7969 get_constraint_mode(F/A,Mode),
7970 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7971 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7972 append(VarsSusp,ExtraVars,HeadVars).
7973 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7974 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7975 functor(Head,F,A),
7976 gen_var(Susps),
7977 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7978 get_constraint_mode(F/A,Mode),
7979 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7980 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7981 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7983 % returns
7984 % VarDict for the copies of variables in the original heads
7985 % VarsSuspsList list of lists of arguments for the successive heads
7986 % FirstVarsSusp top level arguments
7987 % SuspList list of all suspensions
7988 % Iterators list of all iterators
7989 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7990 !,
7991 functor(Head,F,A),
7992 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7993 get_constraint_mode(F/A,Mode),
7994 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7995 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7996 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7997 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7998 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7999 functor(Head,F,A),
8000 gen_var(Susps),
8001 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8002 get_constraint_mode(F/A,Mode),
8003 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8004 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8005 append(HeadVars,[Susp,Susps],Vars).
8007 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8008 !,
8009 functor(Head,F,A),
8010 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8011 get_constraint_mode(F/A,Mode),
8012 head_arg_matches(Pairs,Mode,[],_,VarDict),
8013 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8014 append(VarsSusp,ExtraVars,HeadVars).
8015 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8016 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8017 functor(Head,F,A),
8018 gen_var(Susps),
8019 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8020 get_constraint_mode(F/A,Mode),
8021 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8022 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8023 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8025 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8027 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8028 %% ____ _ _ _ _
8029 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8030 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8031 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8032 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8033 %%
8034 %% ____ _ _ _
8035 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8036 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8037 %% | _ < __/ |_| | | | __/\ V / (_| | |
8038 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8039 %%
8040 %% ____ _ _
8041 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8042 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8043 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8044 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8045 %% |___/
8047 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8048 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8049 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8050 ;
8051 NRestHeads = RestHeads,
8052 NRestIDs = RestIDs
8053 ).
8055 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8056 term_variables(Head,Vars),
8057 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8058 copy_term_nat(InitialData,InitialDataCopy),
8059 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8060 InitialDataCopy = InitialData,
8061 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8062 reverse(RNRestHeads,NRestHeads),
8063 reverse(RNRestIDs,NRestIDs).
8065 final_data(Entry) :-
8066 Entry = entry(_,_,_,_,[],_).
8068 expand_data(Entry,NEntry,Cost) :-
8069 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8070 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8071 term_variables([Head1|Vars],Vars1),
8072 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8073 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8075 % Assigns score to head based on known variables and heads to lookup
8076 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8077 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8078 functor(Head,F,A),
8079 get_store_type(F/A,StoreType),
8080 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8081 % }}}
8083 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8084 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8085 term_variables(Head,HeadVars0),
8086 term_variables(RestHeads,RestVars),
8087 ground_vars([Head],GroundVars),
8088 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8089 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8090 NScore is min(CScore,Score).
8091 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8092 ( CScore =< 100 ->
8093 Score = CScore
8094 ;
8095 order_score_indexes(Indexes,Head,KnownVars,Score)
8096 ).
8097 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8098 ( CScore =< 100 ->
8099 Score = CScore
8100 ;
8101 order_score_indexes(Indexes,Head,KnownVars,Score)
8102 ).
8103 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8104 term_variables(Head,HeadVars),
8105 term_variables(RestHeads,RestVars),
8106 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8107 Score is Score_ * 200,
8108 NScore is min(CScore,Score).
8109 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8110 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8111 Score = 1. % guaranteed O(1)
8112 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8113 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8114 multi_order_score([],_,_,_,_,_,Score,Score).
8115 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8116 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8117 ; Score1 = Score0
8118 ),
8119 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8121 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8122 Score is min(CScore,10).
8123 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8124 Score is min(CScore,10).
8125 % }}}
8128 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8129 order_score_indexes(Indexes,Head,Vars,Score) :-
8130 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8131 numbervars(VarsCopy,0,_),
8132 order_score_indexes(Indexes,HeadCopy,Score).
8134 order_score_indexes([I|Is],Head,Score) :-
8135 args(I,Head,Args),
8136 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8137 Score = 100
8138 ;
8139 order_score_indexes(Is,Head,Score)
8140 ).
8141 % }}}
8143 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8145 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8146 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8147 ( K-R-O == 0-0-0 ->
8148 Score = 0
8149 ; K > 0 ->
8150 Score is max(10 - K,0)
8151 ; R > 0 ->
8152 Score is max(10 - R,1) * 100
8153 ;
8154 Score is max(10-O,1) * 1000
8155 ).
8156 order_score_count_vars([],_,_,0-0-0).
8157 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8158 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8159 ( memberchk_eq(V,KnownVars) ->
8160 NK is K + 1,
8161 NR = R, NO = O
8162 ; memberchk_eq(V,RestVars) ->
8163 NR is R + 1,
8164 NK = K, NO = O
8165 ;
8166 NO is O + 1,
8167 NK = K, NR = R
8168 ).
8170 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8171 %% ___ _ _ _
8172 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8173 %% | || '_ \| | | '_ \| | '_ \ / _` |
8174 %% | || | | | | | | | | | | | | (_| |
8175 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8176 %% |___/
8178 %% SWI begin
8179 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8180 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8181 %% SWI end
8183 %% SICStus begin
8184 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8185 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8186 %% SICStus end
8188 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8190 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8191 %% _ _ _ _ _ _ _
8192 %% | | | | |_(_) (_) |_ _ _
8193 %% | | | | __| | | | __| | | |
8194 %% | |_| | |_| | | | |_| |_| |
8195 %% \___/ \__|_|_|_|\__|\__, |
8196 %% |___/
8198 % Create a fresh variable.
8199 gen_var(_).
8201 % Create =N= fresh variables.
8202 gen_vars(N,Xs) :-
8203 length(Xs,N).
8205 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8206 vars_susp(A,Vars,Susp,VarsSusp),
8207 Head =.. [_|Args],
8208 pairup(Args,Vars,HeadPairs).
8210 inc_id([N|Ns],[O|Ns]) :-
8211 O is N + 1.
8212 dec_id([N|Ns],[M|Ns]) :-
8213 M is N - 1.
8215 extend_id(Id,[0|Id]).
8217 next_id([_,N|Ns],[O|Ns]) :-
8218 O is N + 1.
8220 % return clause Head
8221 % for F/A constraint symbol, predicate identifier Id and arguments Head
8222 build_head(F,A,Id,Args,Head) :-
8223 buildName(F,A,Id,Name),
8224 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8225 ( may_trigger(F/A) ;
8226 get_allocation_occurrence(F/A,AO),
8227 get_max_occurrence(F/A,MO),
8228 MO >= AO ) ) ->
8229 Head =.. [Name|Args]
8230 ;
8231 init(Args,ArgsWOSusp), % XXX not entirely correct!
8232 Head =.. [Name|ArgsWOSusp]
8233 ).
8235 % return predicate name Result
8236 % for Fct/Aty constraint symbol and predicate identifier List
8237 buildName(Fct,Aty,List,Result) :-
8238 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8239 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8240 MO >= AO ) ; List \= [0])) ) ) ->
8241 atom_concat(Fct, '___' ,FctSlash),
8242 atomic_concat(FctSlash,Aty,FctSlashAty),
8243 buildName_(List,FctSlashAty,Result)
8244 ;
8245 Result = Fct
8246 ).
8248 buildName_([],Name,Name).
8249 buildName_([N|Ns],Name,Result) :-
8250 buildName_(Ns,Name,Name1),
8251 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8252 atomic_concat(NameDash,N,Result).
8254 vars_susp(A,Vars,Susp,VarsSusp) :-
8255 length(Vars,A),
8256 append(Vars,[Susp],VarsSusp).
8258 or_pattern(Pos,Pat) :-
8259 Pow is Pos - 1,
8260 Pat is 1 << Pow. % was 2 ** X
8262 and_pattern(Pos,Pat) :-
8263 X is Pos - 1,
8264 Y is 1 << X, % was 2 ** X
8265 Pat is (-1)*(Y + 1).
8267 make_name(Prefix,F/A,Name) :-
8268 atom_concat_list([Prefix,F,'___',A],Name).
8270 %===============================================================================
8271 % Attribute for attributed variables
8273 make_attr(N,Mask,SuspsList,Attr) :-
8274 length(SuspsList,N),
8275 Attr =.. [v,Mask|SuspsList].
8277 get_all_suspensions2(N,Attr,SuspensionsList) :-
8278 chr_pp_flag(dynattr,off), !,
8279 make_attr(N,_,SuspensionsList,Attr).
8281 % NEW
8282 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8283 % writeln(get_all_suspensions2),
8284 length(SuspensionsList,N),
8285 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8288 % NEW
8289 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8290 % writeln(normalize_attr),
8291 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8293 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8294 chr_pp_flag(dynattr,off), !,
8295 make_attr(N,_,SuspsList,Attr),
8296 nth1(Position,SuspsList,Suspensions).
8298 % NEW
8299 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8300 % writeln(get_suspensions),
8301 Goal =
8302 ( memberchk(Position-Suspensions,TAttr) ->
8303 true
8304 ;
8305 Suspensions = []
8306 ).
8308 %-------------------------------------------------------------------------------
8309 % +N: number of constraint symbols
8310 % +Suspension: source-level variable, for suspension
8311 % +Position: constraint symbol number
8312 % -Attr: source-level term, for new attribute
8313 singleton_attr(N,Suspension,Position,Attr) :-
8314 chr_pp_flag(dynattr,off), !,
8315 or_pattern(Position,Pattern),
8316 make_attr(N,Pattern,SuspsList,Attr),
8317 nth1(Position,SuspsList,[Suspension]),
8318 chr_delete(SuspsList,[Suspension],RestSuspsList),
8319 set_elems(RestSuspsList,[]).
8321 % NEW
8322 singleton_attr(N,Suspension,Position,Attr) :-
8323 % writeln(singleton_attr),
8324 Attr = [Position-[Suspension]].
8326 %-------------------------------------------------------------------------------
8327 % +N: number of constraint symbols
8328 % +Suspension: source-level variable, for suspension
8329 % +Position: constraint symbol number
8330 % +TAttr: source-level variable, for old attribute
8331 % -Goal: goal for creating new attribute
8332 % -NTAttr: source-level variable, for new attribute
8333 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8334 chr_pp_flag(dynattr,off), !,
8335 make_attr(N,Mask,SuspsList,Attr),
8336 or_pattern(Position,Pattern),
8337 nth1(Position,SuspsList,Susps),
8338 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8339 make_attr(N,Mask,SuspsList1,NewAttr1),
8340 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8341 make_attr(N,NewMask,SuspsList2,NewAttr2),
8342 Goal = (
8343 TAttr = Attr,
8344 ( Mask /\ Pattern =:= Pattern ->
8345 NTAttr = NewAttr1
8346 ;
8347 NewMask is Mask \/ Pattern,
8348 NTAttr = NewAttr2
8349 )
8350 ), !.
8352 % NEW
8353 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8354 % writeln(add_attr),
8355 Goal =
8356 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8357 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8358 ;
8359 NTAttr = [Position-[Suspension]|TAttr]
8360 ).
8362 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8363 chr_pp_flag(dynattr,off), !,
8364 or_pattern(Position,Pattern),
8365 and_pattern(Position,DelPattern),
8366 make_attr(N,Mask,SuspsList,Attr),
8367 nth1(Position,SuspsList,Susps),
8368 substitute_eq(Susps,SuspsList,[],SuspsList1),
8369 make_attr(N,NewMask,SuspsList1,Attr1),
8370 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8371 make_attr(N,Mask,SuspsList2,Attr2),
8372 get_target_module(Mod),
8373 Goal = (
8374 TAttr = Attr,
8375 ( Mask /\ Pattern =:= Pattern ->
8376 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8377 ( NewSusps == [] ->
8378 NewMask is Mask /\ DelPattern,
8379 ( NewMask == 0 ->
8380 del_attr(Var,Mod)
8381 ;
8382 put_attr(Var,Mod,Attr1)
8383 )
8384 ;
8385 put_attr(Var,Mod,Attr2)
8386 )
8387 ;
8388 true
8389 )
8390 ), !.
8392 % NEW
8393 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8394 % writeln(rem_attr),
8395 get_target_module(Mod),
8396 Goal =
8397 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8398 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8399 ( NSuspensions == [] ->
8400 ( RAttr == [] ->
8401 del_attr(Var,Mod)
8402 ;
8403 put_attr(Var,Mod,RAttr)
8404 )
8405 ;
8406 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8407 )
8408 ;
8409 true
8410 ).
8412 %-------------------------------------------------------------------------------
8413 % +N: number of constraint symbols
8414 % +TAttr1: source-level variable, for attribute
8415 % +TAttr2: source-level variable, for other attribute
8416 % -Goal: goal for merging the two attributes
8417 % -Attr: source-level term, for merged attribute
8418 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8419 chr_pp_flag(dynattr,off), !,
8420 make_attr(N,Mask1,SuspsList1,Attr1),
8421 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8422 Goal = (
8423 TAttr1 = Attr1,
8424 Goal2
8425 ).
8427 % NEW
8428 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8429 % writeln(merge_attributes),
8430 Goal = (
8431 sort(TAttr1,Sorted1),
8432 sort(TAttr2,Sorted2),
8433 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8434 ).
8437 %-------------------------------------------------------------------------------
8438 % +N: number of constraint symbols
8439 % +Mask1: ...
8440 % +SuspsList1: static term, for suspensions list
8441 % +TAttr2: source-level variable, for other attribute
8442 % -Goal: goal for merging the two attributes
8443 % -Attr: source-level term, for merged attribute
8444 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8445 make_attr(N,Mask2,SuspsList2,Attr2),
8446 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8447 list2conj(Gs,SortGoals),
8448 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8449 make_attr(N,Mask,SuspsList,Attr),
8450 Goal = (
8451 TAttr2 = Attr2,
8452 SortGoals,
8453 Mask is Mask1 \/ Mask2
8454 ).
8457 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8458 % Storetype dependent lookup
8460 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8461 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8462 %% -Goal,-SuspensionList) is det.
8463 %
8464 % Create a universal lookup goal for given head.
8465 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8466 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8467 functor(Head,F,A),
8468 get_store_type(F/A,StoreType),
8469 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8471 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8472 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8473 %% -Goal,-SuspensionList) is det.
8474 %
8475 % Create a universal lookup goal for given head.
8476 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8477 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8478 functor(Head,F,A),
8479 get_store_type(F/A,StoreType),
8480 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8482 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8483 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8484 %% +GroundVars,-Goal,-SuspensionList) is det.
8485 %
8486 % Create a universal lookup goal for given head.
8487 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8488 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8489 functor(Head,F,A),
8490 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8491 update_store_type(F/A,default).
8492 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8493 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8494 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8495 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8496 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8497 functor(Head,F,A),
8498 global_ground_store_name(F/A,StoreName),
8499 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8500 update_store_type(F/A,global_ground).
8501 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8502 arg(VarIndex,Head,OVar),
8503 arg(KeyIndex,Head,OKey),
8504 translate([OVar,OKey],VarDict,[Var,Key]),
8505 get_target_module(Module),
8506 Goal = (
8507 get_attr(Var,Module,AssocStore),
8508 lookup_assoc_store(AssocStore,Key,AllSusps)
8509 ).
8510 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8511 functor(Head,F,A),
8512 global_singleton_store_name(F/A,StoreName),
8513 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8514 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8515 update_store_type(F/A,global_singleton).
8516 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8517 once((
8518 member(ST,StoreTypes),
8519 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8520 )).
8521 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8522 functor(Head,F,A),
8523 arg(Index,Head,Var),
8524 translate([Var],VarDict,[KeyVar]),
8525 delay_phase_end(validate_store_type_assumptions,
8526 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8527 ),
8528 update_store_type(F/A,identifier_store(Index)),
8529 get_identifier_index(F/A,Index,_).
8530 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8531 functor(Head,F,A),
8532 arg(Index,Head,Var),
8533 ( var(Var) ->
8534 translate([Var],VarDict,[KeyVar]),
8535 Goal = StructGoal
8536 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8537 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8538 Goal = (LookupGoal,StructGoal)
8539 ),
8540 delay_phase_end(validate_store_type_assumptions,
8541 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8542 ),
8543 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8544 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8546 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8547 get_identifier_size(ISize),
8548 functor(Struct,struct,ISize),
8549 get_identifier_index(C,Index,IIndex),
8550 arg(IIndex,Struct,AllSusps),
8551 Goal = (KeyVar = Struct).
8553 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8554 type_indexed_identifier_structure(IndexType,Struct),
8555 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8556 arg(IIndex,Struct,AllSusps),
8557 Goal = (KeyVar = Struct).
8559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8560 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8561 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8562 %
8563 % Create a universal hash lookup goal for given head.
8564 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8565 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8566 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8567 ( KeyArgCopies = [KeyCopy] ->
8568 true
8569 ;
8570 KeyCopy =.. [k|KeyArgCopies]
8571 ),
8572 functor(Head,F,A),
8573 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8575 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8576 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8578 Goal = (GroundCheck,LookupGoal),
8580 ( HashType == inthash ->
8581 update_store_type(F/A,multi_inthash([Index]))
8582 ;
8583 update_store_type(F/A,multi_hash([Index]))
8584 ).
8586 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8587 member(Index,Indexes),
8588 args(Index,Head,KeyArgs),
8589 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8590 !.
8592 % check whether we can copy the given terms
8593 % with the given dictionary, and, if so, do so
8594 key_in_scope([],VarDict,[]).
8595 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8596 term_variables(Arg,Vars),
8597 translate(Vars,VarDict,VarCopies),
8598 copy_term(Arg/Vars,ArgCopy/VarCopies),
8599 key_in_scope(Args,VarDict,ArgCopies).
8601 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8602 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8603 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8604 %% +VarArgDict,-NewVarArgDict) is det.
8605 %
8606 % Create existential lookup goal for given head.
8607 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8608 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8609 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8610 sbag_member_call(Susp,AllSusps,Sbag),
8611 functor(Head,F,A),
8612 delay_phase_end(validate_store_type_assumptions,
8613 ( static_suspension_term(F/A,SuspTerm),
8614 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8615 )
8616 ),
8617 Goal = (
8618 UniversalGoal,
8619 Sbag,
8620 Susp = SuspTerm,
8621 GetState
8622 ).
8623 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8624 functor(Head,F,A),
8625 global_singleton_store_name(F/A,StoreName),
8626 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8627 Goal = (
8628 GetStoreGoal, % nb_getval(StoreName,Susp),
8629 Susp \== [],
8630 Susp = SuspTerm
8631 ),
8632 update_store_type(F/A,global_singleton).
8633 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8634 once((
8635 member(ST,StoreTypes),
8636 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8637 )).
8638 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8639 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8640 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8641 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8642 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8643 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8644 hash_index_filter(Pairs,Index,NPairs),
8646 functor(Head,F,A),
8647 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8648 Sbag = (AllSusps = [Susp])
8649 ;
8650 sbag_member_call(Susp,AllSusps,Sbag)
8651 ),
8652 delay_phase_end(validate_store_type_assumptions,
8653 ( static_suspension_term(F/A,SuspTerm),
8654 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8655 )
8656 ),
8657 Goal = (
8658 LookupGoal,
8659 Sbag,
8660 Susp = SuspTerm, % not inlined
8661 GetState
8662 ).
8663 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8664 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8665 hash_index_filter(Pairs,Index,NPairs),
8667 functor(Head,F,A),
8668 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8669 Sbag = (AllSusps = [Susp])
8670 ;
8671 sbag_member_call(Susp,AllSusps,Sbag)
8672 ),
8673 delay_phase_end(validate_store_type_assumptions,
8674 ( static_suspension_term(F/A,SuspTerm),
8675 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8676 )
8677 ),
8678 Goal = (
8679 LookupGoal,
8680 Sbag,
8681 Susp = SuspTerm, % not inlined
8682 GetState
8683 ).
8684 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8685 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8686 sbag_member_call(Susp,Susps,Sbag),
8687 functor(Head,F,A),
8688 delay_phase_end(validate_store_type_assumptions,
8689 ( static_suspension_term(F/A,SuspTerm),
8690 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8691 )
8692 ),
8693 Goal = (
8694 UGoal,
8695 Sbag,
8696 Susp = SuspTerm, % not inlined
8697 GetState
8698 ).
8700 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8701 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8702 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8703 %% +VarArgDict,-NewVarArgDict) is det.
8704 %
8705 % Create existential hash lookup goal for given head.
8706 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8707 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8708 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8710 hash_index_filter(Pairs,Index,NPairs),
8712 functor(Head,F,A),
8713 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8714 Sbag = (AllSusps = [Susp])
8715 ;
8716 sbag_member_call(Susp,AllSusps,Sbag)
8717 ),
8718 delay_phase_end(validate_store_type_assumptions,
8719 ( static_suspension_term(F/A,SuspTerm),
8720 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8721 )
8722 ),
8723 Goal = (
8724 LookupGoal,
8725 Sbag,
8726 Susp = SuspTerm, % not inlined
8727 GetState
8728 ).
8730 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8731 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8732 %
8733 % Filter out pairs already covered by given hash index.
8734 % makes them 'silent'
8735 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8736 hash_index_filter(Pairs,Index,NPairs) :-
8737 hash_index_filter(Pairs,Index,1,NPairs).
8739 hash_index_filter([],_,_,[]).
8740 hash_index_filter([P|Ps],Index,N,NPairs) :-
8741 ( Index = [I|Is] ->
8742 NN is N + 1,
8743 ( I > N ->
8744 NPairs = [P|NPs],
8745 hash_index_filter(Ps,[I|Is],NN,NPs)
8746 ; I == N ->
8747 NPairs = [silent(P)|NPs],
8748 hash_index_filter(Ps,Is,NN,NPs)
8749 )
8750 ;
8751 NPairs = [P|Ps]
8752 ).
8754 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8755 %------------------------------------------------------------------------------%
8756 %% assume_constraint_stores(+ConstraintSymbols) is det.
8757 %
8758 % Compute all constraint store types that are possible for the given
8759 % =ConstraintSymbols=.
8760 %------------------------------------------------------------------------------%
8761 assume_constraint_stores([]).
8762 assume_constraint_stores([C|Cs]) :-
8763 ( chr_pp_flag(debugable,off),
8764 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8765 is_stored(C),
8766 get_store_type(C,default) ->
8767 get_indexed_arguments(C,AllIndexedArgs),
8768 get_constraint_mode(C,Modes),
8769 aggregate_all(bag(Index)-count,
8770 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8771 IndexedArgs-NbIndexedArgs),
8772 % Construct Index Combinations
8773 ( NbIndexedArgs > 10 ->
8774 findall([Index],member(Index,IndexedArgs),Indexes)
8775 ;
8776 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8777 predsort(longer_list,UnsortedIndexes,Indexes)
8778 ),
8779 % EXPERIMENTAL HEURISTIC
8780 % findall(Index, (
8781 % member(Arg1,IndexedArgs),
8782 % member(Arg2,IndexedArgs),
8783 % Arg1 =< Arg2,
8784 % sort([Arg1,Arg2], Index)
8785 % ), UnsortedIndexes),
8786 % predsort(longer_list,UnsortedIndexes,Indexes),
8787 % Choose Index Type
8788 ( get_functional_dependency(C,1,Pattern,Key),
8789 all_distinct_var_args(Pattern), Key == [] ->
8790 assumed_store_type(C,global_singleton)
8791 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8792 get_constraint_type_det(C,ArgTypes),
8793 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8795 ( IntHashIndexes = [] ->
8796 Stores = Stores1
8797 ;
8798 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8799 ),
8800 ( HashIndexes = [] ->
8801 Stores1 = Stores2
8802 ;
8803 Stores1 = [multi_hash(HashIndexes)|Stores2]
8804 ),
8805 ( IdentifierIndexes = [] ->
8806 Stores2 = Stores3
8807 ;
8808 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8809 append(WrappedIdentifierIndexes,Stores3,Stores2)
8810 ),
8811 append(CompoundIdentifierIndexes,Stores4,Stores3),
8812 ( only_ground_indexed_arguments(C)
8813 -> Stores4 = [global_ground]
8814 ; Stores4 = [default]
8815 ),
8816 assumed_store_type(C,multi_store(Stores))
8817 ; true
8818 )
8819 ;
8820 true
8821 ),
8822 assume_constraint_stores(Cs).
8824 %------------------------------------------------------------------------------%
8825 %% partition_indexes(+Indexes,+Types,
8826 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8827 %------------------------------------------------------------------------------%
8828 partition_indexes([],_,[],[],[],[]).
8829 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8830 ( Index = [I],
8831 nth1(I,Types,Type),
8832 unalias_type(Type,UnAliasedType),
8833 UnAliasedType == chr_identifier ->
8834 IdentifierIndexes = [I|RIdentifierIndexes],
8835 IntHashIndexes = RIntHashIndexes,
8836 HashIndexes = RHashIndexes,
8837 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8838 ; Index = [I],
8839 nth1(I,Types,Type),
8840 unalias_type(Type,UnAliasedType),
8841 nonvar(UnAliasedType),
8842 UnAliasedType = chr_identifier(IndexType) ->
8843 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8844 IdentifierIndexes = RIdentifierIndexes,
8845 IntHashIndexes = RIntHashIndexes,
8846 HashIndexes = RHashIndexes
8847 ; Index = [I],
8848 nth1(I,Types,Type),
8849 unalias_type(Type,UnAliasedType),
8850 UnAliasedType == dense_int ->
8851 IntHashIndexes = [Index|RIntHashIndexes],
8852 HashIndexes = RHashIndexes,
8853 IdentifierIndexes = RIdentifierIndexes,
8854 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8855 ; member(I,Index),
8856 nth1(I,Types,Type),
8857 unalias_type(Type,UnAliasedType),
8858 nonvar(UnAliasedType),
8859 UnAliasedType = chr_identifier(_) ->
8860 % don't use chr_identifiers in hash indexes
8861 IntHashIndexes = RIntHashIndexes,
8862 HashIndexes = RHashIndexes,
8863 IdentifierIndexes = RIdentifierIndexes,
8864 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8865 ;
8866 IntHashIndexes = RIntHashIndexes,
8867 HashIndexes = [Index|RHashIndexes],
8868 IdentifierIndexes = RIdentifierIndexes,
8869 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8870 ),
8871 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8873 longer_list(R,L1,L2) :-
8874 length(L1,N1),
8875 length(L2,N2),
8876 compare(Rt,N2,N1),
8877 ( Rt == (=) ->
8878 compare(R,L1,L2)
8879 ;
8880 R = Rt
8881 ).
8883 all_distinct_var_args(Term) :-
8884 copy_term_nat(Term,TermCopy),
8885 functor(Term,F,A),
8886 functor(Pattern,F,A),
8887 Pattern =@= TermCopy.
8889 get_indexed_arguments(C,IndexedArgs) :-
8890 C = F/A,
8891 get_indexed_arguments(1,A,C,IndexedArgs).
8893 get_indexed_arguments(I,N,C,L) :-
8894 ( I > N ->
8895 L = []
8896 ; ( is_indexed_argument(C,I) ->
8897 L = [I|T]
8898 ;
8899 L = T
8900 ),
8901 J is I + 1,
8902 get_indexed_arguments(J,N,C,T)
8903 ).
8905 validate_store_type_assumptions([]).
8906 validate_store_type_assumptions([C|Cs]) :-
8907 validate_store_type_assumption(C),
8908 validate_store_type_assumptions(Cs).
8910 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8911 % new code generation
8912 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8913 Rule = rule(H1,_,Guard,Body),
8914 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8915 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8916 flatten(VarsAndSuspsList,VarsAndSusps),
8917 Vars = [ [] | VarsAndSusps],
8918 build_head(F,A,[O|Id],Vars,Head),
8919 ( PrevId0 = [_] ->
8920 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8921 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8922 PrevId = [PredictedPrevId] % PrevId = PrevId0
8923 ;
8924 PrevId = [O|PrevId0]
8925 ),
8926 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8927 Clause = ( Head :- PredecessorCall),
8928 add_dummy_location(Clause,LocatedClause),
8929 L = [LocatedClause | T].
8930 % ( H1 == [],
8931 % functor(CurrentHead,CF,CA),
8932 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8933 % L = T
8934 % ;
8935 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8936 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8937 % flatten(VarsAndSuspsList,VarsAndSusps),
8938 % Vars = [ [] | VarsAndSusps],
8939 % build_head(F,A,Id,Vars,Head),
8940 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8941 % Clause = ( Head :- PredecessorCall),
8942 % L = [Clause | T]
8943 % ).
8945 % skips back intelligently over global_singleton lookups
8946 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8947 ( Id = [0|_] ->
8948 % TOM: add partial success continuation optimization here!
8949 next_id(Id,PrevId),
8950 PrevVarsAndSusps = BaseCallArgs
8951 ;
8952 VarsAndSuspsList = [_|AllButFirstList],
8953 dec_id(Id,PrevId1),
8954 ( PrevHeads = [PrevHead|PrevHeads1],
8955 functor(PrevHead,F,A),
8956 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8957 PrevIterators = [_|PrevIterators1],
8958 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8959 ;
8960 PrevId = PrevId1,
8961 flatten(AllButFirstList,AllButFirst),
8962 PrevIterators = [PrevIterator|_],
8963 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8964 )
8965 ).
8967 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8968 Rule = rule(_,_,Guard,Body),
8969 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8970 init(AllSusps,PreSusps),
8971 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8972 gen_var(OtherSusps),
8973 functor(CurrentHead,OtherF,OtherA),
8974 gen_vars(OtherA,OtherVars),
8975 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8976 get_constraint_mode(OtherF/OtherA,Mode),
8977 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8979 delay_phase_end(validate_store_type_assumptions,
8980 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8981 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8982 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8983 )
8984 ),
8986 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8987 % create_get_mutable_ref(active,State,GetMutable),
8988 CurrentSuspTest = (
8989 OtherSusp = OtherSuspension,
8990 GetState,
8991 DiffSuspGoals,
8992 FirstMatching
8993 ),
8994 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8995 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8996 inc_id(Id,NestedId),
8997 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8998 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8999 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
9000 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
9001 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9003 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9004 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9005 RecursiveVars = PreVarsAndSusps1
9006 ;
9007 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9008 PrevId0 = Id
9009 ),
9010 ( PrevId0 = [_] ->
9011 PrevId = PrevId0
9012 ;
9013 PrevId = [O|PrevId0]
9014 ),
9015 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9017 Clause = (
9018 ClauseHead :-
9019 ( CurrentSuspTest,
9020 NextSuspGoal
9021 ->
9022 NestedHead
9023 ; RecursiveHead
9024 )
9025 ),
9026 add_dummy_location(Clause,LocatedClause),
9027 L = [LocatedClause|T].
9029 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9031 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9032 % Observation Analysis
9033 %
9034 % CLASSIFICATION
9035 % Enabled
9036 %
9037 % Analysis based on Abstract Interpretation paper.
9038 %
9039 % TODO:
9040 % stronger analysis domain [research]
9042 :- chr_constraint
9043 initial_call_pattern/1,
9044 call_pattern/1,
9045 call_pattern_worker/1,
9046 final_answer_pattern/2,
9047 abstract_constraints/1,
9048 depends_on/2,
9049 depends_on_ap/4,
9050 depends_on_goal/2,
9051 ai_observed_internal/2,
9052 % ai_observed/2,
9053 ai_not_observed_internal/2,
9054 ai_not_observed/2,
9055 ai_is_observed/2,
9056 depends_on_as/3,
9057 ai_observation_gather_results/0.
9059 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9060 :- chr_type program_point == any.
9062 :- chr_option(mode,initial_call_pattern(+)).
9063 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9065 :- chr_option(mode,call_pattern(+)).
9066 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9068 :- chr_option(mode,call_pattern_worker(+)).
9069 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9071 :- chr_option(mode,final_answer_pattern(+,+)).
9072 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9074 :- chr_option(mode,abstract_constraints(+)).
9075 :- chr_option(type_declaration,abstract_constraints(list)).
9077 :- chr_option(mode,depends_on(+,+)).
9078 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9080 :- chr_option(mode,depends_on_as(+,+,+)).
9081 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9082 :- chr_option(mode,depends_on_goal(+,+)).
9083 :- chr_option(mode,ai_is_observed(+,+)).
9084 :- chr_option(mode,ai_not_observed(+,+)).
9085 % :- chr_option(mode,ai_observed(+,+)).
9086 :- chr_option(mode,ai_not_observed_internal(+,+)).
9087 :- chr_option(mode,ai_observed_internal(+,+)).
9090 abstract_constraints_fd @
9091 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9093 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9094 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9095 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9097 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9098 ai_is_observed(_,_) <=> true.
9100 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9101 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9102 ai_observation_gather_results <=> true.
9104 %------------------------------------------------------------------------------%
9105 % Main Analysis Entry
9106 %------------------------------------------------------------------------------%
9107 ai_observation_analysis(ACs) :-
9108 ( chr_pp_flag(ai_observation_analysis,on),
9109 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9110 list_to_ord_set(ACs,ACSet),
9111 abstract_constraints(ACSet),
9112 ai_observation_schedule_initial_calls(ACSet,ACSet),
9113 ai_observation_gather_results
9114 ;
9115 true
9116 ).
9118 ai_observation_schedule_initial_calls([],_).
9119 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9120 ai_observation_schedule_initial_call(AC,ACs),
9121 ai_observation_schedule_initial_calls(RACs,ACs).
9123 ai_observation_schedule_initial_call(AC,ACs) :-
9124 ai_observation_top(AC,CallPattern),
9125 % ai_observation_bot(AC,ACs,CallPattern),
9126 initial_call_pattern(CallPattern).
9128 ai_observation_schedule_new_calls([],AP).
9129 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9130 AP = odom(_,Set),
9131 initial_call_pattern(odom(AC,Set)),
9132 ai_observation_schedule_new_calls(ACs,AP).
9134 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9135 <=>
9136 ai_observation_leq(AP2,AP1)
9137 |
9138 true.
9140 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9142 initial_call_pattern(CP) ==> call_pattern(CP).
9144 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9145 ==>
9146 ai_observation_schedule_new_calls(ACs,AP)
9147 pragma
9148 passive(ID3).
9150 call_pattern(CP) \ call_pattern(CP) <=> true.
9152 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9153 final_answer_pattern(CP1,AP).
9155 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9157 call_pattern(CP) ==> call_pattern_worker(CP).
9159 %------------------------------------------------------------------------------%
9160 % Abstract Goal
9161 %------------------------------------------------------------------------------%
9163 % AbstractGoala
9164 %call_pattern(odom([],Set)) ==>
9165 % final_answer_pattern(odom([],Set),odom([],Set)).
9167 call_pattern_worker(odom([],Set)) <=>
9168 % writeln(' - AbstractGoal'(odom([],Set))),
9169 final_answer_pattern(odom([],Set),odom([],Set)).
9171 % AbstractGoalb
9172 call_pattern_worker(odom([G|Gs],Set)) <=>
9173 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9174 CP1 = odom(G,Set),
9175 depends_on_goal(odom([G|Gs],Set),CP1),
9176 call_pattern(CP1).
9178 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9179 <=> true pragma passive(ID).
9180 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9181 ==>
9182 CP1 = odom([_|Gs],_),
9183 AP2 = odom([],Set),
9184 CCP = odom(Gs,Set),
9185 call_pattern(CCP),
9186 depends_on(CP1,CCP).
9188 %------------------------------------------------------------------------------%
9189 % Abstract Disjunction
9190 %------------------------------------------------------------------------------%
9192 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9193 CP = odom((AG1;AG2),Set),
9194 InitialAnswerApproximation = odom([],Set),
9195 final_answer_pattern(CP,InitialAnswerApproximation),
9196 CP1 = odom(AG1,Set),
9197 CP2 = odom(AG2,Set),
9198 call_pattern(CP1),
9199 call_pattern(CP2),
9200 depends_on_as(CP,CP1,CP2).
9202 %------------------------------------------------------------------------------%
9203 % Abstract Solve
9204 %------------------------------------------------------------------------------%
9205 call_pattern_worker(odom(builtin,Set)) <=>
9206 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9207 ord_empty(EmptySet),
9208 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9210 %------------------------------------------------------------------------------%
9211 % Abstract Drop
9212 %------------------------------------------------------------------------------%
9213 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9214 <=>
9215 O > MO
9216 |
9217 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9218 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9219 pragma
9220 passive(ID2).
9222 %------------------------------------------------------------------------------%
9223 % Abstract Activate
9224 %------------------------------------------------------------------------------%
9225 call_pattern_worker(odom(AC,Set))
9226 <=>
9227 AC = _ / _
9228 |
9229 % writeln(' - AbstractActivate'(odom(AC,Set))),
9230 CP = odom(occ(AC,1),Set),
9231 call_pattern(CP),
9232 depends_on(odom(AC,Set),CP).
9234 %------------------------------------------------------------------------------%
9235 % Abstract Passive
9236 %------------------------------------------------------------------------------%
9237 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9238 <=>
9239 is_passive(RuleNb,ID)
9240 |
9241 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9242 % DEFAULT
9243 NO is O + 1,
9244 DCP = odom(occ(C,NO),Set),
9245 call_pattern(DCP),
9246 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9247 depends_on(odom(occ(C,O),Set),DCP)
9248 pragma
9249 passive(ID2).
9250 %------------------------------------------------------------------------------%
9251 % Abstract Simplify
9252 %------------------------------------------------------------------------------%
9254 % AbstractSimplify
9255 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9256 <=>
9257 \+ is_passive(RuleNb,ID)
9258 |
9259 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9260 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9261 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9262 ai_observation_memo_abstract_goal(RuleNb,AG),
9263 call_pattern(odom(AG,Set2)),
9264 % DEFAULT
9265 NO is O + 1,
9266 DCP = odom(occ(C,NO),Set),
9267 call_pattern(DCP),
9268 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9269 % DEADLOCK AVOIDANCE
9270 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9271 pragma
9272 passive(ID2).
9274 depends_on_as(CP,CPS,CPD),
9275 final_answer_pattern(CPS,APS),
9276 final_answer_pattern(CPD,APD) ==>
9277 ai_observation_lub(APS,APD,AP),
9278 final_answer_pattern(CP,AP).
9281 :- chr_constraint
9282 ai_observation_memo_simplification_rest_heads/3,
9283 ai_observation_memoed_simplification_rest_heads/3.
9285 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9286 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9288 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9289 <=>
9290 QRH = RH.
9291 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9292 <=>
9293 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9294 once(select2(ID,_,IDs1,H1,_,RestH1)),
9295 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9296 ai_observation_abstract_constraints(H2,ACs,AH2),
9297 append(ARestHeads,AH2,AbstractHeads),
9298 sort(AbstractHeads,QRH),
9299 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9300 pragma
9301 passive(ID1),
9302 passive(ID2),
9303 passive(ID3).
9305 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9307 %------------------------------------------------------------------------------%
9308 % Abstract Propagate
9309 %------------------------------------------------------------------------------%
9312 % AbstractPropagate
9313 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9314 <=>
9315 \+ is_passive(RuleNb,ID)
9316 |
9317 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9318 % observe partners
9319 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9320 ai_observation_observe_set(Set,AHs,Set2),
9321 ord_add_element(Set2,C,Set3),
9322 ai_observation_memo_abstract_goal(RuleNb,AG),
9323 call_pattern(odom(AG,Set3)),
9324 ( ord_memberchk(C,Set2) ->
9325 Delete = no
9326 ;
9327 Delete = yes
9328 ),
9329 % DEFAULT
9330 NO is O + 1,
9331 DCP = odom(occ(C,NO),Set),
9332 call_pattern(DCP),
9333 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9334 pragma
9335 passive(ID2).
9337 :- chr_constraint
9338 ai_observation_memo_propagation_rest_heads/3,
9339 ai_observation_memoed_propagation_rest_heads/3.
9341 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9342 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9344 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9345 <=>
9346 QRH = RH.
9347 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9348 <=>
9349 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9350 once(select2(ID,_,IDs2,H2,_,RestH2)),
9351 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9352 ai_observation_abstract_constraints(H1,ACs,AH1),
9353 append(ARestHeads,AH1,AbstractHeads),
9354 sort(AbstractHeads,QRH),
9355 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9356 pragma
9357 passive(ID1),
9358 passive(ID2),
9359 passive(ID3).
9361 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9363 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9364 final_answer_pattern(CP,APD).
9365 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9366 final_answer_pattern(CPD,APD) ==>
9367 true |
9368 CP = odom(occ(C,O),_),
9369 ( ai_observation_is_observed(APP,C) ->
9370 ai_observed_internal(C,O)
9371 ;
9372 ai_not_observed_internal(C,O)
9373 ),
9374 ( Delete == yes ->
9375 APP = odom([],Set0),
9376 ord_del_element(Set0,C,Set),
9377 NAPP = odom([],Set)
9378 ;
9379 NAPP = APP
9380 ),
9381 ai_observation_lub(NAPP,APD,AP),
9382 final_answer_pattern(CP,AP).
9384 %------------------------------------------------------------------------------%
9385 % Catch All
9386 %------------------------------------------------------------------------------%
9388 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9390 %------------------------------------------------------------------------------%
9391 % Auxiliary Predicates
9392 %------------------------------------------------------------------------------%
9394 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9395 ord_intersection(S1,S2,S3).
9397 ai_observation_bot(AG,AS,odom(AG,AS)).
9399 ai_observation_top(AG,odom(AG,EmptyS)) :-
9400 ord_empty(EmptyS).
9402 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9403 ord_subset(S2,S1).
9405 ai_observation_observe_set(S,ACSet,NS) :-
9406 ord_subtract(S,ACSet,NS).
9408 ai_observation_abstract_constraint(C,ACs,AC) :-
9409 functor(C,F,A),
9410 AC = F/A,
9411 memberchk(AC,ACs).
9413 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9414 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9416 %------------------------------------------------------------------------------%
9417 % Abstraction of Rule Bodies
9418 %------------------------------------------------------------------------------%
9420 :- chr_constraint
9421 ai_observation_memoed_abstract_goal/2,
9422 ai_observation_memo_abstract_goal/2.
9424 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9425 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9427 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9428 <=>
9429 QAG = AG
9430 pragma
9431 passive(ID1).
9433 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9434 <=>
9435 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9436 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9437 QAG = AG,
9438 ai_observation_memoed_abstract_goal(RuleNb,AG)
9439 pragma
9440 passive(ID1),
9441 passive(ID2).
9443 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9444 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9445 term_variables((H1,H2,Guard),HVars),
9446 append(H1,H2,Heads),
9447 % variables that are declared to be ground are safe,
9448 ground_vars(Heads,GroundVars),
9449 % so we remove them from the list of 'dangerous' head variables
9450 list_difference_eq(HVars,GroundVars,HV),
9451 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9452 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9453 % HV are 'dangerous' variables, all others are fresh and safe
9455 ground_vars([],[]).
9456 ground_vars([H|Hs],GroundVars) :-
9457 functor(H,F,A),
9458 get_constraint_mode(F/A,Mode),
9459 % TOM: fix this code!
9460 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9461 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9462 ground_vars(Hs,GroundVars2),
9463 append(GroundVars1,GroundVars2,GroundVars).
9465 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9466 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9467 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9468 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9469 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9470 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9471 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9472 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9473 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9474 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9475 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9476 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9477 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9478 % non-CHR constraint is safe if it only binds fresh variables
9479 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9480 builtin_binds_b(G,Vars),
9481 intersect_eq(Vars,HV,[]),
9482 !.
9483 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9484 AG = builtin. % default case if goal is not recognized/safe
9486 ai_observation_is_observed(odom(_,ACSet),AC) :-
9487 \+ ord_memberchk(AC,ACSet).
9489 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9490 unconditional_occurrence(C,O) :-
9491 get_occurrence(C,O,RuleNb,ID),
9492 get_rule(RuleNb,PRule),
9493 PRule = pragma(ORule,_,_,_,_),
9494 copy_term_nat(ORule,Rule),
9495 Rule = rule(H1,H2,Guard,_),
9496 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9497 once((
9498 H1 = [Head], H2 == []
9499 ;
9500 H2 = [Head], H1 == [], \+ may_trigger(C)
9501 )),
9502 all_distinct_var_args(Head).
9504 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9506 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9507 % Partial wake analysis
9508 %
9509 % In a Var = Var unification do not wake up constraints of both variables,
9510 % but rather only those of one variable.
9511 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9513 :- chr_constraint partial_wake_analysis/0.
9514 :- chr_constraint no_partial_wake/1.
9515 :- chr_option(mode,no_partial_wake(+)).
9516 :- chr_constraint wakes_partially/1.
9517 :- chr_option(mode,wakes_partially(+)).
9519 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9520 ==>
9521 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9522 ( is_passive(RuleNb,ID) ->
9523 true
9524 ; Type == simplification ->
9525 select(H,H1,RestH1),
9526 H =.. [_|Args],
9527 term_variables(Guard,Vars),
9528 partial_wake_args(Args,ArgModes,Vars,FA)
9529 ; % Type == propagation ->
9530 select(H,H2,RestH2),
9531 H =.. [_|Args],
9532 term_variables(Guard,Vars),
9533 partial_wake_args(Args,ArgModes,Vars,FA)
9534 ).
9536 partial_wake_args([],_,_,_).
9537 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9538 ( Mode \== (+) ->
9539 ( nonvar(Arg) ->
9540 no_partial_wake(C)
9541 ; memberchk_eq(Arg,Vars) ->
9542 no_partial_wake(C)
9543 ;
9544 true
9545 )
9546 ;
9547 true
9548 ),
9549 partial_wake_args(Args,Modes,Vars,C).
9551 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9553 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9555 wakes_partially(C) <=> true.
9558 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9559 % Generate rules that implement chr_show_store/1 functionality.
9560 %
9561 % CLASSIFICATION
9562 % Experimental
9563 % Unused
9564 %
9565 % Generates additional rules:
9566 %
9567 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9568 % ...
9569 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9570 % $show <=> true.
9572 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9573 ( chr_pp_flag(show,on) ->
9574 Constraints = ['$show'/0|Constraints0],
9575 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9576 inc_rule_count(RuleNb),
9577 Rule = pragma(
9578 rule(['$show'],[],true,true),
9579 ids([0],[]),
9580 [],
9581 no,
9582 RuleNb
9583 )
9584 ;
9585 Constraints = Constraints0,
9586 Rules = Rules0
9587 ).
9589 generate_show_rules([],Rules,Rules).
9590 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9591 functor(C,F,A),
9592 inc_rule_count(RuleNb),
9593 Rule = pragma(
9594 rule([],['$show',C],true,writeln(C)),
9595 ids([],[0,1]),
9596 [passive(1)],
9597 no,
9598 RuleNb
9599 ),
9600 generate_show_rules(Rest,Tail,Rules).
9602 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9603 % Custom supension term layout
9605 static_suspension_term(F/A,Suspension) :-
9606 suspension_term_base(F/A,Base),
9607 Arity is Base + A,
9608 functor(Suspension,suspension,Arity).
9610 has_suspension_field(FA,Field) :-
9611 suspension_term_base_fields(FA,Fields),
9612 memberchk(Field,Fields).
9614 suspension_term_base(FA,Base) :-
9615 suspension_term_base_fields(FA,Fields),
9616 length(Fields,Base).
9618 suspension_term_base_fields(FA,Fields) :-
9619 ( chr_pp_flag(debugable,on) ->
9620 % 1. ID
9621 % 2. State
9622 % 3. Propagation History
9623 % 4. Generation Number
9624 % 5. Continuation Goal
9625 % 6. Functor
9626 Fields = [id,state,history,generation,continuation,functor]
9627 ;
9628 ( uses_history(FA) ->
9629 Fields = [id,state,history|Fields2]
9630 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9631 Fields = [state|Fields2]
9632 ;
9633 Fields = [id,state|Fields2]
9634 ),
9635 ( only_ground_indexed_arguments(FA) ->
9636 get_store_type(FA,StoreType),
9637 basic_store_types(StoreType,BasicStoreTypes),
9638 ( memberchk(global_ground,BasicStoreTypes) ->
9639 % 1. ID
9640 % 2. State
9641 % 3. Propagation History
9642 % 4. Global List Prev
9643 Fields2 = [global_list_prev|Fields3]
9644 ;
9645 % 1. ID
9646 % 2. State
9647 % 3. Propagation History
9648 Fields2 = Fields3
9649 ),
9650 ( chr_pp_flag(ht_removal,on)
9651 -> ht_prev_fields(BasicStoreTypes,Fields3)
9652 ; Fields3 = []
9653 )
9654 ; may_trigger(FA) ->
9655 % 1. ID
9656 % 2. State
9657 % 3. Propagation History
9658 ( uses_field(FA,generation) ->
9659 % 4. Generation Number
9660 % 5. Global List Prev
9661 Fields2 = [generation,global_list_prev|Fields3]
9662 ;
9663 Fields2 = [global_list_prev|Fields3]
9664 ),
9665 ( chr_pp_flag(mixed_stores,on),
9666 chr_pp_flag(ht_removal,on)
9667 -> get_store_type(FA,StoreType),
9668 basic_store_types(StoreType,BasicStoreTypes),
9669 ht_prev_fields(BasicStoreTypes,Fields3)
9670 ; Fields3 = []
9671 )
9672 ;
9673 % 1. ID
9674 % 2. State
9675 % 3. Propagation History
9676 % 4. Global List Prev
9677 Fields2 = [global_list_prev|Fields3],
9678 ( chr_pp_flag(mixed_stores,on),
9679 chr_pp_flag(ht_removal,on)
9680 -> get_store_type(FA,StoreType),
9681 basic_store_types(StoreType,BasicStoreTypes),
9682 ht_prev_fields(BasicStoreTypes,Fields3)
9683 ; Fields3 = []
9684 )
9685 )
9686 ).
9688 ht_prev_fields(Stores,Prevs) :-
9689 ht_prev_fields_int(Stores,PrevsList),
9690 append(PrevsList,Prevs).
9691 ht_prev_fields_int([],[]).
9692 ht_prev_fields_int([H|T],Fields) :-
9693 ( H = multi_hash(Indexes)
9694 -> maplist(ht_prev_field,Indexes,FH),
9695 Fields = [FH|FT]
9696 ; Fields = FT
9697 ),
9698 ht_prev_fields_int(T,FT).
9700 ht_prev_field(Index,Field) :-
9701 concat_atom(['multi_hash_prev-'|Index],Field).
9703 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9704 suspension_term_base_fields(FA,Fields),
9705 nth1(Index,Fields,FieldName), !,
9706 arg(Index,StaticSuspension,Field).
9707 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9708 suspension_term_base(FA,Base),
9709 StaticSuspension =.. [_|Args],
9710 drop(Base,Args,Field).
9711 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9712 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9715 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9716 suspension_term_base_fields(FA,Fields),
9717 nth1(Index,Fields,FieldName), !,
9718 Goal = arg(Index,DynamicSuspension,Field).
9719 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9720 static_suspension_term(FA,StaticSuspension),
9721 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9722 Goal = (DynamicSuspension = StaticSuspension).
9723 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9724 suspension_term_base(FA,Base),
9725 Index is I + Base,
9726 Goal = arg(Index,DynamicSuspension,Field).
9727 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9728 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9731 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9732 suspension_term_base_fields(FA,Fields),
9733 nth1(Index,Fields,FieldName), !,
9734 Goal = setarg(Index,DynamicSuspension,Field).
9735 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9736 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9738 basic_store_types(multi_store(Types),Types) :- !.
9739 basic_store_types(Type,[Type]).
9741 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9742 %
9744 :- chr_constraint
9745 phase_end/1,
9746 delay_phase_end/2.
9748 :- chr_option(mode,phase_end(+)).
9749 :- chr_option(mode,delay_phase_end(+,?)).
9751 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9752 % phase_end(Phase) <=> true.
9755 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9756 :- chr_constraint
9757 does_use_history/2,
9758 uses_history/1,
9759 novel_production_call/4.
9761 :- chr_option(mode,uses_history(+)).
9762 :- chr_option(mode,does_use_history(+,+)).
9763 :- chr_option(mode,novel_production_call(+,+,?,?)).
9765 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9766 does_use_history(FA,_) \ uses_history(FA) <=> true.
9767 uses_history(_FA) <=> fail.
9769 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9770 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9772 :- chr_constraint
9773 does_use_field/2,
9774 uses_field/2.
9776 :- chr_option(mode,uses_field(+,+)).
9777 :- chr_option(mode,does_use_field(+,+)).
9779 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9780 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9781 uses_field(_FA,_Field) <=> fail.
9783 :- chr_constraint
9784 uses_state/2,
9785 if_used_state/5,
9786 used_states_known/0.
9788 :- chr_option(mode,uses_state(+,+)).
9789 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9792 % states ::= not_stored_yet | passive | active | triggered | removed
9793 %
9794 % allocate CREATES not_stored_yet
9795 % remove CHECKS not_stored_yet
9796 % activate CHECKS not_stored_yet
9797 %
9798 % ==> no allocate THEN no not_stored_yet
9800 % recurs CREATES inactive
9801 % lookup CHECKS inactive
9803 % insert CREATES active
9804 % activate CREATES active
9805 % lookup CHECKS active
9806 % recurs CHECKS active
9808 % runsusp CREATES triggered
9809 % lookup CHECKS triggered
9810 %
9811 % ==> no runsusp THEN no triggered
9813 % remove CREATES removed
9814 % runsusp CHECKS removed
9815 % lookup CHECKS removed
9816 % recurs CHECKS removed
9817 %
9818 % ==> no remove THEN no removed
9820 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9822 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9824 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9825 <=> ResultGoal = Used.
9826 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9827 <=> ResultGoal = NotUsed.
9829 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9830 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9831 % (Feature for SSS)
9832 %
9833 % 1. Checking
9834 % ~~~~~~~~~~~
9835 %
9836 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9837 %
9838 % :- chr_option(declare_stored_constraints,on).
9839 %
9840 % the compiler will check for the storedness of constraints.
9841 %
9842 % By default, the compiler assumes that the programmer wants his constraints to
9843 % be never-stored. Hence, a warning will be issues when a constraint is actually
9844 % stored.
9845 %
9846 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9847 % to a constraint declaration, i.e. writes
9848 %
9849 % :- chr_constraint c(...) # stored.
9850 %
9851 % In that case a warning is issued when the constraint is never-stored.
9852 %
9853 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9854 % constraints are stored anyway.
9855 %
9856 %
9857 % 2. Rule Generation
9858 % ~~~~~~~~~~~~~~~~~~
9859 %
9860 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9861 %
9862 % :- chr_option(declare_stored_constraints,on).
9863 %
9864 % the compiler will generate default simplification rules for constraints.
9865 %
9866 % By default, no default rule is generated for a constraint. However, if the
9867 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9868 %
9869 % :- chr_constraint c(...) # default(Goal).
9870 %
9871 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9872 % the compiler generates a rule:
9873 %
9874 % c(_,...,_) <=> Goal.
9875 %
9876 % at the end of the program. If multiple default rules are generated, for several constraints,
9877 % then the order of the default rules is not specified.
9880 :- chr_constraint stored_assertion/1.
9881 :- chr_option(mode,stored_assertion(+)).
9882 :- chr_option(type_declaration,stored_assertion(constraint)).
9884 :- chr_constraint never_stored_default/2.
9885 :- chr_option(mode,never_stored_default(+,?)).
9886 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9888 % Rule Generation
9889 % ~~~~~~~~~~~~~~~
9891 generate_never_stored_rules(Constraints,Rules) :-
9892 ( chr_pp_flag(declare_stored_constraints,on) ->
9893 never_stored_rules(Constraints,Rules)
9894 ;
9895 Rules = []
9896 ).
9898 :- chr_constraint never_stored_rules/2.
9899 :- chr_option(mode,never_stored_rules(+,?)).
9900 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9902 never_stored_rules([],Rules) <=> Rules = [].
9903 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9904 Constraint = F/A,
9905 functor(Head,F,A),
9906 inc_rule_count(RuleNb),
9907 Rule = pragma(
9908 rule([Head],[],true,Goal),
9909 ids([0],[]),
9910 [],
9911 no,
9912 RuleNb
9913 ),
9914 Rules = [Rule|Tail],
9915 never_stored_rules(Constraints,Tail).
9916 never_stored_rules([_|Constraints],Rules) <=>
9917 never_stored_rules(Constraints,Rules).
9919 % Checking
9920 % ~~~~~~~~
9922 check_storedness_assertions(Constraints) :-
9923 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9924 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9925 ;
9926 true
9927 ).
9930 :- chr_constraint check_storedness_assertion/1.
9931 :- chr_option(mode,check_storedness_assertion(+)).
9932 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9934 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9935 <=> ( is_stored(Constraint) ->
9936 true
9937 ;
9938 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9939 ).
9940 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9941 <=> ( is_finally_stored(Constraint) ->
9942 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9943 ; is_stored(Constraint) ->
9944 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9945 ;
9946 true
9947 ).
9948 % never-stored, no default goal
9949 check_storedness_assertion(Constraint)
9950 <=> ( is_finally_stored(Constraint) ->
9951 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9952 ; is_stored(Constraint) ->
9953 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9954 ;
9955 true
9956 ).
9958 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9959 % success continuation analysis
9961 % TODO
9962 % also use for forward jumping improvement!
9963 % use Prolog indexing for generated code
9964 %
9965 % EXPORTED
9966 %
9967 % should_skip_to_next_id(C,O)
9968 %
9969 % get_occurrence_code_id(C,O,Id)
9970 %
9971 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9973 continuation_analysis(ConstraintSymbols) :-
9974 maplist(analyse_continuations,ConstraintSymbols).
9976 analyse_continuations(C) :-
9977 % 1. compute success continuations of the
9978 % occurrences of constraint C
9979 continuation_analysis(C,1),
9980 % 2. determine for which occurrences
9981 % to skip to next code id
9982 get_max_occurrence(C,MO),
9983 LO is MO + 1,
9984 bulk_propagation(C,1,LO),
9985 % 3. determine code id for each occurrence
9986 set_occurrence_code_id(C,1,0).
9988 % 1. Compute the success continuations of constrait C
9989 %-------------------------------------------------------------------------------
9991 continuation_analysis(C,O) :-
9992 get_max_occurrence(C,MO),
9993 ( O > MO ->
9994 true
9995 ; O == MO ->
9996 NextO is O + 1,
9997 continuation_occurrence(C,O,NextO)
9998 ;
9999 constraint_continuation(C,O,MO,NextO),
10000 continuation_occurrence(C,O,NextO),
10001 NO is O + 1,
10002 continuation_analysis(C,NO)
10003 ).
10005 constraint_continuation(C,O,MO,NextO) :-
10006 ( get_occurrence_head(C,O,Head) ->
10007 NO is O + 1,
10008 ( between(NO,MO,NextO),
10009 get_occurrence_head(C,NextO,NextHead),
10010 unifiable(Head,NextHead,_) ->
10011 true
10012 ;
10013 NextO is MO + 1
10014 )
10015 ; % current occurrence is passive
10016 NextO = MO
10017 ).
10019 get_occurrence_head(C,O,Head) :-
10020 get_occurrence(C,O,RuleNb,Id),
10021 \+ is_passive(RuleNb,Id),
10022 get_rule(RuleNb,Rule),
10023 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10024 ( select2(Id,Head,Ids1,H1,_,_) -> true
10025 ; select2(Id,Head,Ids2,H2,_,_)
10026 ).
10028 :- chr_constraint continuation_occurrence/3.
10029 :- chr_option(mode,continuation_occurrence(+,+,+)).
10031 :- chr_constraint get_success_continuation_occurrence/3.
10032 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10034 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10035 <=>
10036 X = NO.
10038 get_success_continuation_occurrence(C,O,X)
10039 <=>
10040 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10042 % 2. figure out when to skip to next code id
10043 %-------------------------------------------------------------------------------
10044 % don't go beyond the last occurrence
10045 % we have to go to next id for storage here
10047 :- chr_constraint skip_to_next_id/2.
10048 :- chr_option(mode,skip_to_next_id(+,+)).
10050 :- chr_constraint should_skip_to_next_id/2.
10051 :- chr_option(mode,should_skip_to_next_id(+,+)).
10053 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10054 <=>
10055 true.
10057 should_skip_to_next_id(_,_)
10058 <=>
10059 fail.
10061 :- chr_constraint bulk_propagation/3.
10062 :- chr_option(mode,bulk_propagation(+,+,+)).
10064 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10065 <=>
10066 O >= MO
10067 |
10068 skip_to_next_id(C,O).
10069 % we have to go to the next id here because
10070 % a predecessor needs it
10071 bulk_propagation(C,O,LO)
10072 <=>
10073 LO =:= O + 1
10074 |
10075 skip_to_next_id(C,O),
10076 get_max_occurrence(C,MO),
10077 NLO is MO + 1,
10078 bulk_propagation(C,LO,NLO).
10079 % we have to go to the next id here because
10080 % we're running into a simplification rule
10081 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10082 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10083 <=>
10084 NO =:= O + 1
10085 |
10086 skip_to_next_id(C,O),
10087 get_max_occurrence(C,MO),
10088 NLO is MO + 1,
10089 bulk_propagation(C,NO,NLO).
10090 % we skip the next id here
10091 % and go to the next occurrence
10092 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10093 <=>
10094 NextO > O + 1
10095 |
10096 NLO is min(LO,NextO),
10097 NO is O + 1,
10098 bulk_propagation(C,NO,NLO).
10099 % default case
10100 % err on the safe side
10101 bulk_propagation(C,O,LO)
10102 <=>
10103 skip_to_next_id(C,O),
10104 get_max_occurrence(C,MO),
10105 NLO is MO + 1,
10106 NO is O + 1,
10107 bulk_propagation(C,NO,NLO).
10109 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10111 % if this occurrence is passive, but has to skip,
10112 % then the previous one must skip instead...
10113 % IMPROVE reasoning is conservative
10114 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10115 ==>
10116 O > 1
10117 |
10118 PO is O - 1,
10119 skip_to_next_id(C,PO).
10121 % 3. determine code id of each occurrence
10122 %-------------------------------------------------------------------------------
10124 :- chr_constraint set_occurrence_code_id/3.
10125 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10127 :- chr_constraint occurrence_code_id/3.
10128 :- chr_option(mode,occurrence_code_id(+,+,+)).
10130 % stop at the end
10131 set_occurrence_code_id(C,O,IdNb)
10132 <=>
10133 get_max_occurrence(C,MO),
10134 O > MO
10135 |
10136 occurrence_code_id(C,O,IdNb).
10138 % passive occurrences don't change the code id
10139 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10140 <=>
10141 occurrence_code_id(C,O,IdNb),
10142 NO is O + 1,
10143 set_occurrence_code_id(C,NO,IdNb).
10145 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10146 <=>
10147 occurrence_code_id(C,O,IdNb),
10148 NO is O + 1,
10149 set_occurrence_code_id(C,NO,IdNb).
10151 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10152 <=>
10153 occurrence_code_id(C,O,IdNb),
10154 NO is O + 1,
10155 NIdNb is IdNb + 1,
10156 set_occurrence_code_id(C,NO,NIdNb).
10158 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10159 <=>
10160 occurrence_code_id(C,O,IdNb),
10161 NO is O + 1,
10162 set_occurrence_code_id(C,NO,IdNb).
10164 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10166 :- chr_constraint get_occurrence_code_id/3.
10167 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10169 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10170 <=>
10171 X = IdNb.
10173 get_occurrence_code_id(C,O,X)
10174 <=>
10175 ( O == 0 ->
10176 true % X = 0
10177 ;
10178 format('no occurrence code for ~w!\n',[C:O])
10179 ).
10181 get_success_continuation_code_id(C,O,NextId) :-
10182 get_success_continuation_occurrence(C,O,NextO),
10183 get_occurrence_code_id(C,NextO,NextId).
10185 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10186 % COLLECT CONSTANTS FOR INLINING
10187 %
10188 % for SSS
10190 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10192 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10193 collect_constants(Rules,Constraints,Clauses0) :-
10194 ( not_restarted, chr_pp_flag(experiment,on) ->
10195 ( chr_pp_flag(sss,on) ->
10196 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10197 copy_term_nat(Clauses0,Clauses),
10198 flatten_clauses(Clauses,Dictionary,FlatClauses),
10199 install_new_declarations_and_restart(FlatClauses)
10200 ;
10201 maplist(collect_rule_constants(Constraints),Rules),
10202 ( chr_pp_flag(verbose,on) ->
10203 print_chr_constants
10204 ;
10205 true
10206 ),
10207 ( chr_pp_flag(experiment,on) ->
10208 flattening_dictionary(Constraints,Dictionary),
10209 copy_term_nat(Clauses0,Clauses),
10210 flatten_clauses(Clauses,Dictionary,FlatClauses),
10211 install_new_declarations_and_restart(FlatClauses)
10212 ;
10213 true
10214 )
10215 )
10216 ;
10217 true
10218 ).
10220 :- chr_constraint chr_constants/1.
10221 :- chr_option(mode,chr_constants(+)).
10223 :- chr_constraint get_chr_constants/1.
10225 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10227 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10229 % collect_rule_constants(+constraint_symbols,+rule) {{{
10230 collect_rule_constants(Constraints,Rule) :-
10231 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10232 maplist(collect_head_constants,H1),
10233 maplist(collect_head_constants,H2),
10234 collect_body_constants(B,Constraints).
10236 collect_body_constants(Body,Constraints) :-
10237 conj2list(Body,Goals),
10238 maplist(collect_goal_constants(Constraints),Goals).
10240 collect_goal_constants(Constraints,Goal) :-
10241 ( nonvar(Goal),
10242 functor(Goal,C,N),
10243 memberchk(C/N,Constraints) ->
10244 collect_head_constants(Goal)
10245 ; nonvar(Goal),
10246 Goal = Mod : TheGoal,
10247 get_target_module(Module),
10248 Mod == Module,
10249 nonvar(TheGoal),
10250 functor(TheGoal,C,N),
10251 memberchk(C/N,Constraints) ->
10252 collect_head_constants(TheGoal)
10253 ;
10254 true
10255 ).
10257 collect_head_constants(Head) :-
10258 functor(Head,C,N),
10259 get_constraint_type_det(C/N,Types),
10260 Head =.. [_|Args],
10261 collect_all_arg_constants(Args,Types,[]).
10263 collect_all_arg_constants([],[],Constants) :-
10264 ( Constants \== [] ->
10265 add_chr_constants(Constants)
10266 ;
10267 true
10268 ).
10269 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10270 unalias_type(Type,NormalizedType),
10271 ( is_chr_constants_type(NormalizedType,Key,_) ->
10272 ( ground(Arg) ->
10273 collect_all_arg_constants(Args,Types,[Key-Arg|Constants0])
10274 ; % no useful information here
10275 true
10276 )
10277 ;
10278 collect_all_arg_constants(Args,Types,Constants0)
10279 ).
10281 add_chr_constants(Pairs) :-
10282 keysort(Pairs,SortedPairs),
10283 add_chr_constants_(SortedPairs).
10285 :- chr_constraint add_chr_constants_/1.
10286 :- chr_option(mode,add_chr_constants_(+)).
10288 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10289 sort([Constants|MoreConstants],NConstants),
10290 chr_constants(NConstants).
10292 add_chr_constants_(Constants) <=>
10293 chr_constants([Constants]).
10295 % }}}
10297 :- chr_constraint print_chr_constants/0. % {{{
10299 print_chr_constants, chr_constants(Constants) # Id ==>
10300 format('\t* chr_constants : ~w.\n',[Constants])
10301 pragma passive(Id).
10303 print_chr_constants <=>
10304 true.
10306 % }}}
10308 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10309 flattening_dictionary([],[]).
10310 flattening_dictionary([CS|CSs],Dictionary) :-
10311 ( flattening_dictionary_entry(CS,Entry) ->
10312 Dictionary = [Entry|Rest]
10313 ;
10314 Dictionary = Rest
10315 ),
10316 flattening_dictionary(CSs,Rest).
10318 flattening_dictionary_entry(CS,Entry) :-
10319 get_constraint_type_det(CS,Types),
10320 constant_positions(Types,1,Positions,Keys,Handler),
10321 Positions \== [], % there are chr_constant arguments
10322 pairup(Keys,Constants,Pairs0),
10323 keysort(Pairs0,Pairs),
10324 Entry = CS-Positions-Specs-Handler,
10325 get_chr_constants(ConstantsList),
10326 findall(Spec,
10327 ( member(Pairs,ConstantsList)
10328 , flat_spec(CS,Positions,Constants,Spec)
10329 ),
10330 Specs).
10332 constant_positions([],_,[],[],no).
10333 constant_positions([Type|Types],I,Positions,Keys,Handler) :-
10334 unalias_type(Type,NormalizedType),
10335 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10336 compose_error_handlers(ErrorHandler,NHandler,Handler),
10337 Positions = [I|NPositions],
10338 Keys = [Key|NKeys]
10339 ;
10340 NPositions = Positions,
10341 NKeys = Keys,
10342 NHandler = Handler
10343 ),
10344 J is I + 1,
10345 constant_positions(Types,J,NPositions,NKeys,NHandler).
10347 compose_error_handlers(no,Handler,Handler).
10348 compose_error_handlers(yes(Handler),_,yes(Handler)).
10350 flat_spec(C/N,Positions,Terms,Spec) :-
10351 Spec = Terms - Functor,
10352 term_to_atom(Terms,TermsAtom),
10353 term_to_atom(Positions,PositionsAtom),
10354 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10356 % }}}
10358 % }}}
10359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10360 % RESTART AFTER FLATTENING {{{
10362 restart_after_flattening(Declarations,Declarations) :-
10363 nb_setval('$chr_restart_after_flattening',started).
10364 restart_after_flattening(_,Declarations) :-
10365 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10366 nb_setval('$chr_restart_after_flattening',restarted).
10368 not_restarted :-
10369 nb_getval('$chr_restart_after_flattening',started).
10371 install_new_declarations_and_restart(Declarations) :-
10372 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10373 fail. /* fails to choicepoint of restart_after_flattening */
10374 % }}}
10375 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10376 % FLATTENING {{{
10378 % DONE
10379 % -) generate dictionary from collected chr_constants
10380 % enable with :- chr_option(experiment,on).
10381 % -) issue constraint declarations for constraints not present in
10382 % dictionary
10383 % -) integrate with CHR compiler
10384 % -) pass Mike's test code (full syntactic support for current CHR code)
10385 % -) rewrite the body using the inliner
10386 %
10387 % TODO:
10388 % -) refined semantics correctness issue
10389 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10391 flatten_clauses(Clauses,Dict,NClauses) :-
10392 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10393 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10395 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10396 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10397 dispatching_rules(Dict,NClauses1),
10398 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10399 flatten_rules(Clauses,Dict,NClauses3),
10400 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10402 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10403 % Declarations for non-flattened constraints
10405 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10406 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10407 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10408 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10409 flatten(DeclarationsList,Declarations).
10411 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10412 [(:- chr_constraint ConstraintSymbol),
10413 (:- chr_option(mode,ModeDeclPattern)),
10414 (:- chr_option(type_declaration,TypeDeclPattern))
10415 ]) :-
10416 ConstraintSymbol = Functor / Arity,
10417 % print optional mode declaration
10418 functor(ModeDeclPattern,Functor,Arity),
10419 ( memberchk(ModeDeclPattern,ModeDecls) ->
10420 true
10421 ;
10422 replicate(Arity,(?),Modes),
10423 ModeDeclPattern =.. [_|Modes]
10424 ),
10425 % print optional type declaration
10426 functor(TypeDeclPattern,Functor,Arity),
10427 ( memberchk(TypeDeclPattern,TypeDecls) ->
10428 true
10429 ;
10430 replicate(Arity,any,Types),
10431 TypeDeclPattern =.. [_|Types]
10432 ).
10433 % }}}
10434 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10435 % read clauses from file
10436 % CHR are returned
10437 % declared constaints are returned
10438 % type definitions are returned and printed
10439 % mode declarations are returned
10440 % other clauses are returned
10442 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10443 flatten_readcontent([],[],[],[],[],[],[]).
10444 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10445 % read(Clause),
10446 ( Clause == end_of_file ->
10447 Rules = [],
10448 ConstraintSymbols = [],
10449 ModeDecls = [],
10450 TypeDecls = [],
10451 TypeDefs = [],
10452 RestClauses = []
10453 ; crude_is_rule(Clause) ->
10454 Rules = [Clause|RestRules],
10455 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10456 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10457 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10458 append(SomeModeDecls,RestModeDecls,ModeDecls),
10459 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10460 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10461 ; is_mode_declaration(Clause,ModeDecl) ->
10462 ModeDecls = [ModeDecl|RestModeDecls],
10463 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10464 ; is_type_declaration(Clause,TypeDecl) ->
10465 TypeDecls = [TypeDecl|RestTypeDecls],
10466 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10467 ; is_type_definition(Clause,TypeDef) ->
10468 RestClauses = [Clause|NRestClauses],
10469 TypeDefs = [TypeDef|RestTypeDefs],
10470 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10471 ; ( Clause = (:- op(A,B,C)) ->
10472 % assert operators in order to read and print them out properly
10473 op(A,B,C)
10474 ;
10475 true
10476 ),
10477 RestClauses = [Clause|NRestClauses],
10478 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10479 ).
10481 crude_is_rule(_ @ _).
10482 crude_is_rule(_ pragma _).
10483 crude_is_rule(_ ==> _).
10484 crude_is_rule(_ <=> _).
10486 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10487 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10488 conj2list(Cs,Constraints0),
10489 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10491 pure_extract_type_mode([],[],[],[]).
10492 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10493 pure_extract_type_mode(R,R2,Modes,Types).
10494 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10495 functor(C,F,A),
10496 ConstraintSymbol = F/A,
10497 C =.. [_|Args],
10498 extract_types_and_modes(Args,ArgTypes,ArgModes),
10499 Mode =.. [F|ArgModes],
10500 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10501 Types = RTypes
10502 ;
10503 Types = [Type|RTypes],
10504 Type =.. [F|ArgTypes]
10505 ),
10506 pure_extract_type_mode(R,R2,Modes,RTypes).
10508 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10510 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10511 % }}}
10512 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10513 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10514 % including mode and type declarations
10516 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10517 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10518 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10519 flatten(ConstraintSpecs0,ConstraintSpecs).
10521 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10522 [(:- chr_constraint ConstraintSpec),
10523 (:- chr_option(mode,NewModeDecl)),
10524 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10525 member(C/N-I-SFs-_,Dict),
10526 arg_modes(C,N,ModeDecls,Modes),
10527 specialize_modes(Modes,I,SpecializedModes),
10528 arg_types(C,N,TypeDecls,Types),
10529 specialize_types(Types,I,SpecializedTypes),
10530 length(I,IndexSize),
10531 AN is N - IndexSize,
10532 member(_Term-F,SFs),
10533 ConstraintSpec = F/AN,
10534 NewModeDecl =.. [F|SpecializedModes],
10535 NewTypeDecl =.. [F|SpecializedTypes].
10537 arg_modes(C,N,ModeDecls,ArgModes) :-
10538 functor(ConstraintPattern,C,N),
10539 ( memberchk(ConstraintPattern,ModeDecls) ->
10540 ConstraintPattern =.. [_|ArgModes]
10541 ;
10542 replicate(N,?,ArgModes)
10543 ).
10545 specialize_modes(Modes,I,SpecializedModes) :-
10546 split_args(I,Modes,_,SpecializedModes).
10548 arg_types(C,N,TypeDecls,ArgTypes) :-
10549 functor(ConstraintPattern,C,N),
10550 ( memberchk(ConstraintPattern,TypeDecls) ->
10551 ConstraintPattern =.. [_|ArgTypes]
10552 ;
10553 replicate(N,any,ArgTypes)
10554 ).
10556 specialize_types(Types,I,SpecializedTypes) :-
10557 split_args(I,Types,_,SpecializedTypes).
10558 % }}}
10559 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10560 % DISPATCHING RULES
10561 %
10562 % dispatching_rules(+dict,-newrules)
10565 % {{{
10567 % This code generates a decision tree for calling the appropriate specialized
10568 % constraint based on the particular value of the argument the constraint
10569 % is being specialized on.
10570 %
10571 % In case an error handler is provided, the handler is called with the
10572 % unexpected constraint.
10574 dispatching_rules([],[]).
10575 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10576 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10577 dispatching_rules(Dict,RestDispatchingRules).
10579 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10580 ( increasing_numbers(I,1) ->
10581 /* index on first arguments */
10582 Rules0 = Rules,
10583 NCN = C/N
10584 ;
10585 /* reorder arguments for 1st argument indexing */
10586 functor(Head,C,N),
10587 Head =.. [_|Args],
10588 split_args(I,Args,GroundArgs,OtherArgs),
10589 append(GroundArgs,OtherArgs,ShuffledArgs),
10590 atom_concat(C,'_$shuffled',NC),
10591 Body =.. [NC|ShuffledArgs],
10592 [(Head :- Body)|Rules0] = Rules,
10593 NCN = NC / N
10594 ),
10595 Context = swap(C,I),
10596 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10598 increasing_numbers([],_).
10599 increasing_numbers([X|Ys],X) :-
10600 Y is X + 1,
10601 increasing_numbers(Ys,Y).
10603 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10604 length(I,IndexLength),
10605 once(pairup(TermLists,Functors,SFs)),
10606 maplist(head_tail,TermLists,Heads,Tails),
10607 Payload is N - IndexLength,
10608 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10609 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10611 dispatching_action(Functor,PayloadArgs,Goal) :-
10612 Goal =.. [Functor|PayloadArgs].
10614 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10615 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10617 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10618 % length MorePatterns == length Patterns == length Results
10619 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10620 MorePatterns = [List|_],
10621 length(List,N),
10622 aggregate_all(set(F/A),
10623 ( member(Pattern,Patterns),
10624 functor(Pattern,F,A)
10625 ),
10626 FAs),
10627 N1 is N + 1,
10628 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10630 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10631 ( MaybeErrorHandler = yes(ErrorHandler) ->
10632 Clauses0 = [ErrorClause|Clauses],
10633 ErrorClause = (Head :- Body),
10634 Arity is N + Payload,
10635 functor(Head,Symbol,Arity),
10636 reconstruct_original_term(Context,Head,Term),
10637 Body =.. [ErrorHandler,Term]
10638 ;
10639 Clauses0 = Clauses
10640 ).
10641 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10642 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10643 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10645 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10646 Clause = (Head :- Cut, Body),
10647 ( MaybeErrorHandler = yes(_) ->
10648 Cut = (!)
10649 ;
10650 Cut = true
10651 ),
10652 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10653 N1 is N + Payload,
10654 functor(Head,Symbol,N1),
10655 arg(1,Head,IndexPattern),
10656 Head =.. [_,_|RestArgs],
10657 length(PayloadArgs,Payload),
10658 once(append(Vs,PayloadArgs,RestArgs)),
10659 /* IndexPattern = F(...) */
10660 functor(IndexPattern,F,A),
10661 Context1 = index_functor(F,A,Context0),
10662 IndexPattern =.. [_|Args],
10663 append(Args,RestArgs,RecArgs),
10664 ( RecArgs == PayloadArgs ->
10665 /* nothing more to match on */
10666 List = Tail,
10667 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10668 MoreActions = [Action],
10669 call(Action,PayloadArgs,Body)
10670 ; /* more things to match on */
10671 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10672 ( MoreActions = [OneMoreAction] ->
10673 /* only one more thing to match on */
10674 MoreCases = [OneMoreCase],
10675 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10676 List = Tail,
10677 call(OneMoreAction,PayloadArgs,Body)
10678 ;
10679 /* more than one thing to match on */
10680 /* [ x1,..., xn]
10681 [xs1,...,xsn]
10682 */
10683 pairup(Cases,MoreCases,CasePairs),
10684 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10685 append(Args,Vs,[First|Rest]),
10686 First-Rest = CommonPatternPair,
10687 Context2 = gct([First|Rest],Context1),
10688 gensym(Prefix,RSymbol),
10689 append(DiffVars,PayloadArgs,RecCallVars),
10690 Body =.. [RSymbol|RecCallVars],
10691 findall(CH-CT,member([CH|CT],Differences),CPairs),
10692 once(pairup(CHs,CTs,CPairs)),
10693 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10694 )
10695 ).
10698 % split(list,int,before,at,after).
10700 split([X|Xs],I,Before,At,After) :-
10701 ( I == 1 ->
10702 Before = [],
10703 At = X,
10704 After = Xs
10705 ;
10706 J is I - 1,
10707 Before = [X|RBefore],
10708 split(Xs,J,RBefore,At,After)
10709 ).
10711 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10712 %
10713 % context ::= swap(functor,positions)
10714 % | index_functor(functor,arity,context)
10715 % | gct(Pattern,Context)
10717 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10718 functor(Term,_,Arity),
10719 functor(OriginalTerm,Functor,Arity),
10720 OriginalTerm =.. [_|OriginalArgs],
10721 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10722 Term =.. [_|Args],
10723 append(IndexArgs,OtherArgs,Args).
10724 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10725 Term0 =.. [Predicate|Args],
10726 split_at(Arity,Args,IndexArgs,RestArgs),
10727 Index =.. [Functor|IndexArgs],
10728 Term1 =.. [Predicate,Index|RestArgs],
10729 reconstruct_original_term(Context,Term1,OriginalTerm).
10730 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10731 copy_term_nat(PatternList,IndexTerms),
10732 term_variables(IndexTerms,Variables),
10733 Term0 =.. [Predicate|Args0],
10734 append(Variables,RestArgs,Args0),
10735 append(IndexTerms,RestArgs,Args1),
10736 Term1 =.. [Predicate|Args1],
10737 reconstruct_original_term(Context,Term1,OriginalTerm).
10738 % }}}
10740 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10741 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10742 %
10743 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10744 %
10745 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
10747 % {{{
10748 flatten_rules(Rules,Dict,FlatRules) :-
10749 flatten_rules1(Rules,Dict,FlatRulesList),
10750 flatten(FlatRulesList,FlatRules).
10752 flatten_rules1([],_,[]).
10753 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10754 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10755 flatten_rules1(Rules,Dict,FlatRulesList).
10757 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10758 flatten_rule(Rule,Dict,NRule).
10759 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10760 flatten_rule(Rule,Dict,NRule).
10761 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10762 flatten_heads(H,Dict,NH),
10763 flatten_body(B,Dict,NB).
10764 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10765 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10766 flatten_body(B,Dict,NB).
10767 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10768 flatten_heads(H,Dict,NH),
10769 flatten_body(B,Dict,NB).
10771 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10772 flatten_heads(H1,Dict,NH1),
10773 flatten_heads(H2,Dict,NH2).
10774 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10775 flatten_heads(H,Dict,NH).
10776 flatten_heads(H,Dict,NH) :-
10777 ( functor(H,C,N),
10778 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
10779 H =.. [_|AllArgs],
10780 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
10781 member(GroundArgs-Name,SFs),
10782 NH =.. [Name|OtherArgs]
10783 ;
10784 NH = H
10785 ).
10787 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
10788 conj2list(Guard,Guards),
10789 maplist(flatten_goal(Dict),Guards,NGuards),
10790 list2conj(NGuards,NGuard),
10791 conj2list(Body,Goals),
10792 maplist(flatten_goal(Dict),Goals,NGoals),
10793 list2conj(NGoals,NBody).
10794 flatten_body(Body,Dict,NBody) :-
10795 conj2list(Body,Goals),
10796 maplist(flatten_goal(Dict),Goals,NGoals),
10797 list2conj(NGoals,NBody).
10799 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
10800 flatten_goal(Dict,Goal,NGoal) :-
10801 ( is_specializable_goal(Goal,Dict,ArgPositions)
10802 ->
10803 specialize_goal(Goal,ArgPositions,NGoal)
10804 ; Goal = Mod : TheGoal,
10805 get_target_module(Module),
10806 Mod == Module,
10807 nonvar(TheGoal),
10808 is_specializable_goal(TheGoal,Dict,ArgPositions)
10809 ->
10810 specialize_goal(TheGoal,ArgPositions,NTheGoal),
10811 NGoal = Mod : NTheGoal
10812 ; partial_eval(Goal,NGoal)
10813 ->
10814 true
10815 ;
10816 NGoal = Goal
10817 ).
10819 %-------------------------------------------------------------------------------%
10820 % Specialize body/guard goal
10821 %-------------------------------------------------------------------------------%
10822 is_specializable_goal(Goal,Dict,ArgPositions) :-
10823 functor(Goal,C,N),
10824 memberchk(C/N-ArgPositions-_-_,Dict),
10825 args(ArgPositions,Goal,Args),
10826 ground(Args).
10828 specialize_goal(Goal,ArgPositions,NGoal) :-
10829 functor(Goal,C,N),
10830 Goal =.. [_|Args],
10831 split_args(ArgPositions,Args,GroundTerms,Others),
10832 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
10833 NGoal =.. [Functor|Others].
10835 %-------------------------------------------------------------------------------%
10836 % Partially evaluate predicates
10837 %-------------------------------------------------------------------------------%
10839 % append([],Y,Z) >--> Y = Z
10840 % append(X,[],Z) >--> X = Z
10841 partial_eval(append(L1,L2,L3),NGoal) :-
10842 ( L1 == [] ->
10843 NGoal = (L3 = L2)
10844 ; L2 == [] ->
10845 NGoal = (L3 = L1)
10847 ).
10848 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
10849 % where flatten(L1,L1')
10850 partial_eval(flatten_path(L1,L2),NGoal) :-
10851 nonvar(L1),
10852 flatten(L1,FlatterL1),
10853 FlatterL1 \== L1 ->
10854 NGoal = flatten_path(FlatterL1,L2).
10857 % }}}
10859 % }}}
10860 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10861 dump_code(Clauses) :-
10862 ( chr_pp_flag(dump,on) ->
10863 maplist(portray_clause,Clauses)
10864 ;
10865 true
10866 ).
10868 chr_banner :-
10869 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',[]).