| blob | 3254b28ee31b01f9ad89ea9aa9b99557a79f1398 |
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 ( Type = chr_constants(Key) -> get_chr_constants(Key,Constants)
501 ; Type = chr_enum(Constants) -> true
502 )
503 ->
504 Completeness = complete
505 ;
506 Constants = Constants0,
507 Completeness = incomplete
508 ),
509 delete(STs,multi_hash([Index]),STs0),
510 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
512 get_constraint_arg_type(C,Pos,Type) :-
513 get_constraint_type(C,Types),
514 nth1(Pos,Types,Type0),
515 unalias_type(Type0,Type).
517 validate_store_type_assumption(C) \ actual_store_types(C,STs)
518 <=>
519 % chr_pp_flag(experiment,on),
520 memberchk(multi_hash([[Index]]),STs),
521 get_constraint_type(C,Types),
522 nth1(Index,Types,Type),
523 enumerated_atomic_type(Type,Atoms)
524 |
525 delete(STs,multi_hash([[Index]]),STs0),
526 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
527 validate_store_type_assumption(C) \ actual_store_types(C,STs)
528 <=>
529 memberchk(multi_hash([[Index]]),STs),
530 get_constraint_arg_type(C,Index,Type),
531 ( Type = chr_enum(Constants) -> true
532 ; Type = chr_constants(Key) -> get_chr_constants(Key,Constants)
533 )
534 |
535 delete(STs,multi_hash([[Index]]),STs0),
536 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
537 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
538 <=>
539 ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) ->
540 Stores = [global_ground|STs]
541 ;
542 Stores = STs
543 ),
544 store_type(C,multi_store(Stores)).
545 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
546 <=>
547 store_type(C,multi_store(STs)).
548 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
549 <=>
550 chr_pp_flag(debugable,on)
551 |
552 store_type(C,default).
553 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
554 <=> store_type(C,global_ground).
555 validate_store_type_assumption(C)
556 <=> true.
558 partial_store(ground_constants(_,_,incomplete)).
559 partial_store(atomic_constants(_,_,incomplete)).
561 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
562 passive(R,ID) \ passive(R,ID) <=> true.
564 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
565 is_passive(_,_) <=> fail.
567 passive(RuleNb,_) \ any_passive_head(RuleNb)
568 <=> true.
569 any_passive_head(_)
570 <=> fail.
571 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
573 max_occurrence(C,N) \ max_occurrence(C,M)
574 <=> N >= M | true.
576 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
577 NO is MO + 1,
578 occurrence(C,NO,RuleNb,ID,Type),
579 max_occurrence(C,NO).
580 new_occurrence(C,RuleNb,ID,_) <=>
581 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
583 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
584 <=> Q = MON.
585 get_max_occurrence(C,Q)
586 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
588 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
589 <=> Rule = QRule, ID = QID.
590 get_occurrence(C,O,_,_)
591 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
593 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
594 <=> QC = C, QON = ON.
595 get_occurrence_from_id(C,O,_,_)
596 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
598 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
599 % Late allocation
601 late_allocation_analysis(Cs) :-
602 ( chr_pp_flag(late_allocation,on) ->
603 maplist(late_allocation, Cs)
604 ;
605 true
606 ).
608 late_allocation(C) :- late_allocation(C,0).
609 late_allocation(C,O) :- allocation_occurrence(C,O), !.
610 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
612 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
614 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
616 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
617 \+ is_passive(RuleNb,Id),
618 Type == propagation,
619 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
620 true
621 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
622 is_observed(C,O)
623 ; is_least_occurrence(RuleNb) -> % propagation rule
624 is_observed(C,O)
625 ;
626 true
627 ).
629 stored_in_guard_before_next_kept_occurrence(C,O) :-
630 chr_pp_flag(store_in_guards, on),
631 NO is O + 1,
632 stored_in_guard_lookahead(C,NO).
634 :- chr_constraint stored_in_guard_lookahead/2.
635 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
637 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
638 NO is O + 1, stored_in_guard_lookahead(C,NO).
639 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
640 Type == simplification,
641 ( is_stored_in_guard(C,RuleNb) ->
642 true
643 ;
644 NO is O + 1, stored_in_guard_lookahead(C,NO)
645 ).
646 stored_in_guard_lookahead(_,_) <=> fail.
649 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
650 \ least_occurrence(RuleNb,[ID|IDs])
651 <=> AO >= O, \+ may_trigger(C) |
652 least_occurrence(RuleNb,IDs).
653 rule(RuleNb,Rule), passive(RuleNb,ID)
654 \ least_occurrence(RuleNb,[ID|IDs])
655 <=> least_occurrence(RuleNb,IDs).
657 rule(RuleNb,Rule)
658 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
659 least_occurrence(RuleNb,IDs).
661 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
662 <=> true.
663 is_least_occurrence(_)
664 <=> fail.
666 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
667 <=> Q = O.
668 get_allocation_occurrence(_,Q)
669 <=> chr_pp_flag(late_allocation,off), Q=0.
670 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
672 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
673 <=> Q = Rule.
674 get_rule(_,_)
675 <=> fail.
677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
679 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
680 %
681 % Default store constraint index assignment.
683 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
684 :- chr_option(mode,constraint_index(+,+)).
685 :- chr_option(type_declaration,constraint_index(constraint,int)).
687 :- chr_constraint get_constraint_index/2.
688 :- chr_option(mode,get_constraint_index(+,-)).
689 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
691 :- chr_constraint get_indexed_constraint/2.
692 :- chr_option(mode,get_indexed_constraint(+,-)).
693 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
695 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
696 :- chr_option(mode,max_constraint_index(+)).
697 :- chr_option(type_declaration,max_constraint_index(int)).
699 :- chr_constraint get_max_constraint_index/1.
700 :- chr_option(mode,get_max_constraint_index(-)).
701 :- chr_option(type_declaration,get_max_constraint_index(int)).
703 constraint_index(C,Index) \ get_constraint_index(C,Query)
704 <=> Query = Index.
705 get_constraint_index(C,Query)
706 <=> fail.
708 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
709 <=> Q = C.
710 get_indexed_constraint(Index,Q)
711 <=> fail.
713 max_constraint_index(Index) \ get_max_constraint_index(Query)
714 <=> Query = Index.
715 get_max_constraint_index(Query)
716 <=> Query = 0.
718 set_constraint_indices(Constraints) :-
719 set_constraint_indices(Constraints,1).
720 set_constraint_indices([],M) :-
721 N is M - 1,
722 max_constraint_index(N).
723 set_constraint_indices([C|Cs],N) :-
724 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
725 ; get_store_type(C,var_assoc_store(_,_))) ->
726 constraint_index(C,N),
727 M is N + 1,
728 set_constraint_indices(Cs,M)
729 ;
730 set_constraint_indices(Cs,N)
731 ).
733 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
734 % Identifier Indexes
736 :- chr_constraint identifier_size/1.
737 :- chr_option(mode,identifier_size(+)).
738 :- chr_option(type_declaration,identifier_size(natural)).
740 identifier_size(_) \ identifier_size(_)
741 <=>
742 true.
744 :- chr_constraint get_identifier_size/1.
745 :- chr_option(mode,get_identifier_size(-)).
746 :- chr_option(type_declaration,get_identifier_size(natural)).
748 identifier_size(Size) \ get_identifier_size(Q)
749 <=>
750 Q = Size.
752 get_identifier_size(Q)
753 <=>
754 Q = 1.
756 :- chr_constraint identifier_index/3.
757 :- chr_option(mode,identifier_index(+,+,+)).
758 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
760 identifier_index(C,I,_) \ identifier_index(C,I,_)
761 <=>
762 true.
764 :- chr_constraint get_identifier_index/3.
765 :- chr_option(mode,get_identifier_index(+,+,-)).
766 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
768 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
769 <=>
770 Q = II.
771 identifier_size(Size), get_identifier_index(C,I,Q)
772 <=>
773 NSize is Size + 1,
774 identifier_index(C,I,NSize),
775 identifier_size(NSize),
776 Q = NSize.
777 get_identifier_index(C,I,Q)
778 <=>
779 identifier_index(C,I,2),
780 identifier_size(2),
781 Q = 2.
783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
784 % Type Indexed Identifier Indexes
786 :- chr_constraint type_indexed_identifier_size/2.
787 :- chr_option(mode,type_indexed_identifier_size(+,+)).
788 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
790 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
791 <=>
792 true.
794 :- chr_constraint get_type_indexed_identifier_size/2.
795 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
796 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
798 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
799 <=>
800 Q = Size.
802 get_type_indexed_identifier_size(IndexType,Q)
803 <=>
804 Q = 1.
806 :- chr_constraint type_indexed_identifier_index/4.
807 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
808 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
810 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
811 <=>
812 true.
814 :- chr_constraint get_type_indexed_identifier_index/4.
815 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
816 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
818 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
819 <=>
820 Q = II.
821 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
822 <=>
823 NSize is Size + 1,
824 type_indexed_identifier_index(IndexType,C,I,NSize),
825 type_indexed_identifier_size(IndexType,NSize),
826 Q = NSize.
827 get_type_indexed_identifier_index(IndexType,C,I,Q)
828 <=>
829 type_indexed_identifier_index(IndexType,C,I,2),
830 type_indexed_identifier_size(IndexType,2),
831 Q = 2.
833 type_indexed_identifier_structure(IndexType,Structure) :-
834 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
835 get_type_indexed_identifier_size(IndexType,Arity),
836 functor(Structure,Functor,Arity).
837 type_indexed_identifier_name(IndexType,Prefix,Name) :-
838 ( atom(IndexType) ->
839 IndexTypeName = IndexType
840 ;
841 term_to_atom(IndexType,IndexTypeName)
842 ),
843 atom_concat_list([Prefix,'_',IndexTypeName],Name).
845 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
850 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
851 %%
852 %% Translation
854 chr_translate(Declarations,NewDeclarations) :-
855 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
857 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
858 chr_banner,
859 restart_after_flattening(Declarations0,Declarations),
860 init_chr_pp_flags,
861 chr_source_file(File),
862 /* sort out the interesting stuff from the input */
863 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
864 chr_compiler_options:sanity_check,
866 dump_code(Declarations),
868 check_declared_constraints(Constraints0),
869 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
870 add_constraints(Constraints),
871 add_rules(Rules1),
872 generate_never_stored_rules(Constraints,NewRules),
873 add_rules(NewRules),
874 append(Rules1,NewRules,Rules),
875 chr_analysis(Rules,Constraints,Declarations),
876 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
877 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
878 phase_end(validate_store_type_assumptions),
879 used_states_known,
880 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
881 insert_declarations(OtherClauses, Clauses0),
882 chr_module_declaration(CHRModuleDeclaration),
883 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
884 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
885 append([Clauses0,GeneratedClauses], NewDeclarations),
886 dump_code(NewDeclarations),
887 !. /* cut choicepoint of restart_after_flattening */
889 chr_analysis(Rules,Constraints,Declarations) :-
890 check_rules(Rules,Constraints),
891 time('type checking',chr_translate:static_type_check),
892 /* constants */
893 collect_constants(Rules,Constraints,Declarations),
894 add_occurrences(Rules),
895 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
896 time('set semantics',chr_translate:set_semantics_rules(Rules)),
897 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
898 time('guard simplification',chr_translate:guard_simplification),
899 time('late storage',chr_translate:storage_analysis(Constraints)),
900 time('observation',chr_translate:observation_analysis(Constraints)),
901 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
902 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
903 partial_wake_analysis,
904 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
905 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
906 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
907 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
909 store_management_preds(Constraints,Clauses) :-
910 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
911 generate_attr_unify_hook(AttrUnifyHookClauses),
912 generate_attach_increment(AttachIncrementClauses),
913 generate_extra_clauses(Constraints,ExtraClauses),
914 generate_insert_delete_constraints(Constraints,DeleteClauses),
915 generate_attach_code(Constraints,StoreClauses),
916 generate_counter_code(CounterClauses),
917 generate_dynamic_type_check_clauses(TypeCheckClauses),
918 append([AttachAConstraintClauses
919 ,AttachIncrementClauses
920 ,AttrUnifyHookClauses
921 ,ExtraClauses
922 ,DeleteClauses
923 ,StoreClauses
924 ,CounterClauses
925 ,TypeCheckClauses
926 ]
927 ,Clauses).
930 insert_declarations(Clauses0, Clauses) :-
931 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
932 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
934 auxiliary_module(chr_hashtable_store).
935 auxiliary_module(chr_integertable_store).
936 auxiliary_module(chr_assoc_store).
938 generate_counter_code(Clauses) :-
939 ( chr_pp_flag(store_counter,on) ->
940 Clauses = [
941 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
942 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
943 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
944 (:- '$counter_init'('$insert_counter')),
945 (:- '$counter_init'('$delete_counter')),
946 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
947 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
948 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
949 ]
950 ;
951 Clauses = []
952 ).
954 % for systems with multifile declaration
955 chr_module_declaration(CHRModuleDeclaration) :-
956 get_target_module(Mod),
957 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
958 CHRModuleDeclaration = [
959 (:- multifile chr:'$chr_module'/1),
960 chr:'$chr_module'(Mod)
961 ]
962 ;
963 CHRModuleDeclaration = []
964 ).
967 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
968 %%
969 %% Partitioning of clauses into constraint declarations, chr rules and other
970 %% clauses
972 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
973 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
974 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
975 partition_clauses([],[],[],[]).
976 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
977 ( parse_rule(Clause,Rule) ->
978 ConstraintDeclarations = RestConstraintDeclarations,
979 Rules = [Rule|RestRules],
980 OtherClauses = RestOtherClauses
981 ; is_declaration(Clause,ConstraintDeclaration) ->
982 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
983 Rules = RestRules,
984 OtherClauses = RestOtherClauses
985 ; is_module_declaration(Clause,Mod) ->
986 target_module(Mod),
987 ConstraintDeclarations = RestConstraintDeclarations,
988 Rules = RestRules,
989 OtherClauses = [Clause|RestOtherClauses]
990 ; is_type_definition(Clause) ->
991 ConstraintDeclarations = RestConstraintDeclarations,
992 Rules = RestRules,
993 OtherClauses = RestOtherClauses
994 ; is_chr_declaration(Clause) ->
995 ConstraintDeclarations = RestConstraintDeclarations,
996 Rules = RestRules,
997 OtherClauses = RestOtherClauses
998 ; Clause = (handler _) ->
999 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
1000 ConstraintDeclarations = RestConstraintDeclarations,
1001 Rules = RestRules,
1002 OtherClauses = RestOtherClauses
1003 ; Clause = (rules _) ->
1004 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1005 ConstraintDeclarations = RestConstraintDeclarations,
1006 Rules = RestRules,
1007 OtherClauses = RestOtherClauses
1008 ; Clause = option(OptionName,OptionValue) ->
1009 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1010 handle_option(OptionName,OptionValue),
1011 ConstraintDeclarations = RestConstraintDeclarations,
1012 Rules = RestRules,
1013 OtherClauses = RestOtherClauses
1014 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1015 handle_option(OptionName,OptionValue),
1016 ConstraintDeclarations = RestConstraintDeclarations,
1017 Rules = RestRules,
1018 OtherClauses = RestOtherClauses
1019 ; Clause = ('$chr_compiled_with_version'(_)) ->
1020 ConstraintDeclarations = RestConstraintDeclarations,
1021 Rules = RestRules,
1022 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1023 ; ConstraintDeclarations = RestConstraintDeclarations,
1024 Rules = RestRules,
1025 OtherClauses = [Clause|RestOtherClauses]
1026 ),
1027 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1029 '$chr_compiled_with_version'(2).
1031 is_declaration(D, Constraints) :- %% constraint declaration
1032 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1033 conj2list(Cs,Constraints0)
1034 ;
1035 ( D = (:- Decl) ->
1036 Decl =.. [constraints,Cs]
1037 ;
1038 D =.. [constraints,Cs]
1039 ),
1040 conj2list(Cs,Constraints0),
1041 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1042 ),
1043 extract_type_mode(Constraints0,Constraints).
1045 extract_type_mode([],[]).
1046 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1047 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1048 ( C0 = C # Annotation ->
1049 functor(C,F,A),
1050 extract_annotation(Annotation,F/A)
1051 ;
1052 C0 = C,
1053 functor(C,F,A)
1054 ),
1055 ConstraintSymbol = F/A,
1056 C =.. [_|Args],
1057 extract_types_and_modes(Args,ArgTypes,ArgModes),
1058 assert_constraint_type(ConstraintSymbol,ArgTypes),
1059 constraint_mode(ConstraintSymbol,ArgModes),
1060 extract_type_mode(R,R2).
1062 extract_annotation(stored,Symbol) :-
1063 stored_assertion(Symbol).
1064 extract_annotation(default(Goal),Symbol) :-
1065 never_stored_default(Symbol,Goal).
1067 extract_types_and_modes([],[],[]).
1068 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1069 extract_type_and_mode(X,T,M),
1070 extract_types_and_modes(R,R2,R3).
1072 extract_type_and_mode(+(T),T,(+)) :- !.
1073 extract_type_and_mode(?(T),T,(?)) :- !.
1074 extract_type_and_mode(-(T),T,(-)) :- !.
1075 extract_type_and_mode((+),any,(+)) :- !.
1076 extract_type_and_mode((?),any,(?)) :- !.
1077 extract_type_and_mode((-),any,(-)) :- !.
1078 extract_type_and_mode(Illegal,_,_) :-
1079 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1081 is_chr_declaration(Declaration) :-
1082 Declaration = (:- chr_declaration Decl),
1083 ( Decl = (Pattern ---> Information) ->
1084 background_info(Pattern,Information)
1085 ; Decl = Information ->
1086 background_info([Information])
1087 ).
1088 is_type_definition(Declaration) :-
1089 is_type_definition(Declaration,Result),
1090 assert_type_definition(Result).
1092 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1093 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1095 is_type_definition(Declaration,Result) :-
1096 ( Declaration = (:- TDef) ->
1097 true
1098 ;
1099 Declaration = TDef
1100 ),
1101 TDef =.. [chr_type,TypeDef],
1102 ( TypeDef = (Name ---> Def) ->
1103 tdisj2list(Def,DefList),
1104 Result = typedef(Name,DefList)
1105 ; TypeDef = (Alias == Name) ->
1106 Result = alias(Alias,Name)
1107 ;
1108 Result = typedef(TypeDef,[]),
1109 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1110 ).
1112 %% tdisj2list(+Goal,-ListOfGoals) is det.
1113 %
1114 % no removal of fails, e.g. :- type bool ---> true ; fail.
1115 tdisj2list(Conj,L) :-
1116 tdisj2list(Conj,L,[]).
1118 tdisj2list(Conj,L,T) :-
1119 Conj = (G1;G2), !,
1120 tdisj2list(G1,L,T1),
1121 tdisj2list(G2,T1,T).
1122 tdisj2list(G,[G | T],T).
1125 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1126 %% parse_rule(+term,-pragma_rule) is semidet.
1127 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1128 parse_rule(RI,R) :- %% name @ rule
1129 RI = (Name @ RI2), !,
1130 rule(RI2,yes(Name),R).
1131 parse_rule(RI,R) :-
1132 rule(RI,no,R).
1134 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1135 %% parse_rule(+term,-pragma_rule) is semidet.
1136 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1137 rule(RI,Name,R) :-
1138 RI = (RI2 pragma P), !, %% pragmas
1139 ( var(P) ->
1140 Ps = [_] % intercept variable
1141 ;
1142 conj2list(P,Ps)
1143 ),
1144 inc_rule_count(RuleCount),
1145 R = pragma(R1,IDs,Ps,Name,RuleCount),
1146 is_rule(RI2,R1,IDs,R).
1147 rule(RI,Name,R) :-
1148 inc_rule_count(RuleCount),
1149 R = pragma(R1,IDs,[],Name,RuleCount),
1150 is_rule(RI,R1,IDs,R).
1152 is_rule(RI,R,IDs,RC) :- %% propagation rule
1153 RI = (H ==> B), !,
1154 conj2list(H,Head2i),
1155 get_ids(Head2i,IDs2,Head2,RC),
1156 IDs = ids([],IDs2),
1157 ( B = (G | RB) ->
1158 R = rule([],Head2,G,RB)
1159 ;
1160 R = rule([],Head2,true,B)
1161 ).
1162 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1163 RI = (H <=> B), !,
1164 ( B = (G | RB) ->
1165 Guard = G,
1166 Body = RB
1167 ; Guard = true,
1168 Body = B
1169 ),
1170 ( H = (H1 \ H2) ->
1171 conj2list(H1,Head2i),
1172 conj2list(H2,Head1i),
1173 get_ids(Head2i,IDs2,Head2,0,N,RC),
1174 get_ids(Head1i,IDs1,Head1,N,_,RC),
1175 IDs = ids(IDs1,IDs2)
1176 ; conj2list(H,Head1i),
1177 Head2 = [],
1178 get_ids(Head1i,IDs1,Head1,RC),
1179 IDs = ids(IDs1,[])
1180 ),
1181 R = rule(Head1,Head2,Guard,Body).
1183 get_ids(Cs,IDs,NCs,RC) :-
1184 get_ids(Cs,IDs,NCs,0,_,RC).
1186 get_ids([],[],[],N,N,_).
1187 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1188 ( C = (NC # N1) ->
1189 ( var(N1) ->
1190 N1 = N
1191 ;
1192 check_direct_pragma(N1,N,RC)
1193 )
1194 ;
1195 NC = C
1196 ),
1197 M is N + 1,
1198 get_ids(Cs,IDs,NCs, M,NN,RC).
1200 check_direct_pragma(passive,Id,PragmaRule) :- !,
1201 PragmaRule = pragma(_,_,_,_,RuleNb),
1202 passive(RuleNb,Id).
1203 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1204 ( direct_pragma(FullPragma),
1205 atom_concat(Abbrev,Remainder,FullPragma) ->
1206 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1207 ;
1208 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1209 ).
1211 direct_pragma(passive).
1213 is_module_declaration((:- module(Mod)),Mod).
1214 is_module_declaration((:- module(Mod,_)),Mod).
1216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1219 % Add constraints
1220 add_constraints([]).
1221 add_constraints([C|Cs]) :-
1222 max_occurrence(C,0),
1223 C = _/A,
1224 length(Mode,A),
1225 set_elems(Mode,?),
1226 constraint_mode(C,Mode),
1227 add_constraints(Cs).
1229 % Add rules
1230 add_rules([]).
1231 add_rules([Rule|Rules]) :-
1232 Rule = pragma(_,_,_,_,RuleNb),
1233 rule(RuleNb,Rule),
1234 add_rules(Rules).
1236 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1239 %% Some input verification:
1241 check_declared_constraints(Constraints) :-
1242 tree_set_empty(Acc),
1243 check_declared_constraints(Constraints,Acc).
1245 check_declared_constraints([],_).
1246 check_declared_constraints([C|Cs],Acc) :-
1247 ( tree_set_memberchk(C,Acc) ->
1248 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1249 ;
1250 true
1251 ),
1252 tree_set_add(Acc,C,NAcc),
1253 check_declared_constraints(Cs,NAcc).
1255 %% - all constraints in heads are declared constraints
1256 %% - all passive pragmas refer to actual head constraints
1258 check_rules([],_).
1259 check_rules([PragmaRule|Rest],Decls) :-
1260 check_rule(PragmaRule,Decls),
1261 check_rules(Rest,Decls).
1263 check_rule(PragmaRule,Decls) :-
1264 check_rule_indexing(PragmaRule),
1265 check_trivial_propagation_rule(PragmaRule),
1266 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1267 Rule = rule(H1,H2,_,_),
1268 append(H1,H2,HeadConstraints),
1269 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1270 check_pragmas(Pragmas,PragmaRule).
1272 % Make all heads passive in trivial propagation rule
1273 % ... ==> ... | true.
1274 check_trivial_propagation_rule(PragmaRule) :-
1275 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1276 ( Rule = rule([],_,_,true) ->
1277 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1278 set_all_passive(RuleNb)
1279 ;
1280 true
1281 ).
1283 check_head_constraints([],_,_).
1284 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1285 functor(Constr,F,A),
1286 ( memberchk(F/A,Decls) ->
1287 check_head_constraints(Rest,Decls,PragmaRule)
1288 ;
1289 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1290 ).
1292 check_pragmas([],_).
1293 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1294 check_pragma(Pragma,PragmaRule),
1295 check_pragmas(Pragmas,PragmaRule).
1297 check_pragma(Pragma,PragmaRule) :-
1298 var(Pragma), !,
1299 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1300 check_pragma(passive(ID), PragmaRule) :-
1301 !,
1302 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1303 ( memberchk_eq(ID,IDs1) ->
1304 true
1305 ; memberchk_eq(ID,IDs2) ->
1306 true
1307 ;
1308 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1309 ),
1310 passive(RuleNb,ID).
1312 check_pragma(mpassive(IDs), PragmaRule) :-
1313 !,
1314 PragmaRule = pragma(_,_,_,_,RuleNb),
1315 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1316 maplist(passive(RuleNb),IDs).
1318 check_pragma(Pragma, PragmaRule) :-
1319 Pragma = already_in_heads,
1320 !,
1321 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1323 check_pragma(Pragma, PragmaRule) :-
1324 Pragma = already_in_head(_),
1325 !,
1326 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1328 check_pragma(Pragma, PragmaRule) :-
1329 Pragma = no_history,
1330 !,
1331 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1332 PragmaRule = pragma(_,_,_,_,N),
1333 no_history(N).
1335 check_pragma(Pragma, PragmaRule) :-
1336 Pragma = history(HistoryName,IDs),
1337 !,
1338 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1339 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1340 ( IDs1 \== [] ->
1341 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1342 ; \+ atom(HistoryName) ->
1343 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1344 ; \+ is_set(IDs) ->
1345 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1346 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1347 history(RuleNb,HistoryName,IDs)
1348 ;
1349 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1350 ).
1351 check_pragma(Pragma,PragmaRule) :-
1352 Pragma = line_number(LineNumber),
1353 !,
1354 PragmaRule = pragma(_,_,_,_,RuleNb),
1355 line_number(RuleNb,LineNumber).
1357 check_history_pragma_ids([], _, _).
1358 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1359 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1360 check_history_pragma_ids(IDs,IDs1,IDs2).
1362 check_pragma(Pragma,PragmaRule) :-
1363 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1365 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1366 %% no_history(+RuleNb) is det.
1367 :- chr_constraint no_history/1.
1368 :- chr_option(mode,no_history(+)).
1369 :- chr_option(type_declaration,no_history(int)).
1371 %% has_no_history(+RuleNb) is semidet.
1372 :- chr_constraint has_no_history/1.
1373 :- chr_option(mode,has_no_history(+)).
1374 :- chr_option(type_declaration,has_no_history(int)).
1376 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1377 has_no_history(_) <=> fail.
1379 :- chr_constraint history/3.
1380 :- chr_option(mode,history(+,+,+)).
1381 :- chr_option(type_declaration,history(any,any,list)).
1383 :- chr_constraint named_history/3.
1385 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1386 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1388 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1389 length(IDs1,L1), length(IDs2,L2),
1390 ( L1 \== L2 ->
1391 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1392 ;
1393 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1394 ).
1396 test_named_history_id_pairs(_, [], _, []).
1397 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1398 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1399 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1401 :- chr_constraint test_named_history_id_pair/4.
1402 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1404 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1405 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1406 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1407 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1409 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1410 named_history(_,_,_) <=> fail.
1412 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1415 format_rule(PragmaRule) :-
1416 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1417 ( MaybeName = yes(Name) ->
1418 write('rule '), write(Name)
1419 ;
1420 write('rule number '), write(RuleNumber)
1421 ),
1422 get_line_number(RuleNumber,LineNumber),
1423 write(' (line '),
1424 write(LineNumber),
1425 write(')').
1427 check_rule_indexing(PragmaRule) :-
1428 PragmaRule = pragma(Rule,_,_,_,_),
1429 Rule = rule(H1,H2,G,_),
1430 term_variables(H1-H2,HeadVars),
1431 remove_anti_monotonic_guards(G,HeadVars,NG),
1432 check_indexing(H1,NG-H2),
1433 check_indexing(H2,NG-H1),
1434 % EXPERIMENT
1435 ( chr_pp_flag(term_indexing,on) ->
1436 term_variables(NG,GuardVariables),
1437 append(H1,H2,Heads),
1438 check_specs_indexing(Heads,GuardVariables,Specs)
1439 ;
1440 true
1441 ).
1443 :- chr_constraint indexing_spec/2.
1444 :- chr_option(mode,indexing_spec(+,+)).
1446 :- chr_constraint get_indexing_spec/2.
1447 :- chr_option(mode,get_indexing_spec(+,-)).
1450 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1451 get_indexing_spec(_,Spec) <=> Spec = [].
1453 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1454 <=>
1455 append(Specs1,Specs2,Specs),
1456 indexing_spec(FA,Specs).
1458 remove_anti_monotonic_guards(G,Vars,NG) :-
1459 conj2list(G,GL),
1460 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1461 list2conj(NGL,NG).
1463 remove_anti_monotonic_guard_list([],_,[]).
1464 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1465 ( G = var(X), memberchk_eq(X,Vars) ->
1466 NGs = RGs
1467 % TODO: this is not correct
1468 % ; G = functor(Term,Functor,Arity), % isotonic
1469 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1470 % NGs = RGs
1471 ;
1472 NGs = [G|RGs]
1473 ),
1474 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1476 check_indexing([],_).
1477 check_indexing([Head|Heads],Other) :-
1478 functor(Head,F,A),
1479 Head =.. [_|Args],
1480 term_variables(Heads-Other,OtherVars),
1481 check_indexing(Args,1,F/A,OtherVars),
1482 check_indexing(Heads,[Head|Other]).
1484 check_indexing([],_,_,_).
1485 check_indexing([Arg|Args],I,FA,OtherVars) :-
1486 ( is_indexed_argument(FA,I) ->
1487 true
1488 ; nonvar(Arg) ->
1489 indexed_argument(FA,I)
1490 ; % var(Arg) ->
1491 term_variables(Args,ArgsVars),
1492 append(ArgsVars,OtherVars,RestVars),
1493 ( memberchk_eq(Arg,RestVars) ->
1494 indexed_argument(FA,I)
1495 ;
1496 true
1497 )
1498 ),
1499 J is I + 1,
1500 term_variables(Arg,NVars),
1501 append(NVars,OtherVars,NOtherVars),
1502 check_indexing(Args,J,FA,NOtherVars).
1504 check_specs_indexing([],_,[]).
1505 check_specs_indexing([Head|Heads],Variables,Specs) :-
1506 Specs = [Spec|RSpecs],
1507 term_variables(Heads,OtherVariables,Variables),
1508 check_spec_indexing(Head,OtherVariables,Spec),
1509 term_variables(Head,NVariables,Variables),
1510 check_specs_indexing(Heads,NVariables,RSpecs).
1512 check_spec_indexing(Head,OtherVariables,Spec) :-
1513 functor(Head,F,A),
1514 Spec = spec(F,A,ArgSpecs),
1515 Head =.. [_|Args],
1516 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1517 indexing_spec(F/A,[ArgSpecs]).
1519 check_args_spec_indexing([],_,_,[]).
1520 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1521 term_variables(Args,Variables,OtherVariables),
1522 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1523 ArgSpecs = [ArgSpec|RArgSpecs]
1524 ;
1525 ArgSpecs = RArgSpecs
1526 ),
1527 J is I + 1,
1528 term_variables(Arg,NOtherVariables,OtherVariables),
1529 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1531 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1532 ( var(Arg) ->
1533 memberchk_eq(Arg,Variables),
1534 ArgSpec = specinfo(I,any,[])
1535 ;
1536 functor(Arg,F,A),
1537 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1538 Arg =.. [_|Args],
1539 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1540 ).
1542 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1544 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1545 % Occurrences
1547 add_occurrences([]).
1548 add_occurrences([Rule|Rules]) :-
1549 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1550 add_occurrences(H1,IDs1,simplification,Nb),
1551 add_occurrences(H2,IDs2,propagation,Nb),
1552 add_occurrences(Rules).
1554 add_occurrences([],[],_,_).
1555 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1556 functor(H,F,A),
1557 FA = F/A,
1558 new_occurrence(FA,RuleNb,ID,Type),
1559 add_occurrences(Hs,IDs,Type,RuleNb).
1561 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1564 % Observation Analysis
1565 %
1566 % CLASSIFICATION
1567 %
1568 %
1569 %
1570 %
1571 %
1572 %
1574 :- chr_constraint observation_analysis/1.
1575 :- chr_option(mode, observation_analysis(+)).
1577 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1578 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1579 ( chr_pp_flag(store_in_guards, on) ->
1580 observation_analysis(RuleNb, Guard, guard, Cs)
1581 ;
1582 true
1583 ),
1584 observation_analysis(RuleNb, Body, body, Cs)
1586 pragma passive(Id).
1587 observation_analysis(_) <=> true.
1589 observation_analysis(RuleNb, Term, GB, Cs) :-
1590 ( all_spawned(RuleNb,GB) ->
1591 true
1592 ; var(Term) ->
1593 spawns_all(RuleNb,GB)
1594 ; Term = true ->
1595 true
1596 ; Term = fail ->
1597 true
1598 ; Term = '!' ->
1599 true
1600 ; Term = (T1,T2) ->
1601 observation_analysis(RuleNb,T1,GB,Cs),
1602 observation_analysis(RuleNb,T2,GB,Cs)
1603 ; Term = (T1;T2) ->
1604 observation_analysis(RuleNb,T1,GB,Cs),
1605 observation_analysis(RuleNb,T2,GB,Cs)
1606 ; Term = (T1->T2) ->
1607 observation_analysis(RuleNb,T1,GB,Cs),
1608 observation_analysis(RuleNb,T2,GB,Cs)
1609 ; Term = (\+ T) ->
1610 observation_analysis(RuleNb,T,GB,Cs)
1611 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1612 spawns(RuleNb,GB,F/A)
1613 ; Term = (_ = _) ->
1614 spawns_all_triggers(RuleNb,GB)
1615 ; Term = (_ is _) ->
1616 spawns_all_triggers(RuleNb,GB)
1617 ; builtin_binds_b(Term,Vars) ->
1618 ( Vars == [] ->
1619 true
1620 ;
1621 spawns_all_triggers(RuleNb,GB)
1622 )
1623 ;
1624 spawns_all(RuleNb,GB)
1625 ).
1627 :- chr_constraint spawns/3.
1628 :- chr_option(mode, spawns(+,+,+)).
1629 :- chr_type spawns_type ---> guard ; body.
1630 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1632 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1633 :- chr_option(mode, spawns_all(+,+)).
1634 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1635 :- chr_option(mode, spawns_all_triggers(+,+)).
1636 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1638 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1639 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1640 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1641 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1642 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1643 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1645 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1646 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1647 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1648 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1650 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1651 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1653 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1654 \
1655 spawns(RuleNb1,GB,C1)
1656 <=>
1657 \+ is_passive(RuleNb2,O)
1658 |
1659 spawns_all(RuleNb1,GB)
1660 pragma
1661 passive(Id).
1663 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1664 ==>
1665 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1666 \+ is_passive(RuleNb2,O), may_trigger(C1)
1667 |
1668 spawns_all_triggers_implies_spawns_all
1669 pragma
1670 passive(Id).
1672 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1673 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1674 spawns_all_triggers_implies_spawns_all \
1675 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1677 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1678 \
1679 spawns(RuleNb1,GB,C1)
1680 <=>
1681 may_trigger(C1),
1682 \+ is_passive(RuleNb2,O)
1683 |
1684 spawns_all_triggers(RuleNb1,GB)
1685 pragma
1686 passive(Id).
1688 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1689 spawns(RuleNb1,GB,C1)
1690 ==>
1691 \+ may_trigger(C1),
1692 \+ is_passive(RuleNb2,O)
1693 |
1694 spawns_all_triggers(RuleNb1,GB)
1695 pragma
1696 passive(Id).
1698 % a bit dangerous this rule: could start propagating too much too soon?
1699 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1700 spawns(RuleNb1,GB,C1)
1701 ==>
1702 RuleNb1 \== RuleNb2, C1 \== C2,
1703 \+ is_passive(RuleNb2,O)
1704 |
1705 spawns(RuleNb1,GB,C2)
1706 pragma
1707 passive(Id).
1709 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1710 spawns_all_triggers(RuleNb1,GB)
1711 ==>
1712 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1713 |
1714 spawns(RuleNb1,GB,C2)
1715 pragma
1716 passive(Id).
1719 :- chr_constraint all_spawned/2.
1720 :- chr_option(mode, all_spawned(+,+)).
1721 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1722 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1723 all_spawned(RuleNb,GB) <=> fail.
1726 % Overview of the supported queries:
1727 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1728 % only succeeds if the occurrence is observed by the
1729 % guard resp. body (depending on the last argument) of its rule
1730 % is_observed(+functor/artiy, +occurrence_number, -)
1731 % succeeds if the occurrence is observed by either the guard or
1732 % the body of its rule
1733 % NOTE: the last argument is NOT bound by this query
1734 %
1735 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1736 % succeeds if the given constraint is observed by the given
1737 % guard resp. body
1738 % do_is_observed(+functor/artiy,+rule_number)
1739 % succeeds if the given constraint is observed by the given
1740 % rule (either its guard or its body)
1743 is_observed(C,O) :-
1744 is_observed(C,O,_),
1745 ai_is_observed(C,O).
1747 is_stored_in_guard(C,RuleNb) :-
1748 chr_pp_flag(store_in_guards, on),
1749 do_is_observed(C,RuleNb,guard).
1751 :- chr_constraint is_observed/3.
1752 :- chr_option(mode, is_observed(+,+,+)).
1753 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1754 is_observed(_,_,_) <=> fail. % this will not happen in practice
1757 :- chr_constraint do_is_observed/3.
1758 :- chr_option(mode, do_is_observed(+,+,?)).
1759 :- chr_constraint do_is_observed/2.
1760 :- chr_option(mode, do_is_observed(+,+)).
1762 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1764 % (1) spawns_all
1765 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1766 % and some non-passive occurrence of some (possibly other) constraint
1767 % exists in a rule (could be same rule) with at least one occurrence of C
1769 spawns_all(RuleNb,GB),
1770 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1771 \
1772 do_is_observed(C,RuleNb,GB)
1773 <=>
1774 \+ is_passive(RuleNb2,O)
1775 |
1776 true.
1778 spawns_all(RuleNb,_),
1779 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1780 \
1781 do_is_observed(C,RuleNb)
1782 <=>
1783 \+ is_passive(RuleNb2,O)
1784 |
1785 true.
1787 % (2) spawns
1788 % a constraint C is observed if the GB of the rule it occurs in spawns a
1789 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1790 % as an occurrence of C
1792 spawns(RuleNb,GB,C2),
1793 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1794 \
1795 do_is_observed(C,RuleNb,GB)
1796 <=>
1797 \+ is_passive(RuleNb2,O)
1798 |
1799 true.
1801 spawns(RuleNb,_,C2),
1802 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1803 \
1804 do_is_observed(C,RuleNb)
1805 <=>
1806 \+ is_passive(RuleNb2,O)
1807 |
1808 true.
1810 % (3) spawns_all_triggers
1811 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1812 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1813 % exists in a rule (could be same rule) with at least one occurrence of C
1815 spawns_all_triggers(RuleNb,GB),
1816 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1817 \
1818 do_is_observed(C,RuleNb,GB)
1819 <=>
1820 \+ is_passive(RuleNb2,O), may_trigger(C2)
1821 |
1822 true.
1824 spawns_all_triggers(RuleNb,_),
1825 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1826 \
1827 do_is_observed(C,RuleNb)
1828 <=>
1829 \+ is_passive(RuleNb2,O), may_trigger(C2)
1830 |
1831 true.
1833 % (4) conservativeness
1834 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1835 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1838 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1840 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1842 %%
1843 %% Generated predicates
1844 %% attach_$CONSTRAINT
1845 %% attach_increment
1846 %% detach_$CONSTRAINT
1847 %% attr_unify_hook
1849 %% attach_$CONSTRAINT
1850 generate_attach_detach_a_constraint_all([],[]).
1851 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1852 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1853 generate_attach_a_constraint(Constraint,Clauses1),
1854 generate_detach_a_constraint(Constraint,Clauses2)
1855 ;
1856 Clauses1 = [],
1857 Clauses2 = []
1858 ),
1859 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1860 append([Clauses1,Clauses2,Clauses3],Clauses).
1862 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1863 generate_attach_a_constraint_nil(Constraint,Clause1),
1864 generate_attach_a_constraint_cons(Constraint,Clause2).
1866 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1867 make_name('attach_',FA,Name),
1868 Atom =.. [Name,Vars,Susp].
1870 generate_attach_a_constraint_nil(FA,Clause) :-
1871 Clause = (Head :- true),
1872 attach_constraint_atom(FA,[],_,Head).
1874 generate_attach_a_constraint_cons(FA,Clause) :-
1875 Clause = (Head :- Body),
1876 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1877 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1878 Body = ( AttachBody, Subscribe, RecursiveCall ),
1879 get_max_constraint_index(N),
1880 ( N == 1 ->
1881 generate_attach_body_1(FA,Var,Susp,AttachBody)
1882 ;
1883 generate_attach_body_n(FA,Var,Susp,AttachBody)
1884 ),
1885 % SWI-Prolog specific code
1886 chr_pp_flag(solver_events,NMod),
1887 ( NMod \== none ->
1888 Args = [[Var|_],Susp],
1889 get_target_module(Mod),
1890 use_auxiliary_predicate(run_suspensions),
1891 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1892 ;
1893 Subscribe = true
1894 ).
1896 generate_attach_body_1(FA,Var,Susp,Body) :-
1897 get_target_module(Mod),
1898 Body =
1899 ( get_attr(Var, Mod, Susps) ->
1900 put_attr(Var, Mod, [Susp|Susps])
1901 ;
1902 put_attr(Var, Mod, [Susp])
1903 ).
1905 generate_attach_body_n(F/A,Var,Susp,Body) :-
1906 get_constraint_index(F/A,Position),
1907 get_max_constraint_index(Total),
1908 get_target_module(Mod),
1909 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1910 singleton_attr(Total,Susp,Position,NewAttr3),
1911 Body =
1912 ( get_attr(Var,Mod,TAttr) ->
1913 AddGoal,
1914 put_attr(Var,Mod,NTAttr)
1915 ;
1916 put_attr(Var,Mod,NewAttr3)
1917 ), !.
1919 %% detach_$CONSTRAINT
1920 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1921 generate_detach_a_constraint_nil(Constraint,Clause1),
1922 generate_detach_a_constraint_cons(Constraint,Clause2).
1924 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1925 make_name('detach_',FA,Name),
1926 Atom =.. [Name,Vars,Susp].
1928 generate_detach_a_constraint_nil(FA,Clause) :-
1929 Clause = ( Head :- true),
1930 detach_constraint_atom(FA,[],_,Head).
1932 generate_detach_a_constraint_cons(FA,Clause) :-
1933 Clause = (Head :- Body),
1934 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1935 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1936 Body = ( DetachBody, RecursiveCall ),
1937 get_max_constraint_index(N),
1938 ( N == 1 ->
1939 generate_detach_body_1(FA,Var,Susp,DetachBody)
1940 ;
1941 generate_detach_body_n(FA,Var,Susp,DetachBody)
1942 ).
1944 generate_detach_body_1(FA,Var,Susp,Body) :-
1945 get_target_module(Mod),
1946 Body =
1947 ( get_attr(Var,Mod,Susps) ->
1948 'chr sbag_del_element'(Susps,Susp,NewSusps),
1949 ( NewSusps == [] ->
1950 del_attr(Var,Mod)
1951 ;
1952 put_attr(Var,Mod,NewSusps)
1953 )
1954 ;
1955 true
1956 ).
1958 generate_detach_body_n(F/A,Var,Susp,Body) :-
1959 get_constraint_index(F/A,Position),
1960 get_max_constraint_index(Total),
1961 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1962 get_target_module(Mod),
1963 Body =
1964 ( get_attr(Var,Mod,TAttr) ->
1965 RemGoal
1966 ;
1967 true
1968 ), !.
1970 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1971 %-------------------------------------------------------------------------------
1972 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1973 :- chr_constraint generate_indexed_variables_body/4.
1974 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1975 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1976 %-------------------------------------------------------------------------------
1977 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1978 get_indexing_spec(F/A,Specs),
1979 ( chr_pp_flag(term_indexing,on) ->
1980 spectermvars(Specs,Args,F,A,Body,Vars)
1981 ;
1982 get_constraint_type_det(F/A,ArgTypes),
1983 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1984 ( MaybeBody == empty ->
1985 Body = true,
1986 Vars = []
1987 ; N == 0 ->
1988 ( Args = [Term] ->
1989 true
1990 ;
1991 Term =.. [term|Args]
1992 ),
1993 Body = term_variables(Term,Vars)
1994 ;
1995 MaybeBody = Body
1996 )
1997 ).
1998 generate_indexed_variables_body(FA,_,_,_) <=>
1999 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
2000 %===============================================================================
2002 create_indexed_variables_body([],[],[],_,_,_,empty,0).
2003 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
2004 J is I + 1,
2005 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
2006 ( Mode == (?),
2007 is_indexed_argument(FA,I) ->
2008 ( atomic_type(Type) ->
2009 Body =
2010 (
2011 ( var(V) ->
2012 Vars = [V|Tail]
2013 ;
2014 Vars = Tail
2015 ),
2016 Continuation
2017 ),
2018 ( RBody == empty ->
2019 Continuation = true, Tail = []
2020 ;
2021 Continuation = RBody
2022 )
2023 ;
2024 ( RBody == empty ->
2025 Body = term_variables(V,Vars)
2026 ;
2027 Body = (term_variables(V,Vars,Tail),RBody)
2028 )
2029 ),
2030 N = M
2031 ; Mode == (-), is_indexed_argument(FA,I) ->
2032 ( RBody == empty ->
2033 Body = (Vars = [V])
2034 ;
2035 Body = (Vars = [V|Tail],RBody)
2036 ),
2037 N is M + 1
2038 ;
2039 Vars = Tail,
2040 Body = RBody,
2041 N is M + 1
2042 ).
2043 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2044 % EXPERIMENTAL
2045 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2046 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2048 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2049 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2050 Goal = (ArgGoal,RGoal),
2051 argspecs(Specs,I,TempArgSpecs,RSpecs),
2052 merge_argspecs(TempArgSpecs,ArgSpecs),
2053 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2054 J is I + 1,
2055 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2057 argspecs([],_,[],[]).
2058 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2059 argspecs(Rest,I,ArgSpecs,RestSpecs).
2060 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2061 ( I == J ->
2062 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2063 ( Specs = [] ->
2064 RRestSpecs = RestSpecs
2065 ;
2066 RestSpecs = [Specs|RRestSpecs]
2067 )
2068 ;
2069 ArgSpecs = RArgSpecs,
2070 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2071 ),
2072 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2074 merge_argspecs(In,Out) :-
2075 sort(In,Sorted),
2076 merge_argspecs_(Sorted,Out).
2078 merge_argspecs_([],[]).
2079 merge_argspecs_([X],R) :- !, R = [X].
2080 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2081 ( (F1 == any ; F2 == any) ->
2082 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2083 ; F1 == F2 ->
2084 append(A1,A2,A),
2085 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2086 ;
2087 R = [specinfo(I,F1,A1)|RR],
2088 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2089 ).
2091 arggoal(List,Arg,Goal,L,T) :-
2092 ( List == [] ->
2093 L = T,
2094 Goal = true
2095 ; List = [specinfo(_,any,_)] ->
2096 Goal = term_variables(Arg,L,T)
2097 ;
2098 Goal =
2099 ( var(Arg) ->
2100 L = [Arg|T]
2101 ;
2102 Cases
2103 ),
2104 arggoal_cases(List,Arg,L,T,Cases)
2105 ).
2107 arggoal_cases([],_,L,T,L=T).
2108 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2109 ( ArgSpecs == [] ->
2110 Cases = RCases
2111 ; ArgSpecs == [[]] ->
2112 Cases = RCases
2113 ; FA = F/A ->
2114 Cases = (Case ; RCases),
2115 functor(Term,F,A),
2116 Term =.. [_|Args],
2117 Case = (Arg = Term -> ArgsGoal),
2118 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2119 ),
2120 arggoal_cases(Rest,Arg,L,T,RCases).
2121 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2123 generate_extra_clauses(Constraints,List) :-
2124 generate_activate_clauses(Constraints,List,Tail0),
2125 generate_remove_clauses(Constraints,Tail0,Tail1),
2126 generate_allocate_clauses(Constraints,Tail1,Tail2),
2127 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2128 generate_novel_production(Tail3,Tail4),
2129 generate_extend_history(Tail4,Tail5),
2130 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2131 generate_empty_named_history_initialisations(Tail6,Tail7),
2132 Tail7 = [].
2134 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2135 % remove_constraint_internal/[1/3]
2137 generate_remove_clauses([],List,List).
2138 generate_remove_clauses([C|Cs],List,Tail) :-
2139 generate_remove_clause(C,List,List1),
2140 generate_remove_clauses(Cs,List1,Tail).
2142 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2143 uses_state(Constraint,removed),
2144 ( chr_pp_flag(inline_insertremove,off) ->
2145 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2146 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2147 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2148 ;
2149 delay_phase_end(validate_store_type_assumptions,
2150 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2151 )
2152 ).
2154 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2155 make_name('$remove_constraint_internal_',Constraint,Name),
2156 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2157 Goal =.. [Name, Susp,Delete]
2158 ;
2159 Goal =.. [Name,Susp,Agenda,Delete]
2160 ).
2162 generate_remove_clause(Constraint,List,Tail) :-
2163 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2164 List = [RemoveClause|Tail],
2165 RemoveClause = (Head :- RemoveBody),
2166 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2167 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2168 ;
2169 List = Tail
2170 ).
2172 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2173 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2174 ( Role == active ->
2175 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2176 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2177 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2178 ; Role == partner ->
2179 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2180 GetStateValue = true,
2181 MaybeDelete = DeleteYes
2182 ),
2183 RemoveBody =
2184 (
2185 GetState,
2186 GetStateValue,
2187 UpdateState,
2188 MaybeDelete
2189 )
2190 ;
2191 static_suspension_term(Constraint,Susp2),
2192 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2193 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2194 ( chr_pp_flag(debugable,on) ->
2195 Constraint = Functor / _,
2196 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2197 ;
2198 true
2199 ),
2200 ( Role == active ->
2201 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2202 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2203 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2204 ; Role == partner ->
2205 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2206 GetStateValue = true,
2207 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2208 ),
2209 RemoveBody =
2210 (
2211 Susp = Susp2,
2212 GetStateValue,
2213 UpdateState,
2214 MaybeDelete
2215 )
2216 ).
2218 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2219 % activate_constraint/4
2221 generate_activate_clauses([],List,List).
2222 generate_activate_clauses([C|Cs],List,Tail) :-
2223 generate_activate_clause(C,List,List1),
2224 generate_activate_clauses(Cs,List1,Tail).
2226 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2227 ( chr_pp_flag(inline_insertremove,off) ->
2228 use_auxiliary_predicate(activate_constraint,Constraint),
2229 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2230 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2231 ;
2232 delay_phase_end(validate_store_type_assumptions,
2233 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2234 )
2235 ).
2237 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2238 make_name('$activate_constraint_',Constraint,Name),
2239 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2240 Goal =.. [Name,Store, Susp]
2241 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2242 Goal =.. [Name,Store, Susp, Generation]
2243 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2244 Goal =.. [Name,Store, Vars, Susp, Generation]
2245 ;
2246 Goal =.. [Name,Store, Vars, Susp]
2247 ).
2249 generate_activate_clause(Constraint,List,Tail) :-
2250 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2251 List = [Clause|Tail],
2252 Clause = (Head :- Body),
2253 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2254 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2255 ;
2256 List = Tail
2257 ).
2259 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2260 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2261 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2262 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2263 ;
2264 GenerationHandling = true
2265 ),
2266 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2267 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2268 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2269 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2270 ;
2271 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2272 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2273 ( chr_pp_flag(guard_locks,off) ->
2274 NoneLocked = true
2275 ;
2276 NoneLocked = 'chr none_locked'( Vars)
2277 ),
2278 if_used_state(Constraint,not_stored_yet,
2279 ( State == not_stored_yet ->
2280 ArgumentsGoal,
2281 IndexedVariablesBody,
2282 NoneLocked,
2283 StoreYes
2284 ;
2285 % Vars = [],
2286 StoreNo
2287 ),
2288 % (Vars = [],StoreNo),StoreVarsGoal)
2289 StoreNo,StoreVarsGoal)
2290 ),
2291 Body =
2292 (
2293 GetState,
2294 GetStateValue,
2295 UpdateState,
2296 GenerationHandling,
2297 StoreVarsGoal
2298 ).
2299 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2300 % allocate_constraint/4
2302 generate_allocate_clauses([],List,List).
2303 generate_allocate_clauses([C|Cs],List,Tail) :-
2304 generate_allocate_clause(C,List,List1),
2305 generate_allocate_clauses(Cs,List1,Tail).
2307 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2308 uses_state(Constraint,not_stored_yet),
2309 ( chr_pp_flag(inline_insertremove,off) ->
2310 use_auxiliary_predicate(allocate_constraint,Constraint),
2311 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2312 ;
2313 Goal = (Susp = Suspension, Goal0),
2314 delay_phase_end(validate_store_type_assumptions,
2315 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2316 )
2317 ).
2319 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2320 make_name('$allocate_constraint_',Constraint,Name),
2321 Goal =.. [Name,Susp|Args].
2323 generate_allocate_clause(Constraint,List,Tail) :-
2324 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2325 List = [Clause|Tail],
2326 Clause = (Head :- Body),
2327 Constraint = _/A,
2328 length(Args,A),
2329 allocate_constraint_atom(Constraint,Susp,Args,Head),
2330 allocate_constraint_body(Constraint,Susp,Args,Body)
2331 ;
2332 List = Tail
2333 ).
2335 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2336 static_suspension_term(Constraint,Suspension),
2337 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2338 ( chr_pp_flag(debugable,on) ->
2339 Constraint = Functor / _,
2340 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2341 ;
2342 true
2343 ),
2344 ( chr_pp_flag(debugable,on) ->
2345 ( may_trigger(Constraint) ->
2346 append(Args,[Susp],VarsSusp),
2347 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2348 get_target_module(Mod),
2349 Continuation = Mod : ContinuationGoal
2350 ;
2351 Continuation = true
2352 ),
2353 Init = (Susp = Suspension),
2354 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2355 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2356 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2357 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2358 Susp = Suspension, Init = true, CreateContinuation = true
2359 ;
2360 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2361 ),
2362 ( uses_history(Constraint) ->
2363 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2364 ;
2365 CreateHistory = true
2366 ),
2367 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2368 ( has_suspension_field(Constraint,id) ->
2369 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2370 gen_id(Id,GenID)
2371 ;
2372 GenID = true
2373 ),
2374 Body =
2375 (
2376 Init,
2377 CreateContinuation,
2378 CreateGeneration,
2379 CreateHistory,
2380 CreateState,
2381 GenID
2382 ).
2384 gen_id(Id,'chr gen_id'(Id)).
2385 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2386 % insert_constraint_internal
2388 generate_insert_constraint_internal_clauses([],List,List).
2389 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2390 generate_insert_constraint_internal_clause(C,List,List1),
2391 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2393 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2394 ( chr_pp_flag(inline_insertremove,off) ->
2395 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2396 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2397 ;
2398 delay_phase_end(validate_store_type_assumptions,
2399 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2400 )
2401 ).
2404 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2405 insert_constraint_internal_constraint_name(Constraint,Name),
2406 ( chr_pp_flag(debugable,on) ->
2407 Goal =.. [Name, Vars, Self, Closure | Args]
2408 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2409 Goal =.. [Name,Self | Args]
2410 ;
2411 Goal =.. [Name,Vars, Self | Args]
2412 ).
2414 insert_constraint_internal_constraint_name(Constraint,Name) :-
2415 make_name('$insert_constraint_internal_',Constraint,Name).
2417 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2418 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2419 List = [Clause|Tail],
2420 Clause = (Head :- Body),
2421 Constraint = _/A,
2422 length(Args,A),
2423 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2424 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2425 ;
2426 List = Tail
2427 ).
2430 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2431 static_suspension_term(Constraint,Suspension),
2432 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2433 ( chr_pp_flag(debugable,on) ->
2434 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2435 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2436 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2437 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2438 ;
2439 CreateGeneration = true
2440 ),
2441 ( chr_pp_flag(debugable,on) ->
2442 Constraint = Functor / _,
2443 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2444 ;
2445 true
2446 ),
2447 ( uses_history(Constraint) ->
2448 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2449 ;
2450 CreateHistory = true
2451 ),
2452 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2453 List = [Clause|Tail],
2454 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2455 suspension_term_base_fields(Constraint,BaseFields),
2456 ( has_suspension_field(Constraint,id) ->
2457 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2458 gen_id(Id,GenID)
2459 ;
2460 GenID = true
2461 ),
2462 Body =
2463 (
2464 Susp = Suspension,
2465 CreateState,
2466 CreateGeneration,
2467 CreateHistory,
2468 GenID
2469 )
2470 ;
2471 ( has_suspension_field(Constraint,id) ->
2472 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2473 gen_id(Id,GenID)
2474 ;
2475 GenID = true
2476 ),
2477 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2478 ( chr_pp_flag(guard_locks,off) ->
2479 NoneLocked = true
2480 ;
2481 NoneLocked = 'chr none_locked'( Vars)
2482 ),
2483 Body =
2484 (
2485 Susp = Suspension,
2486 IndexedVariablesBody,
2487 NoneLocked,
2488 CreateState,
2489 CreateGeneration,
2490 CreateHistory,
2491 GenID
2492 )
2493 ).
2495 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2496 % novel_production/2
2498 generate_novel_production(List,Tail) :-
2499 ( is_used_auxiliary_predicate(novel_production) ->
2500 List = [Clause|Tail],
2501 Clause =
2502 (
2503 '$novel_production'( Self, Tuple) :-
2504 % arg( 3, Self, Ref), % ARGXXX
2505 % 'chr get_mutable'( History, Ref),
2506 arg( 3, Self, History), % ARGXXX
2507 ( hprolog:get_ds( Tuple, History, _) ->
2508 fail
2509 ;
2510 true
2511 )
2512 )
2513 ;
2514 List = Tail
2515 ).
2517 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2518 % extend_history/2
2520 generate_extend_history(List,Tail) :-
2521 ( is_used_auxiliary_predicate(extend_history) ->
2522 List = [Clause|Tail],
2523 Clause =
2524 (
2525 '$extend_history'( Self, Tuple) :-
2526 % arg( 3, Self, Ref), % ARGXXX
2527 % 'chr get_mutable'( History, Ref),
2528 arg( 3, Self, History), % ARGXXX
2529 hprolog:put_ds( Tuple, History, x, NewHistory),
2530 setarg( 3, Self, NewHistory) % ARGXXX
2531 )
2532 ;
2533 List = Tail
2534 ).
2536 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2537 %
2538 :- chr_constraint
2539 empty_named_history_initialisations/2,
2540 generate_empty_named_history_initialisation/1,
2541 find_empty_named_histories/0.
2543 generate_empty_named_history_initialisations(List, Tail) :-
2544 empty_named_history_initialisations(List, Tail),
2545 find_empty_named_histories.
2547 find_empty_named_histories, history(_, Name, []) ==>
2548 generate_empty_named_history_initialisation(Name).
2550 generate_empty_named_history_initialisation(Name) \
2551 generate_empty_named_history_initialisation(Name) <=> true.
2552 generate_empty_named_history_initialisation(Name) \
2553 empty_named_history_initialisations(List, Tail) # Passive
2554 <=>
2555 empty_named_history_global_variable(Name, GlobalVariable),
2556 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2557 empty_named_history_initialisations(Rest, Tail)
2558 pragma passive(Passive).
2560 find_empty_named_histories \
2561 generate_empty_named_history_initialisation(_) # Passive <=> true
2562 pragma passive(Passive).
2564 find_empty_named_histories,
2565 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2566 pragma passive(Passive).
2568 find_empty_named_histories <=>
2569 chr_error(internal, 'find_empty_named_histories was not removed', []).
2572 empty_named_history_global_variable(Name, GlobalVariable) :-
2573 atom_concat('chr empty named history ', Name, GlobalVariable).
2575 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2576 empty_named_history_global_variable(Name, GlobalVariable).
2578 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2579 empty_named_history_global_variable(Name, GlobalVariable).
2582 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2583 % run_suspensions/2
2585 generate_run_suspensions_clauses([],List,List).
2586 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2587 generate_run_suspensions_clause(C,List,List1),
2588 generate_run_suspensions_clauses(Cs,List1,Tail).
2590 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2591 make_name('$run_suspensions_',Constraint,Name),
2592 Goal =.. [Name,Suspensions].
2594 generate_run_suspensions_clause(Constraint,List,Tail) :-
2595 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2596 List = [Clause1,Clause2|Tail],
2597 run_suspensions_goal(Constraint,[],Clause1),
2598 ( chr_pp_flag(debugable,on) ->
2599 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2600 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2601 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2602 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2603 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2604 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2605 Clause2 =
2606 (
2607 Clause2Head :-
2608 GetState,
2609 GetStateValue,
2610 ( State==active ->
2611 UpdateState,
2612 GetGeneration,
2613 GetGenerationValue,
2614 Generation is Gen+1,
2615 UpdateGeneration,
2616 GetContinuation,
2617 (
2618 'chr debug_event'(wake(Suspension)),
2619 call(Continuation)
2620 ;
2621 'chr debug_event'(fail(Suspension)), !,
2622 fail
2623 ),
2624 (
2625 'chr debug_event'(exit(Suspension))
2626 ;
2627 'chr debug_event'(redo(Suspension)),
2628 fail
2629 ),
2630 GetPost,
2631 GetPostValue,
2632 ( Post==triggered ->
2633 UpdatePost % catching constraints that did not do anything
2634 ;
2635 true
2636 )
2637 ;
2638 true
2639 ),
2640 Clause2Recursion
2641 )
2642 ;
2643 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2644 static_suspension_term(Constraint,SuspensionTerm),
2645 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2646 append(Arguments,[Suspension],VarsSusp),
2647 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2648 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2649 ( uses_field(Constraint,generation) ->
2650 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2651 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2652 ;
2653 GenerationHandling = true
2654 ),
2655 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2656 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2657 if_used_state(Constraint,removed,
2658 ( GetState,
2659 ( State==active
2660 -> ReactivateConstraint
2661 ; true)
2662 ),ReactivateConstraint,CondReactivate),
2663 ReactivateConstraint =
2664 (
2665 UpdateState,
2666 GenerationHandling,
2667 Continuation,
2668 GetPostState,
2669 ( Post==triggered ->
2670 UpdatePostState % catching constraints that did not do anything
2671 ;
2672 true
2673 )
2674 ),
2675 Clause2 =
2676 (
2677 Clause2Head :-
2678 Suspension = SuspensionTerm,
2679 CondReactivate,
2680 Clause2Recursion
2681 )
2682 )
2683 ;
2684 List = Tail
2685 ).
2687 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2689 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2690 generate_attach_increment(Clauses) :-
2691 get_max_constraint_index(N),
2692 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2693 Clauses = [Clause1,Clause2],
2694 generate_attach_increment_empty(Clause1),
2695 ( N == 1 ->
2696 generate_attach_increment_one(Clause2)
2697 ;
2698 generate_attach_increment_many(N,Clause2)
2699 )
2700 ;
2701 Clauses = []
2702 ).
2704 generate_attach_increment_empty((attach_increment([],_) :- true)).
2706 generate_attach_increment_one(Clause) :-
2707 Head = attach_increment([Var|Vars],Susps),
2708 get_target_module(Mod),
2709 ( chr_pp_flag(guard_locks,off) ->
2710 NotLocked = true
2711 ;
2712 NotLocked = 'chr not_locked'( Var)
2713 ),
2714 Body =
2715 (
2716 NotLocked,
2717 ( get_attr(Var,Mod,VarSusps) ->
2718 sort(VarSusps,SortedVarSusps),
2719 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2720 put_attr(Var,Mod,MergedSusps)
2721 ;
2722 put_attr(Var,Mod,Susps)
2723 ),
2724 attach_increment(Vars,Susps)
2725 ),
2726 Clause = (Head :- Body).
2728 generate_attach_increment_many(N,Clause) :-
2729 Head = attach_increment([Var|Vars],TAttr1),
2730 % writeln(merge_attributes_1_before),
2731 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2732 % writeln(merge_attributes_1_after),
2733 get_target_module(Mod),
2734 ( chr_pp_flag(guard_locks,off) ->
2735 NotLocked = true
2736 ;
2737 NotLocked = 'chr not_locked'( Var)
2738 ),
2739 Body =
2740 (
2741 NotLocked,
2742 ( get_attr(Var,Mod,TAttr2) ->
2743 MergeGoal,
2744 put_attr(Var,Mod,Attr)
2745 ;
2746 put_attr(Var,Mod,TAttr1)
2747 ),
2748 attach_increment(Vars,TAttr1)
2749 ),
2750 Clause = (Head :- Body).
2752 %% attr_unify_hook
2753 generate_attr_unify_hook(Clauses) :-
2754 get_max_constraint_index(N),
2755 ( N == 0 ->
2756 Clauses = []
2757 ;
2758 ( N == 1 ->
2759 generate_attr_unify_hook_one(Clauses)
2760 ;
2761 generate_attr_unify_hook_many(N,Clauses)
2762 )
2763 ).
2765 generate_attr_unify_hook_one([Clause]) :-
2766 Head = attr_unify_hook(Susps,Other),
2767 get_target_module(Mod),
2768 get_indexed_constraint(1,C),
2769 ( get_store_type(C,ST),
2770 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2771 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2772 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2773 ( atomic_types_suspended_constraint(C) ->
2774 SortGoal1 = true,
2775 SortedSusps = Susps,
2776 SortGoal2 = true,
2777 SortedOtherSusps = OtherSusps,
2778 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2779 NonvarBody = true
2780 ;
2781 SortGoal1 = sort(Susps, SortedSusps),
2782 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2783 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2784 use_auxiliary_predicate(attach_increment),
2785 NonvarBody =
2786 ( compound(Other) ->
2787 term_variables(Other,OtherVars),
2788 attach_increment(OtherVars, SortedSusps)
2789 ;
2790 true
2791 )
2792 ),
2793 Body =
2794 (
2795 SortGoal1,
2796 ( var(Other) ->
2797 ( get_attr(Other,Mod,OtherSusps) ->
2798 SortGoal2,
2799 MergeGoal,
2800 put_attr(Other,Mod,NewSusps),
2801 WakeNewSusps
2802 ;
2803 put_attr(Other,Mod,SortedSusps),
2804 WakeSusps
2805 )
2806 ;
2807 NonvarBody,
2808 WakeSusps
2809 )
2810 ),
2811 Clause = (Head :- Body)
2812 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2813 make_run_suspensions(List,List,WakeNewSusps),
2814 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2815 Body =
2816 ( get_attr(Other,Mod,OtherSusps) ->
2817 MergeGoal,
2818 WakeNewSusps
2819 ;
2820 put_attr(Other,Mod,Susps)
2821 ),
2822 Clause = (Head :- Body)
2823 ).
2826 generate_attr_unify_hook_many(N,[Clause]) :-
2827 chr_pp_flag(dynattr,off), !,
2828 Head = attr_unify_hook(Attr,Other),
2829 get_target_module(Mod),
2830 make_attr(N,Mask,SuspsList,Attr),
2831 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2832 list2conj(SortGoalList,SortGoals),
2833 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2834 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2835 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2836 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2837 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2838 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2839 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2840 NonvarBody = true
2841 ;
2842 use_auxiliary_predicate(attach_increment),
2843 NonvarBody =
2844 ( compound(Other) ->
2845 term_variables(Other,OtherVars),
2846 attach_increment(OtherVars,SortedAttr)
2847 ;
2848 true
2849 )
2850 ),
2851 Body =
2852 (
2853 SortGoals,
2854 ( var(Other) ->
2855 ( get_attr(Other,Mod,TOtherAttr) ->
2856 MergeGoal,
2857 put_attr(Other,Mod,MergedAttr),
2858 WakeMergedSusps
2859 ;
2860 put_attr(Other,Mod,SortedAttr),
2861 WakeSortedSusps
2862 )
2863 ;
2864 NonvarBody,
2865 WakeSortedSusps
2866 )
2867 ),
2868 Clause = (Head :- Body).
2870 % NEW
2871 generate_attr_unify_hook_many(N,Clauses) :-
2872 Head = attr_unify_hook(Attr,Other),
2873 get_target_module(Mod),
2874 normalize_attr(Attr,NormalGoal,NormalAttr),
2875 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2876 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2877 make_run_suspensions(N),
2878 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2879 NonvarBody = true
2880 ;
2881 use_auxiliary_predicate(attach_increment),
2882 NonvarBody =
2883 ( compound(Other) ->
2884 term_variables(Other,OtherVars),
2885 attach_increment(OtherVars,NormalAttr)
2886 ;
2887 true
2888 )
2889 ),
2890 Body =
2891 (
2892 NormalGoal,
2893 ( var(Other) ->
2894 ( get_attr(Other,Mod,OtherAttr) ->
2895 NormalOtherGoal,
2896 MergeGoal,
2897 put_attr(Other,Mod,MergedAttr),
2898 '$dispatch_run_suspensions'(MergedAttr)
2899 ;
2900 put_attr(Other,Mod,NormalAttr),
2901 '$dispatch_run_suspensions'(NormalAttr)
2902 )
2903 ;
2904 NonvarBody,
2905 '$dispatch_run_suspensions'(NormalAttr)
2906 )
2907 ),
2908 Clause = (Head :- Body),
2909 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2910 DispatchList1 = ('$dispatch_run_suspensions'([])),
2911 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2912 run_suspensions_dispatchers(N,[],Dispatchers).
2914 % NEW
2915 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2916 ( N > 0 ->
2917 get_indexed_constraint(N,C),
2918 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2919 ( may_trigger(C) ->
2920 run_suspensions_goal(C,List,Body)
2921 ;
2922 Body = true
2923 ),
2924 M is N - 1,
2925 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2926 ;
2927 Dispatchers = Acc
2928 ).
2930 % NEW
2931 make_run_suspensions(N) :-
2932 ( N > 0 ->
2933 ( get_indexed_constraint(N,C),
2934 may_trigger(C) ->
2935 use_auxiliary_predicate(run_suspensions,C)
2936 ;
2937 true
2938 ),
2939 M is N - 1,
2940 make_run_suspensions(M)
2941 ;
2942 true
2943 ).
2945 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2946 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2948 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2949 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2950 use_auxiliary_predicate(run_suspensions,C),
2951 ( wakes_partially(C) ->
2952 run_suspensions_goal(C,OneSusps,Goal)
2953 ;
2954 run_suspensions_goal(C,AllSusps,Goal)
2955 )
2956 ;
2957 Goal = true
2958 ).
2960 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2961 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2963 make_run_suspensions_loop([],[],_,true).
2964 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2965 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2966 J is I + 1,
2967 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2970 % $insert_in_store_F/A
2971 % $delete_from_store_F/A
2973 generate_insert_delete_constraints([],[]).
2974 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2975 ( is_stored(FA) ->
2976 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2977 ;
2978 Clauses = RestClauses
2979 ),
2980 generate_insert_delete_constraints(Rest,RestClauses).
2982 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2983 insert_constraint_clause(FA,Clauses,RestClauses1),
2984 delete_constraint_clause(FA,RestClauses1,RestClauses).
2986 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2987 % insert_in_store
2989 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2990 ( chr_pp_flag(inline_insertremove,off) ->
2991 use_auxiliary_predicate(insert_in_store,FA),
2992 insert_constraint_atom(FA,Susp,Goal)
2993 ;
2994 delay_phase_end(validate_store_type_assumptions,
2995 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2996 insert_constraint_direct_used_vars(UsedVars,Vars)
2997 )
2998 )
2999 ).
3001 insert_constraint_direct_used_vars([],_).
3002 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
3003 nth1(Index,Vars,Var),
3004 insert_constraint_direct_used_vars(Rest,Vars).
3006 insert_constraint_atom(FA,Susp,Call) :-
3007 make_name('$insert_in_store_',FA,Functor),
3008 Call =.. [Functor,Susp].
3010 insert_constraint_clause(C,Clauses,RestClauses) :-
3011 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3012 Clauses = [Clause|RestClauses],
3013 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3014 insert_constraint_atom(C,Susp,Head),
3015 insert_constraint_body(C,Susp,UsedVars,Body),
3016 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3017 ( chr_pp_flag(store_counter,on) ->
3018 InsertCounterInc = '$insert_counter_inc'
3019 ;
3020 InsertCounterInc = true
3021 )
3022 ;
3023 Clauses = RestClauses
3024 ).
3026 insert_constraint_used_vars([],_,_,true).
3027 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3028 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3029 insert_constraint_used_vars(Rest,C,Susp,Goals).
3031 insert_constraint_body(C,Susp,UsedVars,Body) :-
3032 get_store_type(C,StoreType),
3033 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3035 insert_constraint_body(default,C,Susp,[],Body) :-
3036 global_list_store_name(C,StoreName),
3037 make_get_store_goal(StoreName,Store,GetStoreGoal),
3038 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3039 ( chr_pp_flag(debugable,on) ->
3040 Cell = [Susp|Store],
3041 Body =
3042 (
3043 GetStoreGoal,
3044 UpdateStoreGoal
3045 )
3046 ;
3047 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3048 Body =
3049 (
3050 GetStoreGoal,
3051 Cell = [Susp|Store],
3052 UpdateStoreGoal,
3053 ( Store = [NextSusp|_] ->
3054 SetGoal
3055 ;
3056 true
3057 )
3058 )
3059 ).
3060 % get_target_module(Mod),
3061 % get_max_constraint_index(Total),
3062 % ( Total == 1 ->
3063 % generate_attach_body_1(C,Store,Susp,AttachBody)
3064 % ;
3065 % generate_attach_body_n(C,Store,Susp,AttachBody)
3066 % ),
3067 % Body =
3068 % (
3069 % 'chr default_store'(Store),
3070 % AttachBody
3071 % ).
3072 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3073 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3074 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3075 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3076 sort_out_used_vars(MixedUsedVars,UsedVars).
3077 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3078 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3079 constants_store_index_name(C,Index,IndexName),
3080 IndexLookup =.. [IndexName,Key,StoreName],
3081 Body =
3082 ( IndexLookup ->
3083 nb_getval(StoreName,Store),
3084 b_setval(StoreName,[Susp|Store])
3085 ;
3086 true
3087 ).
3088 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3089 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3090 constants_store_index_name(C,Index,IndexName),
3091 IndexLookup =.. [IndexName,Key,StoreName],
3092 Body =
3093 ( IndexLookup ->
3094 nb_getval(StoreName,Store),
3095 b_setval(StoreName,[Susp|Store])
3096 ;
3097 true
3098 ).
3099 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3100 global_ground_store_name(C,StoreName),
3101 make_get_store_goal(StoreName,Store,GetStoreGoal),
3102 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3103 ( chr_pp_flag(debugable,on) ->
3104 Cell = [Susp|Store],
3105 Body =
3106 (
3107 GetStoreGoal,
3108 UpdateStoreGoal
3109 )
3110 ;
3111 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3112 Body =
3113 (
3114 GetStoreGoal,
3115 Cell = [Susp|Store],
3116 UpdateStoreGoal,
3117 ( Store = [NextSusp|_] ->
3118 SetGoal
3119 ;
3120 true
3121 )
3122 )
3123 ).
3124 % global_ground_store_name(C,StoreName),
3125 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3126 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3127 % Body =
3128 % (
3129 % GetStoreGoal, % nb_getval(StoreName,Store),
3130 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3131 % ).
3132 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3133 % TODO: generalize to more than one !!!
3134 get_target_module(Module),
3135 Body = ( get_attr(Variable,Module,AssocStore) ->
3136 insert_assoc_store(AssocStore,Key,Susp)
3137 ;
3138 new_assoc_store(AssocStore),
3139 put_attr(Variable,Module,AssocStore),
3140 insert_assoc_store(AssocStore,Key,Susp)
3141 ).
3143 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3144 global_singleton_store_name(C,StoreName),
3145 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3146 Body =
3147 (
3148 UpdateStoreGoal
3149 ).
3150 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3151 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3152 list2conj(Bodies,Body),
3153 sort_out_used_vars(NestedUsedVars,UsedVars).
3154 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3155 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3156 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3157 UsedVars = [Index-Var],
3158 get_identifier_size(ISize),
3159 functor(Struct,struct,ISize),
3160 get_identifier_index(C,Index,IIndex),
3161 arg(IIndex,Struct,Susps),
3162 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3163 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3164 UsedVars = [Index-Var],
3165 type_indexed_identifier_structure(IndexType,Struct),
3166 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3167 arg(IIndex,Struct,Susps),
3168 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3170 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3171 flatten(NestedUsedVars,FlatUsedVars),
3172 sort(FlatUsedVars,SortedFlatUsedVars),
3173 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3175 sort_out_used_vars1([],[]).
3176 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3177 sort_out_used_vars1([I-X,J-Y|R],L) :-
3178 ( I == J ->
3179 X = Y,
3180 sort_out_used_vars1([I-X|R],L)
3181 ;
3182 L = [I-X|T],
3183 sort_out_used_vars1([J-Y|R],T)
3184 ).
3186 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3187 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3188 multi_hash_store_name(FA,Index,StoreName),
3189 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3190 Body =
3191 (
3192 KeyBody,
3193 nb_getval(StoreName,Store),
3194 insert_iht(Store,Key,Susp)
3195 ),
3196 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3198 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3199 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3200 multi_hash_store_name(FA,Index,StoreName),
3201 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3202 make_get_store_goal(StoreName,Store,GetStoreGoal),
3203 ( chr_pp_flag(ht_removal,on)
3204 -> ht_prev_field(Index,PrevField),
3205 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3206 SetGoal),
3207 Body =
3208 (
3209 GetStoreGoal,
3210 insert_ht(Store,Key,Susp,Result),
3211 ( Result = [_,NextSusp|_]
3212 -> SetGoal
3213 ; true
3214 )
3215 )
3216 ; Body =
3217 (
3218 GetStoreGoal,
3219 insert_ht(Store,Key,Susp)
3220 )
3221 ),
3222 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3224 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3225 % Delete
3227 delete_constraint_clause(C,Clauses,RestClauses) :-
3228 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3229 Clauses = [Clause|RestClauses],
3230 Clause = (Head :- Body),
3231 delete_constraint_atom(C,Susp,Head),
3232 C = F/A,
3233 functor(Head,F,A),
3234 delete_constraint_body(C,Head,Susp,[],Body)
3235 ;
3236 Clauses = RestClauses
3237 ).
3239 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3240 functor(Head,F,A),
3241 C = F/A,
3242 ( chr_pp_flag(inline_insertremove,off) ->
3243 use_auxiliary_predicate(delete_from_store,C),
3244 delete_constraint_atom(C,Susp,Goal)
3245 ;
3246 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3247 ).
3249 delete_constraint_atom(C,Susp,Atom) :-
3250 make_name('$delete_from_store_',C,Functor),
3251 Atom =.. [Functor,Susp].
3254 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3255 Body = (CounterBody,DeleteBody),
3256 ( chr_pp_flag(store_counter,on) ->
3257 CounterBody = '$delete_counter_inc'
3258 ;
3259 CounterBody = true
3260 ),
3261 get_store_type(C,StoreType),
3262 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3264 delete_constraint_body(default,C,_,Susp,_,Body) :-
3265 ( chr_pp_flag(debugable,on) ->
3266 global_list_store_name(C,StoreName),
3267 make_get_store_goal(StoreName,Store,GetStoreGoal),
3268 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3269 Body =
3270 (
3271 GetStoreGoal, % nb_getval(StoreName,Store),
3272 'chr sbag_del_element'(Store,Susp,NStore),
3273 UpdateStoreGoal % b_setval(StoreName,NStore)
3274 )
3275 ;
3276 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3277 global_list_store_name(C,StoreName),
3278 make_get_store_goal(StoreName,Store,GetStoreGoal),
3279 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3280 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3281 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3282 Body =
3283 (
3284 GetGoal,
3285 ( var(PredCell) ->
3286 GetStoreGoal, % nb_getval(StoreName,Store),
3287 Store = [_|Tail],
3288 UpdateStoreGoal,
3289 ( Tail = [NextSusp|_] ->
3290 SetGoal1
3291 ;
3292 true
3293 )
3294 ;
3295 PredCell = [_,_|Tail],
3296 setarg(2,PredCell,Tail),
3297 ( Tail = [NextSusp|_] ->
3298 SetGoal2
3299 ;
3300 true
3301 )
3302 )
3303 )
3304 ).
3305 % get_target_module(Mod),
3306 % get_max_constraint_index(Total),
3307 % ( Total == 1 ->
3308 % generate_detach_body_1(C,Store,Susp,DetachBody),
3309 % Body =
3310 % (
3311 % 'chr default_store'(Store),
3312 % DetachBody
3313 % )
3314 % ;
3315 % generate_detach_body_n(C,Store,Susp,DetachBody),
3316 % Body =
3317 % (
3318 % 'chr default_store'(Store),
3319 % DetachBody
3320 % )
3321 % ).
3322 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3323 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3324 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3325 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3326 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3327 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3328 constants_store_index_name(C,Index,IndexName),
3329 IndexLookup =.. [IndexName,Key,StoreName],
3330 Body =
3331 ( KeyBody,
3332 ( IndexLookup ->
3333 nb_getval(StoreName,Store),
3334 'chr sbag_del_element'(Store,Susp,NStore),
3335 b_setval(StoreName,NStore)
3336 ;
3337 true
3338 )).
3339 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3340 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3341 constants_store_index_name(C,Index,IndexName),
3342 IndexLookup =.. [IndexName,Key,StoreName],
3343 Body =
3344 ( KeyBody,
3345 ( IndexLookup ->
3346 nb_getval(StoreName,Store),
3347 'chr sbag_del_element'(Store,Susp,NStore),
3348 b_setval(StoreName,NStore)
3349 ;
3350 true
3351 )).
3352 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3353 ( chr_pp_flag(debugable,on) ->
3354 global_ground_store_name(C,StoreName),
3355 make_get_store_goal(StoreName,Store,GetStoreGoal),
3356 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3357 Body =
3358 (
3359 GetStoreGoal, % nb_getval(StoreName,Store),
3360 'chr sbag_del_element'(Store,Susp,NStore),
3361 UpdateStoreGoal % b_setval(StoreName,NStore)
3362 )
3363 ;
3364 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3365 global_ground_store_name(C,StoreName),
3366 make_get_store_goal(StoreName,Store,GetStoreGoal),
3367 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3368 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3369 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3370 Body =
3371 (
3372 GetGoal,
3373 ( var(PredCell) ->
3374 GetStoreGoal, % nb_getval(StoreName,Store),
3375 Store = [_|Tail],
3376 UpdateStoreGoal,
3377 ( Tail = [NextSusp|_] ->
3378 SetGoal1
3379 ;
3380 true
3381 )
3382 ;
3383 PredCell = [_,_|Tail],
3384 setarg(2,PredCell,Tail),
3385 ( Tail = [NextSusp|_] ->
3386 SetGoal2
3387 ;
3388 true
3389 )
3390 )
3391 )
3392 ).
3393 % global_ground_store_name(C,StoreName),
3394 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3395 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3396 % Body =
3397 % (
3398 % GetStoreGoal, % nb_getval(StoreName,Store),
3399 % 'chr sbag_del_element'(Store,Susp,NStore),
3400 % UpdateStoreGoal % b_setval(StoreName,NStore)
3401 % ).
3402 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3403 get_target_module(Module),
3404 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3405 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3406 Body = (
3407 VariableGoal,
3408 get_attr(Variable,Module,AssocStore),
3409 KeyGoal,
3410 delete_assoc_store(AssocStore,Key,Susp)
3411 ).
3412 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3413 global_singleton_store_name(C,StoreName),
3414 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3415 Body =
3416 (
3417 UpdateStoreGoal % b_setval(StoreName,[])
3418 ).
3419 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3420 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3421 list2conj(Bodies,Body).
3422 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3423 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3424 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3425 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3426 get_identifier_size(ISize),
3427 functor(Struct,struct,ISize),
3428 get_identifier_index(C,Index,IIndex),
3429 arg(IIndex,Struct,Susps),
3430 Body = (
3431 VariableGoal,
3432 Variable = Struct,
3433 'chr sbag_del_element'(Susps,Susp,NSusps),
3434 setarg(IIndex,Variable,NSusps)
3435 ).
3436 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3437 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3438 type_indexed_identifier_structure(IndexType,Struct),
3439 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3440 arg(IIndex,Struct,Susps),
3441 Body = (
3442 VariableGoal,
3443 Variable = Struct,
3444 'chr sbag_del_element'(Susps,Susp,NSusps),
3445 setarg(IIndex,Variable,NSusps)
3446 ).
3448 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3449 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3450 multi_hash_store_name(FA,Index,StoreName),
3451 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3452 Body =
3453 (
3454 KeyBody,
3455 nb_getval(StoreName,Store),
3456 delete_iht(Store,Key,Susp)
3457 ),
3458 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3459 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3460 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3461 multi_hash_store_name(C,Index,StoreName),
3462 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3463 make_get_store_goal(StoreName,Store,GetStoreGoal),
3464 ( chr_pp_flag(ht_removal,on)
3465 -> ht_prev_field(Index,PrevField),
3466 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3467 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3468 SetGoal1),
3469 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3470 SetGoal2),
3471 Body =
3472 (
3473 GetGoal,
3474 ( var(Prev)
3475 -> GetStoreGoal,
3476 KeyBody,
3477 delete_first_ht(Store,Key,Values),
3478 ( Values = [NextSusp|_]
3479 -> SetGoal1
3480 ; true
3481 )
3482 ; Prev = [_,_|Values],
3483 setarg(2,Prev,Values),
3484 ( Values = [NextSusp|_]
3485 -> SetGoal2
3486 ; true
3487 )
3488 )
3489 )
3490 ; Body =
3491 (
3492 KeyBody,
3493 GetStoreGoal, % nb_getval(StoreName,Store),
3494 delete_ht(Store,Key,Susp)
3495 )
3496 ),
3497 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3499 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3501 :- chr_constraint
3502 module_initializer/1,
3503 module_initializers/1.
3505 module_initializers(G), module_initializer(Initializer) <=>
3506 G = (Initializer,Initializers),
3507 module_initializers(Initializers).
3509 module_initializers(G) <=>
3510 G = true.
3512 generate_attach_code(Constraints,[Enumerate|L]) :-
3513 enumerate_stores_code(Constraints,Enumerate),
3514 generate_attach_code(Constraints,L,T),
3515 module_initializers(Initializers),
3516 prolog_global_variables_code(PrologGlobalVariables),
3517 % Do not rename or the 'chr_initialization' predicate
3518 % without warning SSS
3519 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3521 generate_attach_code([],L,L).
3522 generate_attach_code([C|Cs],L,T) :-
3523 get_store_type(C,StoreType),
3524 generate_attach_code(StoreType,C,L,L1),
3525 generate_attach_code(Cs,L1,T).
3527 generate_attach_code(default,C,L,T) :-
3528 global_list_store_initialisation(C,L,T).
3529 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3530 multi_inthash_store_initialisations(Indexes,C,L,L1),
3531 multi_inthash_via_lookups(Indexes,C,L1,T).
3532 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3533 multi_hash_store_initialisations(Indexes,C,L,L1),
3534 multi_hash_lookups(Indexes,C,L1,T).
3535 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3536 constants_initializers(C,Index,Constants),
3537 atomic_constants_code(C,Index,Constants,L,T).
3538 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3539 constants_initializers(C,Index,Constants),
3540 ground_constants_code(C,Index,Constants,L,T).
3541 generate_attach_code(global_ground,C,L,T) :-
3542 global_ground_store_initialisation(C,L,T).
3543 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3544 use_auxiliary_module(chr_assoc_store).
3545 generate_attach_code(global_singleton,C,L,T) :-
3546 global_singleton_store_initialisation(C,L,T).
3547 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3548 multi_store_generate_attach_code(StoreTypes,C,L,T).
3549 generate_attach_code(identifier_store(Index),C,L,T) :-
3550 get_identifier_index(C,Index,IIndex),
3551 ( IIndex == 2 ->
3552 get_identifier_size(ISize),
3553 functor(Struct,struct,ISize),
3554 Struct =.. [_,Label|Stores],
3555 set_elems(Stores,[]),
3556 Clause1 = new_identifier(Label,Struct),
3557 functor(Struct2,struct,ISize),
3558 arg(1,Struct2,Label2),
3559 Clause2 =
3560 ( user:portray(Struct2) :-
3561 write('<id:'),
3562 print(Label2),
3563 write('>')
3564 ),
3565 functor(Struct3,struct,ISize),
3566 arg(1,Struct3,Label3),
3567 Clause3 = identifier_label(Struct3,Label3),
3568 L = [Clause1,Clause2,Clause3|T]
3569 ;
3570 L = T
3571 ).
3572 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3573 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3574 ( IIndex == 2 ->
3575 identifier_store_initialization(IndexType,L,L1),
3576 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3577 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3578 get_type_indexed_identifier_size(IndexType,ISize),
3579 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3581 type_indexed_identifier_structure(IndexType,Struct),
3582 Struct =.. [_,Label|Stores],
3583 set_elems(Stores,[]),
3584 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3585 Clause1 =.. [Name1,Label,Struct],
3586 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3587 Goal1 =.. [Name1,Label1b,S1b],
3588 type_indexed_identifier_structure(IndexType,Struct1b),
3589 Struct1b =.. [_,Label1b|Stores1b],
3590 set_elems(Stores1b,[]),
3591 Expansion1 = (S1b = Struct1b),
3592 Clause1b = user:goal_expansion(Goal1,Expansion1),
3593 % writeln(Clause1-Clause1b),
3594 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3595 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3596 type_indexed_identifier_structure(IndexType,Struct2),
3597 arg(1,Struct2,Label2),
3598 Clause2 =
3599 ( user:portray(Struct2) :-
3600 write('<id:'),
3601 print(Label2),
3602 write('>')
3603 ),
3604 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3606 type_indexed_identifier_structure(IndexType,Struct3),
3607 arg(1,Struct3,Label3),
3608 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3609 Clause3 =.. [Name3,Struct3,Label3],
3610 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3611 Goal3b =.. [Name3,S3b,L3b],
3612 type_indexed_identifier_structure(IndexType,Struct3b),
3613 arg(1,Struct3b,L3b),
3614 Expansion3b = (S3 = Struct3b),
3615 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3616 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3617 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3618 identifier_store_name(IndexType,GlobalVariable),
3619 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3620 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3621 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3622 Clause4 =
3623 ( LookupAtom :-
3624 nb_getval(GlobalVariable,HT),
3625 ( lookup_ht(HT,X,[IX]) ->
3626 true
3627 ;
3628 NewIdentifierGoal,
3629 insert_ht(HT,X,IX)
3630 )
3631 ),
3632 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3633 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3634 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3635 ;
3636 L = T
3637 ).
3639 constants_initializers(C,Index,Constants) :-
3640 maplist(constant_initializer(C,Index),Constants).
3642 constant_initializer(C,Index,Constant) :-
3643 constants_store_name(C,Index,Constant,StoreName),
3644 module_initializer(nb_setval(StoreName,[])).
3646 lookup_identifier_atom(Key,X,IX,Atom) :-
3647 atom_concat('lookup_identifier_',Key,LookupFunctor),
3648 Atom =.. [LookupFunctor,X,IX].
3650 identifier_label_atom(IndexType,IX,X,Atom) :-
3651 type_indexed_identifier_name(IndexType,identifier_label,Name),
3652 Atom =.. [Name,IX,X].
3654 multi_store_generate_attach_code([],_,L,L).
3655 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3656 generate_attach_code(ST,C,L,L1),
3657 multi_store_generate_attach_code(STs,C,L1,T).
3659 multi_inthash_store_initialisations([],_,L,L).
3660 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3661 use_auxiliary_module(chr_integertable_store),
3662 multi_hash_store_name(FA,Index,StoreName),
3663 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3664 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3665 L1 = L,
3666 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3667 multi_hash_store_initialisations([],_,L,L).
3668 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3669 use_auxiliary_module(chr_hashtable_store),
3670 multi_hash_store_name(FA,Index,StoreName),
3671 prolog_global_variable(StoreName),
3672 make_init_store_goal(StoreName,HT,InitStoreGoal),
3673 module_initializer((new_ht(HT),InitStoreGoal)),
3674 L1 = L,
3675 multi_hash_store_initialisations(Indexes,FA,L1,T).
3677 global_list_store_initialisation(C,L,T) :-
3678 ( is_stored(C) ->
3679 global_list_store_name(C,StoreName),
3680 prolog_global_variable(StoreName),
3681 make_init_store_goal(StoreName,[],InitStoreGoal),
3682 module_initializer(InitStoreGoal)
3683 ;
3684 true
3685 ),
3686 L = T.
3687 global_ground_store_initialisation(C,L,T) :-
3688 global_ground_store_name(C,StoreName),
3689 prolog_global_variable(StoreName),
3690 make_init_store_goal(StoreName,[],InitStoreGoal),
3691 module_initializer(InitStoreGoal),
3692 L = T.
3693 global_singleton_store_initialisation(C,L,T) :-
3694 global_singleton_store_name(C,StoreName),
3695 prolog_global_variable(StoreName),
3696 make_init_store_goal(StoreName,[],InitStoreGoal),
3697 module_initializer(InitStoreGoal),
3698 L = T.
3699 identifier_store_initialization(IndexType,L,T) :-
3700 use_auxiliary_module(chr_hashtable_store),
3701 identifier_store_name(IndexType,StoreName),
3702 prolog_global_variable(StoreName),
3703 make_init_store_goal(StoreName,HT,InitStoreGoal),
3704 module_initializer((new_ht(HT),InitStoreGoal)),
3705 L = T.
3708 multi_inthash_via_lookups([],_,L,L).
3709 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3710 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3711 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3712 L = [(Head :- Body)|L1],
3713 multi_inthash_via_lookups(Indexes,C,L1,T).
3714 multi_hash_lookups([],_,L,L).
3715 multi_hash_lookups([Index|Indexes],C,L,T) :-
3716 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3717 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3718 L = [(Head :- Body)|L1],
3719 multi_hash_lookups(Indexes,C,L1,T).
3721 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3722 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3723 Head =.. [Name,Key,SuspsList].
3725 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3726 %
3727 % Returns goal that performs hash table lookup.
3728 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3729 % INLINED:
3730 get_store_type(ConstraintSymbol,multi_store(Stores)),
3731 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3732 ( ground(Key) ->
3733 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3734 Goal = nb_getval(StoreName,SuspsList)
3735 ;
3736 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3737 Lookup =.. [IndexName,Key,StoreName],
3738 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3739 )
3740 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3741 ( ground(Key) ->
3742 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3743 Goal = nb_getval(StoreName,SuspsList)
3744 ;
3745 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3746 Lookup =.. [IndexName,Key,StoreName],
3747 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3748 )
3749 ; memberchk(multi_hash([Index]),Stores) ->
3750 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3751 make_get_store_goal(StoreName,HT,GetStoreGoal),
3752 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3753 Goal =
3754 (
3755 GetStoreGoal, % nb_getval(StoreName,HT),
3756 HashCall, % hash_term(Key,Hash),
3757 lookup_ht1(HT,Hash,Key,SuspsList)
3758 )
3759 ;
3760 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3761 Goal =
3762 (
3763 GetStoreGoal, % nb_getval(StoreName,HT),
3764 Lookup
3765 )
3766 )
3767 ; HashType == inthash ->
3768 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3769 make_get_store_goal(StoreName,HT,GetStoreGoal),
3770 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3771 Goal =
3772 (
3773 GetStoreGoal, % nb_getval(StoreName,HT),
3774 Lookup
3775 )
3776 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3777 % find alternative index
3778 % -> SubIndex + RestIndex
3779 % -> SubKey + RestKeys
3780 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3781 % instantiate rest goal?
3782 % Goal = (SubGoal,RestGoal)
3783 ).
3786 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3787 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3789 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3790 ( ground(Key) ->
3791 % This is based on a property of SWI-Prolog's
3792 % hash_term/2 predicate:
3793 % the hash value is stable over repeated invocations
3794 % of SWI-Prolog
3795 hash_term(Key,Hash),
3796 Call = true
3797 ; Index = [IndexPos],
3798 get_constraint_type(Constraint,ArgTypes),
3799 nth1(IndexPos,ArgTypes,Type),
3800 unalias_type(Type,NormalType),
3801 memberchk_eq(NormalType,[int,natural]) ->
3802 ( NormalType == int ->
3803 Call = (Hash is abs(Key))
3804 ;
3805 Hash = Key,
3806 Call = true
3807 )
3808 ;
3809 nonvar(Key),
3810 specialize_hash_term(Key,NewKey),
3811 NewKey \== Key,
3812 Call = hash_term(NewKey,Hash)
3813 ).
3815 specialize_hash_term(Term,NewTerm) :-
3816 ( ground(Term) ->
3817 hash_term(Term,NewTerm)
3818 ; var(Term) ->
3819 NewTerm = Term
3820 ;
3821 Term =.. [F|Args],
3822 maplist(specialize_hash_term,Args,NewArgs),
3823 NewTerm =.. [F|NewArgs]
3824 ).
3826 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3827 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3828 ( /* chr_pp_flag(experiment,off) ->
3829 true
3830 ; */ atomic(Key) ->
3831 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3832 ; ground(Key) ->
3833 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3834 ;
3835 ( Index = [Pos],
3836 get_constraint_arg_type(ConstraintSymbol,Pos,chr_constants(_))
3837 ->
3838 true
3839 ;
3840 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3841 )
3842 ),
3843 delay_phase_end(validate_store_type_assumptions,
3844 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3846 :- chr_constraint actual_atomic_multi_hash_keys/3.
3847 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3849 :- chr_constraint actual_ground_multi_hash_keys/3.
3850 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3852 :- chr_constraint actual_non_ground_multi_hash_key/2.
3853 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3855 /*
3856 actual_atomic_multi_hash_keys(C,Index,Keys)
3857 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3859 actual_ground_multi_hash_keys(C,Index,Keys)
3860 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3862 actual_non_ground_multi_hash_key(C,Index)
3863 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3864 */
3865 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3866 <=> append(Keys1,Keys2,Keys0),
3867 sort(Keys0,Keys),
3868 actual_atomic_multi_hash_keys(C,Index,Keys).
3870 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3871 <=> append(Keys1,Keys2,Keys0),
3872 sort(Keys0,Keys),
3873 actual_ground_multi_hash_keys(C,Index,Keys).
3875 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3876 <=> append(Keys1,Keys2,Keys0),
3877 sort(Keys0,Keys),
3878 actual_ground_multi_hash_keys(C,Index,Keys).
3880 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3881 <=> true.
3883 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3884 <=> true.
3886 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3887 <=> true.
3889 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3890 %
3891 % Returns predicate name of hash table lookup predicate.
3892 multi_hash_lookup_name(F/A,Index,Name) :-
3893 atom_concat_list(Index,IndexName),
3894 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3896 multi_hash_store_name(F/A,Index,Name) :-
3897 get_target_module(Mod),
3898 atom_concat_list(Index,IndexName),
3899 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3901 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3902 ( Index = [I] ->
3903 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3904 ;
3905 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
3906 Key =.. [k|Keys],
3907 list2conj(Bodies,KeyBody)
3908 ).
3910 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3911 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3913 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3914 ( Index = [I] ->
3915 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3916 ;
3917 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
3918 Key =.. [k|Keys],
3919 list2conj(Bodies,KeyBody)
3920 ).
3922 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3923 arg(Index,Head,OriginalArg),
3924 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3925 Goal = true
3926 ;
3927 functor(Head,F,A),
3928 C = F/A,
3929 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3930 ).
3932 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3933 ( Index = [I] ->
3934 UsedVars = [I-Key]
3935 ;
3936 pairup(Index,Keys,UsedVars),
3937 Key =.. [k|Keys]
3938 ).
3940 multi_hash_key_args(Index,Head,KeyArgs) :-
3941 maplist(arg1(Head),Index,KeyArgs).
3943 %-------------------------------------------------------------------------------
3944 atomic_constants_code(C,Index,Constants,L,T) :-
3945 constants_store_index_name(C,Index,IndexName),
3946 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3947 append(Clauses,T,L).
3949 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3950 constants_store_name(C,Index,Constant,StoreName),
3951 Clause =.. [IndexName,Constant,StoreName].
3953 %-------------------------------------------------------------------------------
3954 ground_constants_code(C,Index,Terms,L,T) :-
3955 constants_store_index_name(C,Index,IndexName),
3956 maplist(constants_store_name(C,Index),Terms,StoreNames),
3957 length(Terms,N),
3958 replicate(N,[],More),
3959 trie_index([Terms|More],StoreNames,IndexName,L,T).
3961 constants_store_name(F/A,Index,Term,Name) :-
3962 get_target_module(Mod),
3963 term_to_atom(Term,Constant),
3964 term_to_atom(Index,IndexAtom),
3965 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3967 constants_store_index_name(F/A,Index,Name) :-
3968 get_target_module(Mod),
3969 term_to_atom(Index,IndexAtom),
3970 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3972 % trie index code {{{
3973 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3974 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3976 trie_step([],_,_,[],[],L,L) :- !.
3977 % length MorePatterns == length Patterns == length Results
3978 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3979 MorePatterns = [List|_],
3980 length(List,N),
3981 aggregate_all(set(F/A),
3982 ( member(Pattern,Patterns),
3983 functor(Pattern,F,A)
3984 ),
3985 FAs),
3986 N1 is N + 1,
3987 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3989 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3990 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3991 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3992 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3994 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3995 Clause = (Head :- Body),
3996 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
3997 N1 is N + 1,
3998 functor(Head,Symbol,N1),
3999 arg(1,Head,IndexPattern),
4000 Head =.. [_,_|RestArgs],
4001 once(append(Vs,[Result],RestArgs)),
4002 /* IndexPattern = F() */
4003 functor(IndexPattern,F,A),
4004 IndexPattern =.. [_|Args],
4005 append(Args,RestArgs,RecArgs),
4006 ( RecArgs == [Result] ->
4007 /* nothing more to match on */
4008 List = Tail,
4009 Body = true,
4010 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4011 MoreResults = [Result]
4012 ; /* more things to match on */
4013 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4014 ( MoreCases = [OneMoreCase] ->
4015 /* only one more thing to match on */
4016 List = Tail,
4017 Body = true,
4018 append([Cases,OneMoreCase,MoreResults],RecArgs)
4019 ;
4020 /* more than one thing to match on */
4021 /* [ x1,..., xn]
4022 [xs1,...,xsn]
4023 */
4024 pairup(Cases,MoreCases,CasePairs),
4025 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4026 append(Args,Vs,[First|Rest]),
4027 First-Rest = CommonPatternPair,
4028 % Body = RSymbol(DiffVars,Result)
4029 gensym(Prefix,RSymbol),
4030 append(DiffVars,[Result],RecCallVars),
4031 Body =.. [RSymbol|RecCallVars],
4032 maplist(head_tail,Differences,CHs,CTs),
4033 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4034 )
4035 ).
4037 head_tail([H|T],H,T).
4039 rec_cases([],[],[],_,[],[],[]).
4040 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4041 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4042 Cases = [Case|NCases],
4043 MoreCases = [MoreCase|NMoreCases],
4044 MoreResults = [Result|NMoreResults],
4045 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4046 ;
4047 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4048 ).
4049 % }}}
4051 %% common_pattern(+terms,-term,-vars,-differences) is det.
4052 common_pattern(Ts,T,Vars,Differences) :-
4053 fold1(gct,Ts,T),
4054 term_variables(T,Vars),
4055 findall(Vars,member(T,Ts),Differences).
4057 gct(T1,T2,T) :-
4058 gct_(T1,T2,T,[],_).
4060 gct_(T1,T2,T,Dict0,Dict) :-
4061 ( nonvar(T1),
4062 nonvar(T2),
4063 functor(T1,F1,A1),
4064 functor(T2,F2,A2),
4065 F1 == F2,
4066 A1 == A2 ->
4067 functor(T,F1,A1),
4068 T1 =.. [_|Args1],
4069 T2 =.. [_|Args2],
4070 T =.. [_|Args],
4071 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4072 ;
4073 /* T is a variable */
4074 ( lookup_eq(Dict0,T1+T2,T) ->
4075 /* we already have a variable for this difference */
4076 Dict = Dict0
4077 ;
4078 /* T is a fresh variable */
4079 Dict = [(T1+T2)-T|Dict0]
4080 )
4081 ).
4084 fold1(P,[Head|Tail],Result) :-
4085 fold(Tail,P,Head,Result).
4087 fold([],_,Acc,Acc).
4088 fold([X|Xs],P,Acc,Res) :-
4089 call(P,X,Acc,NAcc),
4090 fold(Xs,P,NAcc,Res).
4092 maplist_dcg(P,L1,L2,L) -->
4093 maplist_dcg_(L1,L2,L,P).
4095 maplist_dcg_([],[],[],_) --> [].
4096 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4097 call(P,X,Y,Z),
4098 maplist_dcg_(Xs,Ys,Zs,P).
4099 %-------------------------------------------------------------------------------
4100 global_list_store_name(F/A,Name) :-
4101 get_target_module(Mod),
4102 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4103 global_ground_store_name(F/A,Name) :-
4104 get_target_module(Mod),
4105 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4106 global_singleton_store_name(F/A,Name) :-
4107 get_target_module(Mod),
4108 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4110 identifier_store_name(TypeName,Name) :-
4111 get_target_module(Mod),
4112 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4114 :- chr_constraint prolog_global_variable/1.
4115 :- chr_option(mode,prolog_global_variable(+)).
4117 :- chr_constraint prolog_global_variables/1.
4118 :- chr_option(mode,prolog_global_variables(-)).
4120 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4122 prolog_global_variables(List), prolog_global_variable(Name) <=>
4123 List = [Name|Tail],
4124 prolog_global_variables(Tail).
4125 prolog_global_variables(List) <=> List = [].
4127 %% SWI begin
4128 prolog_global_variables_code(Code) :-
4129 prolog_global_variables(Names),
4130 ( Names == [] ->
4131 Code = []
4132 ;
4133 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4134 Code = [(:- dynamic user:exception/3),
4135 (:- multifile user:exception/3),
4136 (user:exception(undefined_global_variable,Name,retry) :-
4137 (
4138 '$chr_prolog_global_variable'(Name),
4139 '$chr_initialization'
4140 )
4141 )
4142 |
4143 NameDeclarations
4144 ]
4145 ).
4146 %% SWI end
4147 %% SICStus begin
4148 % prolog_global_variables_code([]).
4149 %% SICStus end
4150 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4151 %sbag_member_call(S,L,sysh:mem(S,L)).
4152 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4153 %sbag_member_call(S,L,member(S,L)).
4154 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4155 %update_mutable_call(A,B,setarg(1, B, A)).
4156 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4157 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4159 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4160 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4161 % create_get_mutable(Value,Field,Get1).
4162 %
4163 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4164 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4165 % update_mutable_call(NewValue,Field,Set).
4166 %
4167 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4168 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4169 % create_get_mutable_ref(Value,Field,Get1),
4170 % update_mutable_call(NewValue,Field,Set).
4171 %
4172 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4173 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4174 % create_mutable_call(Value,Field,Create).
4175 %
4176 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4177 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4178 % create_get_mutable(Value,Field,Get).
4179 %
4180 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4181 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4182 % create_get_mutable_ref(Value,Field,Get),
4183 % update_mutable_call(NewValue,Field,Set).
4185 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4186 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4188 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4189 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4191 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4192 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4193 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4195 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4196 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4198 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4199 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4201 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4202 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4203 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4205 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4207 enumerate_stores_code(Constraints,Clause) :-
4208 Head = '$enumerate_constraints'(Constraint),
4209 enumerate_store_bodies(Constraints,Constraint,Bodies),
4210 list2disj(Bodies,Body),
4211 Clause = (Head :- Body).
4213 enumerate_store_bodies([],_,[]).
4214 enumerate_store_bodies([C|Cs],Constraint,L) :-
4215 ( is_stored(C) ->
4216 get_store_type(C,StoreType),
4217 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4218 true
4219 ;
4220 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4221 ),
4222 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4223 C = F/_,
4224 Constraint0 =.. [F|Arguments],
4225 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4226 L = [Body|T]
4227 ;
4228 L = T
4229 ),
4230 enumerate_store_bodies(Cs,Constraint,T).
4232 enumerate_store_body(default,C,Susp,Body) :-
4233 global_list_store_name(C,StoreName),
4234 sbag_member_call(Susp,List,Sbag),
4235 make_get_store_goal(StoreName,List,GetStoreGoal),
4236 Body =
4237 (
4238 GetStoreGoal, % nb_getval(StoreName,List),
4239 Sbag
4240 ).
4241 % get_constraint_index(C,Index),
4242 % get_target_module(Mod),
4243 % get_max_constraint_index(MaxIndex),
4244 % Body1 =
4245 % (
4246 % 'chr default_store'(GlobalStore),
4247 % get_attr(GlobalStore,Mod,Attr)
4248 % ),
4249 % ( MaxIndex > 1 ->
4250 % NIndex is Index + 1,
4251 % sbag_member_call(Susp,List,Sbag),
4252 % Body2 =
4253 % (
4254 % arg(NIndex,Attr,List),
4255 % Sbag
4256 % )
4257 % ;
4258 % sbag_member_call(Susp,Attr,Sbag),
4259 % Body2 = Sbag
4260 % ),
4261 % Body = (Body1,Body2).
4262 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4263 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4264 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4265 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4266 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4267 Completeness == complete, % fail if incomplete
4268 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4269 list2disj(Disjuncts, Disjunction),
4270 Body = ( Disjunction, member(Susp,Susps) ).
4271 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4272 constants_store_name(C,Index,Constant,StoreName).
4274 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4275 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4276 enumerate_store_body(global_ground,C,Susp,Body) :-
4277 global_ground_store_name(C,StoreName),
4278 sbag_member_call(Susp,List,Sbag),
4279 make_get_store_goal(StoreName,List,GetStoreGoal),
4280 Body =
4281 (
4282 GetStoreGoal, % nb_getval(StoreName,List),
4283 Sbag
4284 ).
4285 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4286 Body = fail.
4287 enumerate_store_body(global_singleton,C,Susp,Body) :-
4288 global_singleton_store_name(C,StoreName),
4289 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4290 Body =
4291 (
4292 GetStoreGoal, % nb_getval(StoreName,Susp),
4293 Susp \== []
4294 ).
4295 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4296 once((
4297 member(ST,STs),
4298 enumerate_store_body(ST,C,Susp,Body)
4299 )).
4300 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4301 Body = fail.
4302 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4303 Body = fail.
4305 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4306 multi_hash_store_name(C,I,StoreName),
4307 B =
4308 (
4309 nb_getval(StoreName,HT),
4310 value_iht(HT,Susp)
4311 ).
4312 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4313 multi_hash_store_name(C,I,StoreName),
4314 make_get_store_goal(StoreName,HT,GetStoreGoal),
4315 B =
4316 (
4317 GetStoreGoal, % nb_getval(StoreName,HT),
4318 value_ht(HT,Susp)
4319 ).
4321 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4322 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4323 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4325 :- chr_constraint
4326 background_info/1,
4327 background_info/2,
4328 get_bg_info/1,
4329 get_bg_info/2,
4330 get_bg_info_answer/1.
4332 background_info(X), background_info(Y) <=>
4333 append(X,Y,XY), background_info(XY).
4334 background_info(X) \ get_bg_info(Q) <=> Q=X.
4335 get_bg_info(Q) <=> Q = [].
4337 background_info(T,I), get_bg_info(A,Q) ==>
4338 copy_term_nat(T,T1),
4339 subsumes_chk(T1,A)
4340 |
4341 copy_term_nat(T-I,A-X),
4342 get_bg_info_answer([X]).
4343 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4344 append(X,Y,XY), get_bg_info_answer(XY).
4346 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4347 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4352 :- chr_constraint
4353 prev_guard_list/8,
4354 prev_guard_list/6,
4355 simplify_guards/1,
4356 set_all_passive/1.
4358 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4359 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4360 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4361 :- chr_option(mode,simplify_guards(+)).
4362 :- chr_option(mode,set_all_passive(+)).
4364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4365 % GUARD SIMPLIFICATION
4366 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4367 % If the negation of the guards of earlier rules entails (part of)
4368 % the current guard, the current guard can be simplified. We can only
4369 % use earlier rules with a head that matches if the head of the current
4370 % rule does, and which make it impossible for the current rule to match
4371 % if they fire (i.e. they shouldn't be propagation rules and their
4372 % head constraints must be subsets of those of the current rule).
4373 % At this point, we know for sure that the negation of the guard
4374 % of such a rule has to be true (otherwise the earlier rule would have
4375 % fired, because of the refined operational semantics), so we can use
4376 % that information to simplify the guard by replacing all entailed
4377 % conditions by true/0. As a consequence, the never-stored analysis
4378 % (in a further phase) will detect more cases of never-stored constraints.
4379 %
4380 % e.g. c(X),d(Y) <=> X > 0 | ...
4381 % e(X) <=> X < 0 | ...
4382 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4383 % \____________/
4384 % true
4386 guard_simplification :-
4387 ( chr_pp_flag(guard_simplification,on) ->
4388 precompute_head_matchings,
4389 simplify_guards(1)
4390 ;
4391 true
4392 ).
4394 % for every rule, we create a prev_guard_list where the last argument
4395 % eventually is a list of the negations of earlier guards
4396 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4397 <=>
4398 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4399 append(Head1,Head2,Heads),
4400 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4401 tree_set_empty(Done),
4402 multiple_occ_constraints_checked(Done),
4403 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4405 append(IDs1,IDs2,IDs),
4406 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4407 empty_q(EmptyHeap),
4408 insert_list_q(HeapData,EmptyHeap,Heap),
4409 next_prev_rule(Heap,_,Heap1),
4410 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4411 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4412 NextRule is RuleNb+1,
4413 simplify_guards(NextRule).
4415 next_prev_rule(Heap,RuleNb,NHeap) :-
4416 ( find_min_q(Heap,_-Priority) ->
4417 Priority = (-RuleNb),
4418 normalize_heap(Heap,Priority,NHeap)
4419 ;
4420 RuleNb = 0,
4421 NHeap = Heap
4422 ).
4424 normalize_heap(Heap,Priority,NHeap) :-
4425 ( find_min_q(Heap,_-Priority) ->
4426 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4427 ( O > 1 ->
4428 NO is O -1,
4429 get_occurrence(C,NO,RuleNb,_),
4430 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4431 ;
4432 Heap2 = Heap1
4433 ),
4434 normalize_heap(Heap2,Priority,NHeap)
4435 ;
4436 NHeap = Heap
4437 ).
4439 % no more rule
4440 simplify_guards(_)
4441 <=>
4442 true.
4444 % The negation of the guard of a non-propagation rule is added
4445 % if its kept head constraints are a subset of the kept constraints of
4446 % the rule we're working on, and its removed head constraints (at least one)
4447 % are a subset of the removed constraints.
4449 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4450 <=>
4451 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4452 H1 \== [],
4453 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4454 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4455 |
4456 append(H1,H2,Heads),
4457 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4458 append(GuardList,DerivedInfo,GL1),
4459 normalize_conj_list(GL1,GL),
4460 append(GH_New1,GH,GH1),
4461 normalize_conj_list(GH1,GH_New),
4462 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4463 % PrevPrevRuleNb is PrevRuleNb-1,
4464 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4466 % if this isn't the case, we skip this one and try the next rule
4467 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4468 <=>
4469 ( N > 0 ->
4470 next_prev_rule(Heap,N1,NHeap),
4471 % N1 is N-1,
4472 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4473 ;
4474 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4475 ).
4477 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4478 <=>
4479 GH \== []
4480 |
4481 head_types_modes_condition(GH,H,TypeInfo),
4482 conj2list(TypeInfo,TI),
4483 term_variables(H,HeadVars),
4484 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4485 normalize_conj_list(Info,InfoL),
4486 append(H,InfoL,RelevantTerms),
4487 add_background_info([G|RelevantTerms],BGInfo),
4488 append(InfoL,BGInfo,AllInfo_),
4489 normalize_conj_list(AllInfo_,AllInfo),
4490 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4492 head_types_modes_condition([],H,true).
4493 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4494 types_modes_condition(H,GH,TI1),
4495 head_types_modes_condition(GHs,H,TI2).
4497 add_background_info(Term,Info) :-
4498 get_bg_info(GeneralInfo),
4499 add_background_info2(Term,TermInfo),
4500 append(GeneralInfo,TermInfo,Info).
4502 add_background_info2(X,[]) :- var(X), !.
4503 add_background_info2([],[]) :- !.
4504 add_background_info2([X|Xs],Info) :- !,
4505 add_background_info2(X,Info1),
4506 add_background_info2(Xs,Infos),
4507 append(Info1,Infos,Info).
4509 add_background_info2(X,Info) :-
4510 (functor(X,_,A), A>0 ->
4511 X =.. [_|XArgs],
4512 add_background_info2(XArgs,XArgInfo)
4513 ;
4514 XArgInfo = []
4515 ),
4516 get_bg_info(X,XInfo),
4517 append(XInfo,XArgInfo,Info).
4519 %%
4520 % when all earlier guards are added or skipped, we simplify the guard.
4521 % if it's different from the original one, we change the rule
4523 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4524 <=>
4525 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4526 G \== true, % let's not try to simplify this ;)
4527 append(M,GuardList,Info),
4528 (% if guard + context is a contradiction, it should be simplified to "fail"
4529 conj2list(G,GL), append(Info,GL,GuardWithContext),
4530 guard_entailment:entails_guard(GuardWithContext,fail) ->
4531 SimpleGuard = fail
4532 ;
4533 % otherwise we try to remove redundant conjuncts
4534 simplify_guard(G,B,Info,SimpleGuard,NB)
4535 ),
4536 G \== SimpleGuard % only do this if we can change the guard
4537 |
4538 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4539 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4541 %% normalize_conj_list(+List,-NormalList) is det.
4542 %
4543 % Removes =true= elements and flattens out conjunctions.
4545 normalize_conj_list(List,NormalList) :-
4546 list2conj(List,Conj),
4547 conj2list(Conj,NormalList).
4549 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4550 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4551 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4553 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4554 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4555 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4556 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4557 append(Renaming1,ExtraRenaming,Renaming2),
4558 list2conj(PrevMatchings,Match),
4559 negate_b(Match,HeadsDontMatch),
4560 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4561 list2conj(HeadsMatch,HeadsMatchBut),
4562 term_variables(Renaming2,RenVars),
4563 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4564 new_vars(MGVars,RenVars,ExtraRenaming2),
4565 append(Renaming2,ExtraRenaming2,Renaming),
4566 ( PrevGuard == true -> % true can't fail
4567 Info_ = HeadsDontMatch
4568 ;
4569 negate_b(PrevGuard,TheGuardFailed),
4570 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4571 ),
4572 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4573 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4574 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4575 list2conj(RenamedMatchings_,RenamedMatchings),
4576 apply_guard_wrt_term(H,RenamedG2,GH2),
4577 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4578 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4580 simplify_guard(G,B,Info,SG,NB) :-
4581 conj2list(G,LG),
4582 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4583 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4584 list2conj(SGL,SG).
4587 new_vars([],_,[]).
4588 new_vars([A|As],RV,ER) :-
4589 ( memberchk_eq(A,RV) ->
4590 new_vars(As,RV,ER)
4591 ;
4592 ER = [A-NewA,NewA-A|ER2],
4593 new_vars(As,RV,ER2)
4594 ).
4596 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4597 %
4598 % check if a list of constraints is a subset of another list of constraints
4599 % (multiset-subset), meanwhile computing a variable renaming to convert
4600 % one into the other.
4601 head_subset(H,Head,Renaming) :-
4602 head_subset(H,Head,Renaming,[],_).
4604 head_subset([],Remainder,Renaming,Renaming,Remainder).
4605 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4606 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4607 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4609 % check if A is in the list, remove it from Headleft
4610 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4611 ( variable_replacement(A,X,Acc,Renaming),
4612 Remainder = Xs
4613 ;
4614 Remainder = [X|RRemainder],
4615 head_member(Xs,A,Renaming,Acc,RRemainder)
4616 ).
4617 %-------------------------------------------------------------------------------%
4618 % memoing code to speed up repeated computation
4620 :- chr_constraint precompute_head_matchings/0.
4622 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4623 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4624 append(H1,H2,Heads),
4625 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4626 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4627 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4629 precompute_head_matchings <=> true.
4631 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4632 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4634 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4635 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4637 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4638 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4639 <=>
4640 Q1 = NHeads,
4641 Q2 = Matchings.
4642 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4644 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4645 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4646 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4647 %-------------------------------------------------------------------------------%
4649 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4650 extract_arguments(Heads,Arguments),
4651 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4652 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4654 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4655 extract_arguments(Heads,Arguments),
4656 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4657 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4659 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4660 extract_arguments(Heads,Arguments1),
4661 extract_arguments(MatchingFreeHeads,Arguments2),
4662 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4664 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4665 %
4666 % Returns list of arguments of given list of constraints.
4667 extract_arguments([],[]).
4668 extract_arguments([Constraint|Constraints],AllArguments) :-
4669 Constraint =.. [_|Arguments],
4670 append(Arguments,RestArguments,AllArguments),
4671 extract_arguments(Constraints,RestArguments).
4673 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4674 %
4675 % Substitutes arguments of constraints with those in the given list.
4677 substitute_arguments([],[],[]).
4678 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4679 functor(Constraint,F,N),
4680 split_at(N,Variables,Arguments,RestVariables),
4681 NConstraint =.. [F|Arguments],
4682 substitute_arguments(Constraints,RestVariables,NConstraints).
4684 make_matchings_explicit([],[],_,MC,MC,[]).
4685 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4686 ( var(Arg) ->
4687 ( memberchk_eq(Arg,VarAcc) ->
4688 list2disj(MatchingCondition,MatchingCondition_disj),
4689 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4690 NVarAcc = VarAcc
4691 ;
4692 Matchings = RestMatchings,
4693 NewVar = Arg,
4694 NVarAcc = [Arg|VarAcc]
4695 ),
4696 MatchingCondition2 = MatchingCondition
4697 ;
4698 functor(Arg,F,A),
4699 Arg =.. [F|RecArgs],
4700 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4701 FlatArg =.. [F|RecVars],
4702 ( RecMatchings == [] ->
4703 Matchings = [functor(NewVar,F,A)|RestMatchings]
4704 ;
4705 list2conj(RecMatchings,ArgM_conj),
4706 list2disj(MatchingCondition,MatchingCondition_disj),
4707 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4708 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4709 ),
4710 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4711 term_variables(Args,ArgVars),
4712 append(ArgVars,VarAcc,NVarAcc)
4713 ),
4714 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4717 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4718 %
4719 % Returns list of new variables and list of pairwise unifications between given list and variables.
4721 make_matchings_explicit_not_negated([],[],[]).
4722 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4723 Matchings = [Var = X|RMatchings],
4724 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4726 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4727 %
4728 % (Partially) applies substitutions of =Goal= to given list.
4730 apply_guard_wrt_term([],_Guard,[]).
4731 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4732 ( var(Term) ->
4733 apply_guard_wrt_variable(Guard,Term,NTerm)
4734 ;
4735 Term =.. [F|HArgs],
4736 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4737 NTerm =.. [F|NewHArgs]
4738 ),
4739 apply_guard_wrt_term(RH,Guard,RGH).
4741 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4742 %
4743 % (Partially) applies goal =Guard= wrt variable.
4745 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4746 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4747 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4748 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4749 ( Guard = (X = Y), Variable == X ->
4750 NVariable = Y
4751 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4752 functor(NVariable,Functor,Arity)
4753 ;
4754 NVariable = Variable
4755 ).
4758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4759 % ALWAYS FAILING GUARDS
4760 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4762 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4763 ==>
4764 chr_pp_flag(check_impossible_rules,on),
4765 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4766 conj2list(G,GL),
4767 append(M,GuardList,Info),
4768 append(Info,GL,GuardWithContext),
4769 guard_entailment:entails_guard(GuardWithContext,fail)
4770 |
4771 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4772 set_all_passive(RuleNb).
4774 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4775 % HEAD SIMPLIFICATION
4776 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4778 % now we check the head matchings (guard may have been simplified meanwhile)
4779 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4780 <=>
4781 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4782 simplify_heads(M,GuardList,G,B,NewM,NewB),
4783 NewM \== [],
4784 extract_arguments(Head1,VH1),
4785 extract_arguments(Head2,VH2),
4786 extract_arguments(H,VH),
4787 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4788 substitute_arguments(Head1,H1,NewH1),
4789 substitute_arguments(Head2,H2,NewH2),
4790 append(NewB,NewB_,NewBody),
4791 list2conj(NewBody,BodyMatchings),
4792 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4793 (Head1 \== NewH1 ; Head2 \== NewH2 )
4794 |
4795 rule(RuleNb,NewRule).
4797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4798 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4799 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4801 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4802 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4803 ( NH == M ->
4804 H2_ = M,
4805 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4806 ;
4807 (M = functor(X,F,A), NH == X ->
4808 length(A_args,A),
4809 (var(H2) ->
4810 NewB1 = [],
4811 H2_ =.. [F|A_args]
4812 ;
4813 H2 =.. [F|OrigArgs],
4814 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4815 H2_ =.. [F|A_args_]
4816 ),
4817 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4818 append(NewB1,NewB2,NewB)
4819 ;
4820 H2_ = H2,
4821 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4822 )
4823 ).
4825 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4826 ( NH == M ->
4827 H1_ = M,
4828 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4829 ;
4830 (M = functor(X,F,A), NH == X ->
4831 length(A_args,A),
4832 (var(H1) ->
4833 NewB1 = [],
4834 H1_ =.. [F|A_args]
4835 ;
4836 H1 =.. [F|OrigArgs],
4837 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4838 H1_ =.. [F|A_args_]
4839 ),
4840 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4841 append(NewB1,NewB2,NewB)
4842 ;
4843 H1_ = H1,
4844 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4845 )
4846 ).
4848 use_same_args([],[],[],_,_,[]).
4849 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4850 var(OA),!,
4851 Out = OA,
4852 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4853 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4854 nonvar(OA),!,
4855 ( common_variables(OA,Body) ->
4856 NewB = [NA = OA|NextB]
4857 ;
4858 NewB = NextB
4859 ),
4860 Out = NA,
4861 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4864 simplify_heads([],_GuardList,_G,_Body,[],[]).
4865 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4866 M = (A = B),
4867 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4868 guard_entailment:entails_guard(GuardList,(A=B)) ->
4869 ( common_variables(B,G-RM-GuardList) ->
4870 NewB = NextB,
4871 NewM = NextM
4872 ;
4873 ( common_variables(B,Body) ->
4874 NewB = [A = B|NextB]
4875 ;
4876 NewB = NextB
4877 ),
4878 NewM = [A|NextM]
4879 )
4880 ;
4881 ( nonvar(B), functor(B,BFu,BAr),
4882 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4883 NewB = NextB,
4884 ( common_variables(B,G-RM-GuardList) ->
4885 NewM = NextM
4886 ;
4887 NewM = [functor(A,BFu,BAr)|NextM]
4888 )
4889 ;
4890 NewM = NextM,
4891 NewB = NextB
4892 )
4893 ),
4894 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4896 common_variables(B,G) :-
4897 term_variables(B,BVars),
4898 term_variables(G,GVars),
4899 intersect_eq(BVars,GVars,L),
4900 L \== [].
4903 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4904 set_all_passive(_) <=> true.
4908 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4909 % OCCURRENCE SUBSUMPTION
4910 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4912 :- chr_constraint
4913 first_occ_in_rule/4,
4914 next_occ_in_rule/6.
4916 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4917 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4919 :- chr_constraint multiple_occ_constraints_checked/1.
4920 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4922 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4923 occurrence(C,O,RuleNb,ID,_),
4924 occurrence(C,O2,RuleNb,ID2,_),
4925 rule(RuleNb,Rule)
4926 \
4927 multiple_occ_constraints_checked(Done)
4928 <=>
4929 O < O2,
4930 chr_pp_flag(occurrence_subsumption,on),
4931 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4932 H1 \== [],
4933 \+ tree_set_memberchk(C,Done)
4934 |
4935 first_occ_in_rule(RuleNb,C,O,ID),
4936 tree_set_add(Done,C,NDone),
4937 multiple_occ_constraints_checked(NDone).
4939 % Find first occurrence of constraint =C= in rule =RuleNb=
4940 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4941 <=>
4942 O < O2
4943 |
4944 first_occ_in_rule(RuleNb,C,O,ID).
4946 first_occ_in_rule(RuleNb,C,O,ID_o1)
4947 <=>
4948 C = F/A,
4949 functor(FreshHead,F,A),
4950 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4952 % Skip passive occurrences.
4953 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4954 <=>
4955 O2 is O+1
4956 |
4957 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4959 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)
4960 <=>
4961 O2 is O+1,
4962 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4963 |
4964 append(H1,H2,Heads),
4965 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4966 ( ExtraCond == [chr_pp_void_info] ->
4967 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4968 ;
4969 append(ExtraCond,Cond,NewCond),
4970 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4971 copy_term(GuardList,FGuardList),
4972 variable_replacement(GuardList,FGuardList,GLRepl),
4973 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4974 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4975 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4976 append(NewCond,GuardList2,BigCond),
4977 append(BigCond,GuardList3,BigCond2),
4978 copy_with_variable_replacement(M,M2,Repl),
4979 copy_with_variable_replacement(M,M3,Repl2),
4980 append(M3,BigCond2,BigCond3),
4981 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4982 list2conj(CheckCond,OccSubsum),
4983 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4984 ( OccSubsum \= chr_pp_void_info ->
4985 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4986 passive(RuleNb,ID_o2)
4987 ;
4988 true
4989 )
4990 ;
4991 true
4992 ),!,
4993 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4994 ).
4997 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4998 <=>
4999 true.
5001 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5002 <=>
5003 true.
5005 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5006 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5007 append(ID2,ID1,IDs),
5008 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5009 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5010 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5011 copy_with_variable_replacement(G,FG,Repl),
5012 extract_explicit_matchings(FG,FG2),
5013 negate_b(FG2,NotFG),
5014 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5015 ( subsumes(FH,FH2) ->
5016 FailCond = [(NotFG;FMPCond)]
5017 ;
5018 % in this case, not much can be done
5019 % e.g. c(f(...)), c(g(...)) <=> ...
5020 FailCond = [chr_pp_void_info]
5021 ).
5023 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5024 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5025 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5026 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5027 Cond = (chr_pp_not_in_store(H);Cond1),
5028 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5030 extract_explicit_matchings((A,B),D) :- !,
5031 ( extract_explicit_matchings(A) ->
5032 extract_explicit_matchings(B,D)
5033 ;
5034 D = (A,E),
5035 extract_explicit_matchings(B,E)
5036 ).
5037 extract_explicit_matchings(A,D) :- !,
5038 ( extract_explicit_matchings(A) ->
5039 D = true
5040 ;
5041 D = A
5042 ).
5044 extract_explicit_matchings(A=B) :-
5045 var(A), var(B), !, A=B.
5046 extract_explicit_matchings(A==B) :-
5047 var(A), var(B), !, A=B.
5049 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5050 % TYPE INFORMATION
5051 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5053 :- chr_constraint
5054 type_definition/2,
5055 type_alias/2,
5056 constraint_type/2,
5057 get_type_definition/2,
5058 get_constraint_type/2.
5061 :- chr_option(mode,type_definition(?,?)).
5062 :- chr_option(mode,get_type_definition(?,?)).
5063 :- chr_option(mode,type_alias(?,?)).
5064 :- chr_option(mode,constraint_type(+,+)).
5065 :- chr_option(mode,get_constraint_type(+,-)).
5067 assert_constraint_type(Constraint,ArgTypes) :-
5068 ( ground(ArgTypes) ->
5069 constraint_type(Constraint,ArgTypes)
5070 ;
5071 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5072 ).
5074 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5075 % Consistency checks of type aliases
5077 type_alias(T1,T2) <=>
5078 var(T1)
5079 |
5080 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5082 type_alias(T1,T2) <=>
5083 var(T2)
5084 |
5085 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5087 type_alias(T,T2) <=>
5088 functor(T,F,A),
5089 functor(T2,F,A),
5090 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5091 |
5092 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5094 type_alias(T1,A1), type_alias(T2,A2) <=>
5095 functor(T1,F,A),
5096 functor(T2,F,A),
5097 \+ (T1\=T2)
5098 |
5099 copy_term_nat(T1,T1_),
5100 copy_term_nat(T2,T2_),
5101 T1_ = T2_,
5102 chr_error(type_error,
5103 '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_]).
5105 type_alias(T,B) \ type_alias(X,T2) <=>
5106 functor(T,F,A),
5107 functor(T2,F,A),
5108 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5109 subsumes(T1,T3)
5110 |
5111 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5112 type_alias(X2,D1).
5114 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5115 % Consistency checks of type definitions
5117 type_definition(T1,_), type_definition(T2,_)
5118 <=>
5119 functor(T1,F,A), functor(T2,F,A)
5120 |
5121 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5123 type_definition(T1,_), type_alias(T2,_)
5124 <=>
5125 functor(T1,F,A), functor(T2,F,A)
5126 |
5127 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5129 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5130 %% get_type_definition(+Type,-Definition) is semidet.
5131 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5133 get_type_definition(T,Def)
5134 <=>
5135 \+ ground(T)
5136 |
5137 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5139 type_alias(T,D) \ get_type_definition(T2,Def)
5140 <=>
5141 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5142 copy_term_nat((T,D),(T1,D1)),T1=T2
5143 |
5144 ( get_type_definition(D1,Def) ->
5145 true
5146 ;
5147 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5148 ).
5150 type_definition(T,D) \ get_type_definition(T2,Def)
5151 <=>
5152 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5153 copy_term_nat((T,D),(T1,D1)),T1=T2
5154 |
5155 Def = D1.
5157 get_type_definition(Type,Def)
5158 <=>
5159 atomic_builtin_type(Type,_,_)
5160 |
5161 Def = [Type].
5163 get_type_definition(Type,Def)
5164 <=>
5165 compound_builtin_type(Type,_,_,_)
5166 |
5167 Def = [Type].
5169 get_type_definition(X,Y) <=> fail.
5171 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5172 %% get_type_definition_det(+Type,-Definition) is det.
5173 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5174 get_type_definition_det(Type,Definition) :-
5175 ( get_type_definition(Type,Definition) ->
5176 true
5177 ;
5178 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5179 ).
5181 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5182 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5183 %
5184 % Return argument types of =ConstraintSymbol=, but fails if none where
5185 % declared.
5186 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5187 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5188 get_constraint_type(_,_) <=> fail.
5190 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5191 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5192 %
5193 % Like =get_constraint_type/2=, but returns list of =any= types when
5194 % no types are declared.
5195 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5196 get_constraint_type_det(ConstraintSymbol,Types) :-
5197 ( get_constraint_type(ConstraintSymbol,Types) ->
5198 true
5199 ;
5200 ConstraintSymbol = _ / N,
5201 replicate(N,any,Types)
5202 ).
5203 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5204 %% unalias_type(+Alias,-Type) is det.
5205 %
5206 % Follows alias chain until base type is reached.
5207 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5208 :- chr_constraint unalias_type/2.
5210 unalias_var @
5211 unalias_type(Alias,BaseType)
5212 <=>
5213 var(Alias)
5214 |
5215 BaseType = Alias.
5217 unalias_alias @
5218 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5219 <=>
5220 nonvar(AliasProtoType),
5221 nonvar(Alias),
5222 functor(AliasProtoType,F,A),
5223 functor(Alias,F,A),
5224 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5225 Alias = AliasInstance
5226 |
5227 unalias_type(Type,BaseType).
5229 unalias_type_definition @
5230 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5231 <=>
5232 nonvar(ProtoType),
5233 nonvar(Alias),
5234 functor(ProtoType,F,A),
5235 functor(Alias,F,A)
5236 |
5237 BaseType = Alias.
5239 unalias_atomic_builtin @
5240 unalias_type(Alias,BaseType)
5241 <=>
5242 atomic_builtin_type(Alias,_,_)
5243 |
5244 BaseType = Alias.
5246 unalias_compound_builtin @
5247 unalias_type(Alias,BaseType)
5248 <=>
5249 compound_builtin_type(Alias,_,_,_)
5250 |
5251 BaseType = Alias.
5253 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5254 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5255 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5256 :- chr_constraint types_modes_condition/3.
5257 :- chr_option(mode,types_modes_condition(+,+,?)).
5258 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5260 types_modes_condition([],[],T) <=> T=true.
5262 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5263 <=>
5264 functor(Head,F,A)
5265 |
5266 Head =.. [_|Args],
5267 Condition = (ModesCondition, TypesCondition, RestCondition),
5268 modes_condition(Modes,Args,ModesCondition),
5269 get_constraint_type_det(F/A,Types),
5270 UnrollHead =.. [_|RealArgs],
5271 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5272 types_modes_condition(Heads,UnrollHeads,RestCondition).
5274 types_modes_condition([Head|_],_,_)
5275 <=>
5276 functor(Head,F,A),
5277 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5280 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5281 %% modes_condition(+Modes,+Args,-Condition) is det.
5282 %
5283 % Return =Condition= on =Args= that checks =Modes=.
5284 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5285 modes_condition([],[],true).
5286 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5287 ( Mode == (+) ->
5288 Condition = ( ground(Arg) , RCondition )
5289 ; Mode == (-) ->
5290 Condition = ( var(Arg) , RCondition )
5291 ;
5292 Condition = RCondition
5293 ),
5294 modes_condition(Modes,Args,RCondition).
5296 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5297 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5298 %
5299 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5300 % =UnrollArgs= controls the depth of type definition unrolling.
5301 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5302 types_condition([],[],[],[],true).
5303 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5304 ( Mode == (-) ->
5305 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5306 ;
5307 get_type_definition_det(Type,Def),
5308 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5309 ( Mode == (+) ->
5310 TypeConditionList = TypeConditionList1
5311 ;
5312 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5313 )
5314 ),
5315 list2disj(TypeConditionList,DisjTypeConditionList),
5316 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5318 type_condition([],_,_,_,[]).
5319 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5320 ( var(DefCase) ->
5321 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5322 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5323 true
5324 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5325 true
5326 ;
5327 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5328 ),
5329 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5331 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5332 :- chr_type atomic_builtin_type ---> any
5333 ; number
5334 ; float
5335 ; int
5336 ; natural
5337 ; dense_int
5338 ; chr_identifier
5339 ; chr_identifier(any)
5340 ; /* all possible values are given */
5341 chr_enum(list(any))
5342 ; /* all possible values appear in rule heads;
5343 to distinguish between multiple chr_constants
5344 we have a key*/
5345 chr_constants(any).
5346 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5348 atomic_builtin_type(any,_Arg,true).
5349 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5350 atomic_builtin_type(int,Arg,integer(Arg)).
5351 atomic_builtin_type(number,Arg,number(Arg)).
5352 atomic_builtin_type(float,Arg,float(Arg)).
5353 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5354 atomic_builtin_type(chr_identifier,_Arg,true).
5356 compound_builtin_type(chr_constants(_),_Arg,true,true).
5357 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5358 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5359 once(( member(Constant,Constants),
5360 unifiable(Arg,Constant,_)
5361 )
5362 )
5363 ).
5365 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5366 ( nonvar(DefCase) ->
5367 functor(DefCase,F,A),
5368 ( A == 0 ->
5369 Condition = (Arg = DefCase)
5370 ; var(UnrollArg) ->
5371 Condition = functor(Arg,F,A)
5372 ; functor(UnrollArg,F,A) ->
5373 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5374 DefCase =.. [_|ArgTypes],
5375 UnrollArg =.. [_|UnrollArgs],
5376 functor(Template,F,A),
5377 Template =.. [_|TemplateArgs],
5378 replicate(A,Mode,ArgModes),
5379 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5380 ;
5381 Condition = functor(Arg,F,A)
5382 )
5383 ;
5384 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5385 ).
5388 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5389 % STATIC TYPE CHECKING
5390 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5391 % Checks head constraints and CHR constraint calls in bodies.
5392 %
5393 % TODO:
5394 % - type clashes involving built-in types
5395 % - Prolog built-ins in guard and body
5396 % - indicate position in terms in error messages
5397 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5398 :- chr_constraint
5399 static_type_check/0.
5402 % 1. Check the declared types
5404 constraint_type(Constraint,ArgTypes), static_type_check
5405 ==>
5406 forall(
5407 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5408 ( get_type_definition(Type,_) ->
5409 true
5410 ;
5411 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5412 )
5413 ).
5415 % 2. Check the rules
5417 :- chr_type type_error_src ---> head(any) ; body(any).
5419 rule(_,Rule), static_type_check
5420 ==>
5421 copy_term_nat(Rule,RuleCopy),
5422 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5423 (
5424 catch(
5425 ( static_type_check_heads(Head1),
5426 static_type_check_heads(Head2),
5427 conj2list(Body,GoalList),
5428 static_type_check_body(GoalList)
5429 ),
5430 type_error(Error),
5431 ( Error = invalid_functor(Src,Term,Type) ->
5432 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5433 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5434 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5435 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5436 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5437 )
5438 ),
5439 fail % cleanup constraints
5440 ;
5441 true
5442 ).
5445 static_type_check <=> true.
5447 static_type_check_heads([]).
5448 static_type_check_heads([Head|Heads]) :-
5449 static_type_check_head(Head),
5450 static_type_check_heads(Heads).
5452 static_type_check_head(Head) :-
5453 functor(Head,F,A),
5454 get_constraint_type_det(F/A,Types),
5455 Head =..[_|Args],
5456 maplist(static_type_check_term(head(Head)),Args,Types).
5458 static_type_check_body([]).
5459 static_type_check_body([Goal|Goals]) :-
5460 functor(Goal,F,A),
5461 get_constraint_type_det(F/A,Types),
5462 Goal =..[_|Args],
5463 maplist(static_type_check_term(body(Goal)),Args,Types),
5464 static_type_check_body(Goals).
5466 :- chr_constraint static_type_check_term/3.
5467 :- chr_option(mode,static_type_check_term(?,?,?)).
5468 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5470 static_type_check_term(Src,Term,Type)
5471 <=>
5472 var(Term)
5473 |
5474 static_type_check_var(Src,Term,Type).
5475 static_type_check_term(Src,Term,Type)
5476 <=>
5477 atomic_builtin_type(Type,Term,Goal)
5478 |
5479 ( call(Goal) ->
5480 true
5481 ;
5482 throw(type_error(invalid_functor(Src,Term,Type)))
5483 ).
5484 static_type_check_term(Src,Term,Type)
5485 <=>
5486 compound_builtin_type(Type,Term,_,Goal)
5487 |
5488 ( call(Goal) ->
5489 true
5490 ;
5491 throw(type_error(invalid_functor(Src,Term,Type)))
5492 ).
5493 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5494 <=>
5495 functor(Type,F,A),
5496 functor(AType,F,A)
5497 |
5498 copy_term_nat(AType-ADef,Type-Def),
5499 static_type_check_term(Src,Term,Def).
5501 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5502 <=>
5503 functor(Type,F,A),
5504 functor(AType,F,A)
5505 |
5506 copy_term_nat(AType-ADef,Type-Variants),
5507 functor(Term,TF,TA),
5508 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5509 Term =.. [_|Args],
5510 Variant =.. [_|Types],
5511 maplist(static_type_check_term(Src),Args,Types)
5512 ;
5513 throw(type_error(invalid_functor(Src,Term,Type)))
5514 ).
5516 static_type_check_term(Src,Term,Type)
5517 <=>
5518 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5520 :- chr_constraint static_type_check_var/3.
5521 :- chr_option(mode,static_type_check_var(?,-,?)).
5522 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5524 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5525 <=>
5526 functor(AType,F,A),
5527 functor(Type,F,A)
5528 |
5529 copy_term_nat(AType-ADef,Type-Def),
5530 static_type_check_var(Src,Var,Def).
5532 static_type_check_var(Src,Var,Type)
5533 <=>
5534 atomic_builtin_type(Type,_,_)
5535 |
5536 static_atomic_builtin_type_check_var(Src,Var,Type).
5538 static_type_check_var(Src,Var,Type)
5539 <=>
5540 compound_builtin_type(Type,_,_,_)
5541 |
5542 true.
5545 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5546 <=>
5547 Type1 \== Type2
5548 |
5549 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5551 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5552 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5553 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5554 :- chr_constraint static_atomic_builtin_type_check_var/3.
5555 :- chr_option(mode,static_type_check_var(?,-,+)).
5556 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5558 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5559 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5560 <=>
5561 true.
5562 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5563 <=>
5564 true.
5565 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5566 <=>
5567 true.
5568 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5569 <=>
5570 true.
5571 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5572 <=>
5573 true.
5574 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5575 <=>
5576 true.
5577 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5578 <=>
5579 true.
5580 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5581 <=>
5582 true.
5583 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5584 <=>
5585 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5587 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5588 %% format_src(+type_error_src) is det.
5589 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5590 format_src(head(Head)) :- format('head ~w',[Head]).
5591 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5593 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5594 % Dynamic type checking
5595 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5597 :- chr_constraint
5598 dynamic_type_check/0,
5599 dynamic_type_check_clauses/1,
5600 get_dynamic_type_check_clauses/1.
5602 generate_dynamic_type_check_clauses(Clauses) :-
5603 ( chr_pp_flag(debugable,on) ->
5604 dynamic_type_check,
5605 get_dynamic_type_check_clauses(Clauses0),
5606 append(Clauses0,
5607 [('$dynamic_type_check'(Type,Term) :-
5608 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5609 )],
5610 Clauses)
5611 ;
5612 Clauses = []
5613 ).
5615 type_definition(T,D), dynamic_type_check
5616 ==>
5617 copy_term_nat(T-D,Type-Definition),
5618 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5619 dynamic_type_check_clauses(DynamicChecks).
5620 type_alias(A,B), dynamic_type_check
5621 ==>
5622 copy_term_nat(A-B,Alias-Body),
5623 dynamic_type_check_alias_clause(Alias,Body,Clause),
5624 dynamic_type_check_clauses([Clause]).
5626 dynamic_type_check <=>
5627 findall(
5628 ('$dynamic_type_check'(Type,Term) :- Goal),
5629 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5630 BuiltinChecks
5631 ),
5632 dynamic_type_check_clauses(BuiltinChecks).
5634 dynamic_type_check_clause(T,DC,Clause) :-
5635 copy_term(T-DC,Type-DefinitionClause),
5636 functor(DefinitionClause,F,A),
5637 functor(Term,F,A),
5638 DefinitionClause =.. [_|DCArgs],
5639 Term =.. [_|TermArgs],
5640 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5641 list2conj(RecursiveCallList,RecursiveCalls),
5642 Clause = (
5643 '$dynamic_type_check'(Type,Term) :-
5644 RecursiveCalls
5645 ).
5647 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5648 Clause = (
5649 '$dynamic_type_check'(Alias,Term) :-
5650 '$dynamic_type_check'(Body,Term)
5651 ).
5653 dynamic_type_check_call(Type,Term,Call) :-
5654 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5655 % Call = when(nonvar(Term),Goal)
5656 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5657 % Call = when(nonvar(Term),Goal)
5658 % ;
5659 ( Type == any ->
5660 Call = true
5661 ;
5662 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5663 )
5664 % )
5665 .
5667 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5668 <=>
5669 append(C1,C2,C),
5670 dynamic_type_check_clauses(C).
5672 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5673 <=>
5674 Q = C.
5675 get_dynamic_type_check_clauses(Q)
5676 <=>
5677 Q = [].
5679 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5680 % Atomic Types
5681 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5682 % Some optimizations can be applied for atomic types...
5683 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5685 atomic_types_suspended_constraint(C) :-
5686 C = _/N,
5687 get_constraint_type(C,ArgTypes),
5688 get_constraint_mode(C,ArgModes),
5689 findall(I,between(1,N,I),Indexes),
5690 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5692 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5693 ( is_indexed_argument(C,Index) ->
5694 ( Mode == (?) ->
5695 atomic_type(Type)
5696 ;
5697 true
5698 )
5699 ;
5700 true
5701 ).
5703 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5704 %% atomic_type(+Type) is semidet.
5705 %
5706 % Succeeds when all values of =Type= are atomic.
5707 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5708 :- chr_constraint atomic_type/1.
5710 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5712 type_definition(TypePat,Def) \ atomic_type(Type)
5713 <=>
5714 functor(Type,F,A), functor(TypePat,F,A)
5715 |
5716 maplist(atomic,Def).
5718 type_alias(TypePat,Alias) \ atomic_type(Type)
5719 <=>
5720 functor(Type,F,A), functor(TypePat,F,A)
5721 |
5722 atomic(Alias),
5723 copy_term_nat(TypePat-Alias,Type-NType),
5724 atomic_type(NType).
5726 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5727 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5728 %
5729 % Succeeds when all values of =Type= are atomic
5730 % and the atom values are finitely enumerable.
5731 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5732 :- chr_constraint enumerated_atomic_type/2.
5734 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5736 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5737 <=>
5738 functor(Type,F,A), functor(TypePat,F,A)
5739 |
5740 maplist(atomic,Def),
5741 Atoms = Def.
5743 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5744 <=>
5745 functor(Type,F,A), functor(TypePat,F,A)
5746 |
5747 atomic(Alias),
5748 copy_term_nat(TypePat-Alias,Type-NType),
5749 enumerated_atomic_type(NType,Atoms).
5750 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5752 :- chr_constraint
5753 stored/3, % constraint,occurrence,(yes/no/maybe)
5754 stored_completing/3,
5755 stored_complete/3,
5756 is_stored/1,
5757 is_finally_stored/1,
5758 check_all_passive/2.
5760 :- chr_option(mode,stored(+,+,+)).
5761 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5762 :- chr_type storedinfo ---> yes ; no ; maybe.
5763 :- chr_option(mode,stored_complete(+,+,+)).
5764 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5765 :- chr_option(mode,guard_list(+,+,+,+)).
5766 :- chr_option(mode,check_all_passive(+,+)).
5767 :- chr_option(type_declaration,check_all_passive(any,list)).
5769 % change yes in maybe when yes becomes passive
5770 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5771 stored(C,O,yes), stored_complete(C,RO,Yesses)
5772 <=> O < RO | NYesses is Yesses - 1,
5773 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5774 % change yes in maybe when not observed
5775 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5776 <=> O < RO |
5777 NYesses is Yesses - 1,
5778 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5780 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5781 ==> RO =< MO2 | % C2 is never stored
5782 passive(RuleNb,ID).
5787 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5789 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5790 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5791 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5793 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5794 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5795 check_all_passive(RuleNb,IDs2).
5797 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5798 check_all_passive(RuleNb,IDs).
5800 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5801 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5803 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5805 % collect the storage information
5806 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5807 <=> NO is O + 1, NYesses is Yesses + 1,
5808 stored_completing(C,NO,NYesses).
5809 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5810 <=> NO is O + 1,
5811 stored_completing(C,NO,Yesses).
5813 stored(C,O,no) \ stored_completing(C,O,Yesses)
5814 <=> stored_complete(C,O,Yesses).
5815 stored_completing(C,O,Yesses)
5816 <=> stored_complete(C,O,Yesses).
5818 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5819 O2 > O | passive(RuleNb,Id).
5821 % decide whether a constraint is stored
5822 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5823 <=> RO =< MO | fail.
5824 is_stored(C) <=> true.
5826 % decide whether a constraint is suspends after occurrences
5827 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5828 <=> RO =< MO | fail.
5829 is_finally_stored(C) <=> true.
5831 storage_analysis(Constraints) :-
5832 ( chr_pp_flag(storage_analysis,on) ->
5833 check_constraint_storages(Constraints)
5834 ;
5835 true
5836 ).
5838 check_constraint_storages([]).
5839 check_constraint_storages([C|Cs]) :-
5840 check_constraint_storage(C),
5841 check_constraint_storages(Cs).
5843 check_constraint_storage(C) :-
5844 get_max_occurrence(C,MO),
5845 check_occurrences_storage(C,1,MO).
5847 check_occurrences_storage(C,O,MO) :-
5848 ( O > MO ->
5849 stored_completing(C,1,0)
5850 ;
5851 check_occurrence_storage(C,O),
5852 NO is O + 1,
5853 check_occurrences_storage(C,NO,MO)
5854 ).
5856 check_occurrence_storage(C,O) :-
5857 get_occurrence(C,O,RuleNb,ID),
5858 ( is_passive(RuleNb,ID) ->
5859 stored(C,O,maybe)
5860 ;
5861 get_rule(RuleNb,PragmaRule),
5862 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5863 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5864 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5865 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5866 check_storage_head2(Head2,O,Heads1,Body)
5867 )
5868 ).
5870 check_storage_head1(Head,O,H1,H2,G) :-
5871 functor(Head,F,A),
5872 C = F/A,
5873 ( H1 == [Head],
5874 H2 == [],
5875 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5876 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5877 Head =.. [_|L],
5878 no_matching(L,[]) ->
5879 stored(C,O,no)
5880 ;
5881 stored(C,O,maybe)
5882 ).
5884 no_matching([],_).
5885 no_matching([X|Xs],Prev) :-
5886 var(X),
5887 \+ memberchk_eq(X,Prev),
5888 no_matching(Xs,[X|Prev]).
5890 check_storage_head2(Head,O,H1,B) :-
5891 functor(Head,F,A),
5892 C = F/A,
5893 ( %(
5894 ( H1 \== [], B == true )
5895 %;
5896 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5897 %)
5898 ->
5899 stored(C,O,maybe)
5900 ;
5901 stored(C,O,yes)
5902 ).
5904 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5906 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5907 %% ____ _ ____ _ _ _ _
5908 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5909 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5910 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5911 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5912 %% |_|
5914 constraints_code(Constraints,Clauses) :-
5915 (chr_pp_flag(reduced_indexing,on),
5916 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5917 none_suspended_on_variables
5918 ;
5919 true
5920 ),
5921 constraints_code1(Constraints,Clauses,[]).
5923 %===============================================================================
5924 :- chr_constraint constraints_code1/3.
5925 :- chr_option(mode,constraints_code1(+,+,+)).
5926 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5927 %-------------------------------------------------------------------------------
5928 constraints_code1([],L,T) <=> L = T.
5929 constraints_code1([C|RCs],L,T)
5930 <=>
5931 constraint_code(C,L,T1),
5932 constraints_code1(RCs,T1,T).
5933 %===============================================================================
5934 :- chr_constraint constraint_code/3.
5935 :- chr_option(mode,constraint_code(+,+,+)).
5936 %-------------------------------------------------------------------------------
5937 %% Generate code for a single CHR constraint
5938 constraint_code(Constraint, L, T)
5939 <=> true
5940 | ( (chr_pp_flag(debugable,on) ;
5941 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5942 ( may_trigger(Constraint) ;
5943 get_allocation_occurrence(Constraint,AO),
5944 get_max_occurrence(Constraint,MO), MO >= AO ) )
5945 ->
5946 constraint_prelude(Constraint,Clause),
5947 add_dummy_location(Clause,LocatedClause),
5948 L = [LocatedClause | L1]
5949 ;
5950 L = L1
5951 ),
5952 Id = [0],
5953 occurrences_code(Constraint,1,Id,NId,L1,L2),
5954 gen_cond_attach_clause(Constraint,NId,L2,T).
5956 %===============================================================================
5957 %% Generate prelude predicate for a constraint.
5958 %% f(...) :- f/a_0(...,Susp).
5959 constraint_prelude(F/A, Clause) :-
5960 vars_susp(A,Vars,Susp,VarsSusp),
5961 Head =.. [ F | Vars],
5962 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5963 build_head(F,A,[0],VarsSusp,Delegate),
5964 ( chr_pp_flag(debugable,on) ->
5965 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5966 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5967 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5968 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5970 ( get_constraint_type(F/A,ArgTypeList) ->
5971 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5972 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5973 ;
5974 DynamicTypeChecks = true
5975 ),
5977 Clause =
5978 ( Head :-
5979 DynamicTypeChecks,
5980 InsertGoal,
5981 InsertCall,
5982 AttachCall,
5983 Inactive,
5984 'chr debug_event'(insert(Head#Susp)),
5985 (
5986 'chr debug_event'(call(Susp)),
5987 Delegate
5988 ;
5989 'chr debug_event'(fail(Susp)), !,
5990 fail
5991 ),
5992 (
5993 'chr debug_event'(exit(Susp))
5994 ;
5995 'chr debug_event'(redo(Susp)),
5996 fail
5997 )
5998 )
5999 ; get_allocation_occurrence(F/A,0) ->
6000 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6001 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6002 Clause = ( Head :- Goal, Inactive, Delegate )
6003 ;
6004 Clause = ( Head :- Delegate )
6005 ).
6007 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6008 ( may_trigger(F/A) ->
6009 build_head(F,A,[0],VarsSusp,Delegate),
6010 ( chr_pp_flag(debugable,off) ->
6011 Goal = Delegate
6012 ;
6013 get_target_module(Mod),
6014 Goal = Mod:Delegate
6015 )
6016 ;
6017 Goal = true
6018 ).
6020 %===============================================================================
6021 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6022 :- chr_option(mode,has_active_occurrence(+)).
6023 :- chr_option(mode,has_active_occurrence(+,+)).
6024 %-------------------------------------------------------------------------------
6025 has_active_occurrence(C) <=> has_active_occurrence(C,1).
6027 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6028 O > MO | fail.
6029 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6030 has_active_occurrence(C,O) <=>
6031 NO is O + 1,
6032 has_active_occurrence(C,NO).
6033 has_active_occurrence(C,O) <=> true.
6034 %===============================================================================
6036 gen_cond_attach_clause(F/A,Id,L,T) :-
6037 ( is_finally_stored(F/A) ->
6038 get_allocation_occurrence(F/A,AllocationOccurrence),
6039 get_max_occurrence(F/A,MaxOccurrence),
6040 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6041 ( only_ground_indexed_arguments(F/A) ->
6042 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6043 ;
6044 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6045 )
6046 ; vars_susp(A,Args,Susp,AllArgs),
6047 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6048 ),
6049 build_head(F,A,Id,AllArgs,Head),
6050 Clause = ( Head :- Body ),
6051 add_dummy_location(Clause,LocatedClause),
6052 L = [LocatedClause | T]
6053 ;
6054 L = T
6055 ).
6057 :- chr_constraint use_auxiliary_predicate/1.
6058 :- chr_option(mode,use_auxiliary_predicate(+)).
6060 :- chr_constraint use_auxiliary_predicate/2.
6061 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6063 :- chr_constraint is_used_auxiliary_predicate/1.
6064 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6066 :- chr_constraint is_used_auxiliary_predicate/2.
6067 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6070 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6072 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6074 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6076 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6078 is_used_auxiliary_predicate(P) <=> fail.
6080 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6081 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6083 is_used_auxiliary_predicate(P,C) <=> fail.
6085 %------------------------------------------------------------------------------%
6086 % Only generate import statements for actually used modules.
6087 %------------------------------------------------------------------------------%
6089 :- chr_constraint use_auxiliary_module/1.
6090 :- chr_option(mode,use_auxiliary_module(+)).
6092 :- chr_constraint is_used_auxiliary_module/1.
6093 :- chr_option(mode,is_used_auxiliary_module(+)).
6096 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6098 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6100 is_used_auxiliary_module(P) <=> fail.
6102 % only called for constraints with
6103 % at least one
6104 % non-ground indexed argument
6105 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6106 vars_susp(A,Args,Susp,AllArgs),
6107 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6108 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6109 Attach = true
6110 ;
6111 attach_constraint_atom(F/A,Vars,Susp,Attach)
6112 ),
6113 FTerm =.. [F|Args],
6114 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6115 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6116 ( may_trigger(F/A) ->
6117 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6118 Goal =
6119 (
6120 ( var(Susp) ->
6121 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6122 InsertCall,
6123 Attach
6124 ;
6125 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6126 )
6127 )
6128 ;
6129 Goal =
6130 (
6131 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6132 InsertCall,
6133 Attach
6134 )
6135 ).
6137 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6138 vars_susp(A,Args,Susp,AllArgs),
6139 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6140 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6141 attach_constraint_atom(F/A,Vars,Susp,Attach)
6142 ;
6143 Attach = true
6144 ),
6145 FTerm =.. [F|Args],
6146 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6147 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6148 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6149 Goal =
6150 (
6151 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6152 InsertCall
6153 )
6154 ;
6155 Goal =
6156 (
6157 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6158 InsertCall,
6159 Attach
6160 )
6161 ).
6163 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6164 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6165 attach_constraint_atom(FA,Vars,Susp,Attach)
6166 ;
6167 Attach = true
6168 ),
6169 insert_constraint_goal(FA,Susp,Args,InsertCall),
6170 ( chr_pp_flag(late_allocation,on) ->
6171 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6172 ;
6173 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6174 ).
6176 %-------------------------------------------------------------------------------
6177 :- chr_constraint occurrences_code/6.
6178 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6179 %-------------------------------------------------------------------------------
6180 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6181 <=> O > MO
6182 | NId = Id, L = T.
6183 occurrences_code(C,O,Id,NId,L,T)
6184 <=>
6185 occurrence_code(C,O,Id,Id1,L,L1),
6186 NO is O + 1,
6187 occurrences_code(C,NO,Id1,NId,L1,T).
6188 %-------------------------------------------------------------------------------
6189 :- chr_constraint occurrence_code/6.
6190 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6191 %-------------------------------------------------------------------------------
6192 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6193 <=>
6194 ( named_history(RuleNb,_,_) ->
6195 does_use_history(C,O)
6196 ;
6197 true
6198 ),
6199 NId = Id,
6200 L = T.
6201 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6202 <=> true |
6203 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6204 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6205 NId = Id,
6206 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6207 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6209 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6210 ( should_skip_to_next_id(C,O) ->
6211 inc_id(Id,NId),
6212 ( unconditional_occurrence(C,O) ->
6213 L1 = T
6214 ;
6215 gen_alloc_inc_clause(C,O,Id,L1,T)
6216 )
6217 ;
6218 NId = Id,
6219 L1 = T
6220 )
6221 ).
6223 occurrence_code(C,O,_,_,_,_)
6224 <=>
6225 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6226 %-------------------------------------------------------------------------------
6228 %% Generate code based on one removed head of a CHR rule
6229 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6230 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6231 Rule = rule(_,Head2,_,_),
6232 ( Head2 == [] ->
6233 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6234 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6235 ;
6236 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6237 ).
6239 %% Generate code based on one persistent head of a CHR rule
6240 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6241 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6242 Rule = rule(Head1,_,_,_),
6243 ( Head1 == [] ->
6244 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6245 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6246 ;
6247 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6248 ).
6250 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6251 vars_susp(A,Vars,Susp,VarsSusp),
6252 build_head(F,A,Id,VarsSusp,Head),
6253 inc_id(Id,IncId),
6254 build_head(F,A,IncId,VarsSusp,CallHead),
6255 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6256 Clause =
6257 (
6258 Head :-
6259 ConditionalAlloc,
6260 CallHead
6261 ),
6262 add_dummy_location(Clause,LocatedClause),
6263 L = [LocatedClause|T].
6265 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6266 get_allocation_occurrence(FA,AO),
6267 get_occurrence_code_id(FA,AO,AId),
6268 get_occurrence_code_id(FA,O,Id),
6269 ( chr_pp_flag(debugable,off), Id == AId ->
6270 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6271 ( may_trigger(FA) ->
6272 Goal = (var(Susp) -> Goal0 ; true)
6273 ;
6274 Goal = Goal0
6275 )
6276 ;
6277 Goal = true
6278 ).
6280 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6281 get_allocation_occurrence(FA,AO),
6282 ( chr_pp_flag(debugable,off), O < AO ->
6283 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6284 ( may_trigger(FA) ->
6285 Goal = (var(Susp) -> Goal0 ; true)
6286 ;
6287 Goal = Goal0
6288 )
6289 ;
6290 Goal = true
6291 ).
6293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6295 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6296 %
6297 % Reorders guard goals with respect to partner constraint retrieval goals and
6298 % active constraint. Returns combined partner retrieval + guard goal.
6300 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6301 ( chr_pp_flag(guard_via_reschedule,on) ->
6302 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6303 list2conj(ScheduleSkeleton,GoalSkeleton)
6304 ;
6305 length(Retrievals,RL), length(LookupSkeleton,RL),
6306 length(GuardList,GL), length(GuardListSkeleton,GL),
6307 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6308 list2conj(GoalListSkeleton,GoalSkeleton)
6309 ).
6310 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6311 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6312 initialize_unit_dictionary(ActiveHead,Dict),
6313 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6314 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6315 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6316 dependency_reorder(Units,NUnits),
6317 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6318 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6319 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6321 wrappedunits2lists([],[],[],[]).
6322 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6323 Ss = [GoalCopy|TSs],
6324 ( WrappedGoal = lookup(Goal) ->
6325 Ls = [GoalCopy|TLs],
6326 Gs = TGs
6327 ; WrappedGoal = guard(Goal) ->
6328 Gs = [N-GoalCopy|TGs],
6329 Ls = TLs
6330 ),
6331 wrappedunits2lists(Units,TGs,TLs,TSs).
6333 guard_splitting(Rule,SplitGuardList) :-
6334 Rule = rule(H1,H2,Guard,_),
6335 append(H1,H2,Heads),
6336 conj2list(Guard,GuardList),
6337 term_variables(Heads,HeadVars),
6338 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6339 append(GuardPrefix,[RestGuard],SplitGuardList),
6340 term_variables(RestGuardList,GuardVars1),
6341 % variables that are declared to be ground don't need to be locked
6342 ground_vars(Heads,GroundVars),
6343 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6344 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6345 ( chr_pp_flag(guard_locks,on),
6346 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6347 once(pairup(Locks,Unlocks,LocksUnlocks))
6348 ;
6349 Locks = [],
6350 Unlocks = []
6351 ),
6352 list2conj(Locks,LockPhase),
6353 list2conj(Unlocks,UnlockPhase),
6354 list2conj(RestGuardList,RestGuard1),
6355 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6357 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6358 Rule = rule(_,_,_,Body),
6359 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6360 my_term_copy(Body,VarDict2,BodyCopy).
6363 split_off_simple_guard_new([],_,[],[]).
6364 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6365 ( simple_guard_new(G,VarDict) ->
6366 S = [G|Ss],
6367 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6368 ;
6369 S = [],
6370 C = [G|Gs]
6371 ).
6373 % simple guard: cheap and benign (does not bind variables)
6374 simple_guard_new(G,Vars) :-
6375 builtin_binds_b(G,BoundVars),
6376 \+ (( member(V,BoundVars),
6377 memberchk_eq(V,Vars)
6378 )).
6380 dependency_reorder(Units,NUnits) :-
6381 dependency_reorder(Units,[],NUnits).
6383 dependency_reorder([],Acc,Result) :-
6384 reverse(Acc,Result).
6386 dependency_reorder([Unit|Units],Acc,Result) :-
6387 Unit = unit(_GID,_Goal,Type,GIDs),
6388 ( Type == fixed ->
6389 NAcc = [Unit|Acc]
6390 ;
6391 dependency_insert(Acc,Unit,GIDs,NAcc)
6392 ),
6393 dependency_reorder(Units,NAcc,Result).
6395 dependency_insert([],Unit,_,[Unit]).
6396 dependency_insert([X|Xs],Unit,GIDs,L) :-
6397 X = unit(GID,_,_,_),
6398 ( memberchk(GID,GIDs) ->
6399 L = [Unit,X|Xs]
6400 ;
6401 L = [X | T],
6402 dependency_insert(Xs,Unit,GIDs,T)
6403 ).
6405 build_units(Retrievals,Guard,InitialDict,Units) :-
6406 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6407 build_guard_units(Guard,N,Dict,Tail).
6409 build_retrieval_units([],N,N,Dict,Dict,L,L).
6410 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6411 term_variables(U,Vs),
6412 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6413 L = [unit(N,U,fixed,GIDs)|L1],
6414 N1 is N + 1,
6415 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6417 initialize_unit_dictionary(Term,Dict) :-
6418 term_variables(Term,Vars),
6419 pair_all_with(Vars,0,Dict).
6421 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6422 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6423 ( lookup_eq(Dict,V,GID) ->
6424 ( (GID == This ; memberchk(GID,GIDs) ) ->
6425 GIDs1 = GIDs
6426 ;
6427 GIDs1 = [GID|GIDs]
6428 ),
6429 Dict1 = Dict
6430 ;
6431 Dict1 = [V - This|Dict],
6432 GIDs1 = GIDs
6433 ),
6434 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6436 build_guard_units(Guard,N,Dict,Units) :-
6437 ( Guard = [Goal] ->
6438 Units = [unit(N,Goal,fixed,[])]
6439 ; Guard = [Goal|Goals] ->
6440 term_variables(Goal,Vs),
6441 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6442 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6443 N1 is N + 1,
6444 build_guard_units(Goals,N1,NDict,RUnits)
6445 ).
6447 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6448 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6449 ( lookup_eq(Dict,V,GID) ->
6450 ( (GID == This ; memberchk(GID,GIDs) ) ->
6451 GIDs1 = GIDs
6452 ;
6453 GIDs1 = [GID|GIDs]
6454 ),
6455 Dict1 = [V - This|Dict]
6456 ;
6457 Dict1 = [V - This|Dict],
6458 GIDs1 = GIDs
6459 ),
6460 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6462 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6464 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6465 %% ____ _ ____ _ _
6466 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6467 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6468 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6469 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6470 %%
6471 %% _ _ _ ___ __
6472 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6473 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6474 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6475 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6476 %% |_|
6477 :- chr_constraint
6478 functional_dependency/4,
6479 get_functional_dependency/4.
6481 :- chr_option(mode,functional_dependency(+,+,?,?)).
6482 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6484 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6485 <=>
6486 RuleNb > 1, AO > O
6487 |
6488 functional_dependency(C,1,Pattern,Key).
6490 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6491 <=>
6492 RuleNb2 >= RuleNb1
6493 |
6494 QPattern = Pattern, QKey = Key.
6495 get_functional_dependency(_,_,_,_)
6496 <=>
6497 fail.
6499 functional_dependency_analysis(Rules) :-
6500 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6501 functional_dependency_analysis_main(Rules)
6502 ;
6503 true
6504 ).
6506 functional_dependency_analysis_main([]).
6507 functional_dependency_analysis_main([PRule|PRules]) :-
6508 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6509 functional_dependency(C,RuleNb,Pattern,Key)
6510 ;
6511 true
6512 ),
6513 functional_dependency_analysis_main(PRules).
6515 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6516 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6517 Rule = rule(H1,H2,Guard,_),
6518 ( H1 = [C1],
6519 H2 = [C2] ->
6520 true
6521 ; H1 = [C1,C2],
6522 H2 == [] ->
6523 true
6524 ),
6525 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6526 term_variables(C1,Vs),
6527 \+ (
6528 member(V1,Vs),
6529 lookup_eq(List,V1,V2),
6530 memberchk_eq(V2,Vs)
6531 ),
6532 select_pragma_unique_variables(Vs,List,Key1),
6533 copy_term_nat(C1-Key1,Pattern-Key),
6534 functor(C1,F,A).
6536 select_pragma_unique_variables([],_,[]).
6537 select_pragma_unique_variables([V|Vs],List,L) :-
6538 ( lookup_eq(List,V,_) ->
6539 L = T
6540 ;
6541 L = [V|T]
6542 ),
6543 select_pragma_unique_variables(Vs,List,T).
6545 % depends on functional dependency analysis
6546 % and shape of rule: C1 \ C2 <=> true.
6547 set_semantics_rules(Rules) :-
6548 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6549 set_semantics_rules_main(Rules)
6550 ;
6551 true
6552 ).
6554 set_semantics_rules_main([]).
6555 set_semantics_rules_main([R|Rs]) :-
6556 set_semantics_rule_main(R),
6557 set_semantics_rules_main(Rs).
6559 set_semantics_rule_main(PragmaRule) :-
6560 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6561 ( Rule = rule([C1],[C2],true,_),
6562 IDs = ids([ID1],[ID2]),
6563 \+ is_passive(RuleNb,ID1),
6564 functor(C1,F,A),
6565 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6566 copy_term_nat(Pattern-Key,C1-Key1),
6567 copy_term_nat(Pattern-Key,C2-Key2),
6568 Key1 == Key2 ->
6569 passive(RuleNb,ID2)
6570 ;
6571 true
6572 ).
6574 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6575 \+ any_passive_head(RuleNb),
6576 variable_replacement(C1-C2,C2-C1,List),
6577 copy_with_variable_replacement(G,OtherG,List),
6578 negate_b(G,NotG),
6579 once(entails_b(NotG,OtherG)).
6581 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6582 % where C1 and C2 are symmteric constraints
6583 symmetry_analysis(Rules) :-
6584 ( chr_pp_flag(check_unnecessary_active,off) ->
6585 true
6586 ;
6587 symmetry_analysis_main(Rules)
6588 ).
6590 symmetry_analysis_main([]).
6591 symmetry_analysis_main([R|Rs]) :-
6592 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6593 Rule = rule(H1,H2,_,_),
6594 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6595 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6596 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6597 ;
6598 true
6599 ),
6600 symmetry_analysis_main(Rs).
6602 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6603 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6604 ( \+ is_passive(RuleNb,ID),
6605 member2(PreHs,PreIDs,PreH-PreID),
6606 \+ is_passive(RuleNb,PreID),
6607 variable_replacement(PreH,H,List),
6608 copy_with_variable_replacement(Rule,Rule2,List),
6609 identical_guarded_rules(Rule,Rule2) ->
6610 passive(RuleNb,ID)
6611 ;
6612 true
6613 ),
6614 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6616 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6617 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6618 ( \+ is_passive(RuleNb,ID),
6619 member2(PreHs,PreIDs,PreH-PreID),
6620 \+ is_passive(RuleNb,PreID),
6621 variable_replacement(PreH,H,List),
6622 copy_with_variable_replacement(Rule,Rule2,List),
6623 identical_rules(Rule,Rule2) ->
6624 passive(RuleNb,ID)
6625 ;
6626 true
6627 ),
6628 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6630 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6632 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6633 %% ____ _ _ _ __ _ _ _
6634 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6635 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6636 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6637 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6638 %% |_|
6639 %% {{{
6641 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6642 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6643 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6644 build_head(F,A,Id,HeadVars,ClauseHead),
6645 get_constraint_mode(F/A,Mode),
6646 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6649 guard_splitting(Rule,GuardList0),
6650 ( is_stored_in_guard(F/A, RuleNb) ->
6651 GuardList = [Hole1|GuardList0]
6652 ;
6653 GuardList = GuardList0
6654 ),
6655 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6657 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6659 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6661 ( is_stored_in_guard(F/A, RuleNb) ->
6662 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6663 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6664 GuardCopyList = [Hole1Copy|_],
6665 Hole1Copy = (Allocation, Attachment)
6666 ;
6667 true
6668 ),
6671 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6672 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6674 ( chr_pp_flag(debugable,on) ->
6675 Rule = rule(_,_,Guard,Body),
6676 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6677 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6678 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6679 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6680 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6681 ;
6682 Cut = ActualCut
6683 ),
6684 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6685 Clause = ( ClauseHead :-
6686 FirstMatching,
6687 RescheduledTest,
6688 Cut,
6689 SuspsDetachments,
6690 SuspDetachment,
6691 BodyCopy
6692 ),
6693 add_location(Clause,RuleNb,LocatedClause),
6694 L = [LocatedClause | T].
6696 % }}}
6698 add_location(Clause,RuleNb,NClause) :-
6699 ( chr_pp_flag(line_numbers,on) ->
6700 get_chr_source_file(File),
6701 get_line_number(RuleNb,LineNb),
6702 NClause = '$source_location'(File,LineNb):Clause
6703 ;
6704 NClause = Clause
6705 ).
6707 add_dummy_location(Clause,NClause) :-
6708 ( chr_pp_flag(line_numbers,on) ->
6709 get_chr_source_file(File),
6710 NClause = '$source_location'(File,1):Clause
6711 ;
6712 NClause = Clause
6713 ).
6714 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6715 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6716 %
6717 % Return goal matching newly introduced variables with variables in
6718 % previously looked-up heads.
6719 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6720 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6721 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6723 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6724 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6725 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6726 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6727 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6728 list2conj(GoalList,Goal).
6730 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6731 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6732 ( var(Arg) ->
6733 ( lookup_eq(VarDict,Arg,OtherVar) ->
6734 ( Mode = (+) ->
6735 ( memberchk_eq(Arg,GroundVars) ->
6736 GoalList = [Var = OtherVar | RestGoalList],
6737 GroundVars1 = GroundVars
6738 ;
6739 GoalList = [Var == OtherVar | RestGoalList],
6740 GroundVars1 = [Arg|GroundVars]
6741 )
6742 ;
6743 GoalList = [Var == OtherVar | RestGoalList],
6744 GroundVars1 = GroundVars
6745 ),
6746 VarDict1 = VarDict
6747 ;
6748 VarDict1 = [Arg-Var | VarDict],
6749 GoalList = RestGoalList,
6750 ( Mode = (+) ->
6751 GroundVars1 = [Arg|GroundVars]
6752 ;
6753 GroundVars1 = GroundVars
6754 )
6755 ),
6756 Pairs = Rest,
6757 RestModes = Modes
6758 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6759 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6760 GoalList = [Goal|RestGoalList],
6761 VarDict = VarDict1,
6762 GroundVars1 = GroundVars,
6763 Pairs = Rest,
6764 RestModes = Modes
6765 ; atomic(Arg) ->
6766 ( Mode = (+) ->
6767 GoalList = [ Var = Arg | RestGoalList]
6768 ;
6769 GoalList = [ Var == Arg | RestGoalList]
6770 ),
6771 VarDict = VarDict1,
6772 GroundVars1 = GroundVars,
6773 Pairs = Rest,
6774 RestModes = Modes
6775 ; Mode == (+), is_ground(GroundVars,Arg) ->
6776 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6777 GoalList = [ Var = ArgCopy | RestGoalList],
6778 VarDict = VarDict1,
6779 GroundVars1 = GroundVars,
6780 Pairs = Rest,
6781 RestModes = Modes
6782 ; Mode == (?), is_ground(GroundVars,Arg) ->
6783 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6784 GoalList = [ Var == ArgCopy | RestGoalList],
6785 VarDict = VarDict1,
6786 GroundVars1 = GroundVars,
6787 Pairs = Rest,
6788 RestModes = Modes
6789 ; Arg =.. [_|Args],
6790 functor(Arg,Fct,N),
6791 functor(Term,Fct,N),
6792 Term =.. [_|Vars],
6793 ( Mode = (+) ->
6794 GoalList = [ Var = Term | RestGoalList ]
6795 ;
6796 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6797 ),
6798 pairup(Args,Vars,NewPairs),
6799 append(NewPairs,Rest,Pairs),
6800 replicate(N,Mode,NewModes),
6801 append(NewModes,Modes,RestModes),
6802 VarDict1 = VarDict,
6803 GroundVars1 = GroundVars
6804 ),
6805 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6807 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6808 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6809 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6810 add_heads_types([],VarTypes,VarTypes).
6811 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6812 add_head_types(Head,VarTypes,VarTypes1),
6813 add_heads_types(Heads,VarTypes1,NVarTypes).
6815 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6816 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6817 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6818 add_head_types(Head,VarTypes,NVarTypes) :-
6819 functor(Head,F,A),
6820 get_constraint_type_det(F/A,ArgTypes),
6821 Head =.. [_|Args],
6822 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6824 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6825 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6826 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6827 add_args_types([],[],VarTypes,VarTypes).
6828 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6829 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6830 add_args_types(Args,Types,VarTypes1,NVarTypes).
6832 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6833 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6834 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6835 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6836 ( var(Term) ->
6837 ( lookup_eq(VarTypes,Term,_) ->
6838 NVarTypes = VarTypes
6839 ;
6840 NVarTypes = [Term-Type|VarTypes]
6841 )
6842 ; ground(Term) ->
6843 NVarTypes = VarTypes
6844 ; % TODO improve approximation!
6845 term_variables(Term,Vars),
6846 length(Vars,VarNb),
6847 replicate(VarNb,any,Types),
6848 add_args_types(Vars,Types,VarTypes,NVarTypes)
6849 ).
6853 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6854 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6855 %
6856 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6857 add_heads_ground_variables([],GroundVars,GroundVars).
6858 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6859 add_head_ground_variables(Head,GroundVars,GroundVars1),
6860 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6862 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6863 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6864 %
6865 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6866 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6867 functor(Head,F,A),
6868 get_constraint_mode(F/A,ArgModes),
6869 Head =.. [_|Args],
6870 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6873 add_arg_ground_variables([],[],GroundVars,GroundVars).
6874 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6875 ( Mode == (+) ->
6876 term_variables(Arg,Vars),
6877 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6878 ;
6879 GroundVars = GroundVars1
6880 ),
6881 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6883 add_var_ground_variables([],GroundVars,GroundVars).
6884 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6885 ( memberchk_eq(Var,GroundVars) ->
6886 GroundVars1 = GroundVars
6887 ;
6888 GroundVars1 = [Var|GroundVars]
6889 ),
6890 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6891 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6892 %% is_ground(+GroundVars,+Term) is semidet.
6893 %
6894 % Determine whether =Term= is always ground.
6895 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6896 is_ground(GroundVars,Term) :-
6897 ( ground(Term) ->
6898 true
6899 ; compound(Term) ->
6900 Term =.. [_|Args],
6901 maplist(is_ground(GroundVars),Args)
6902 ;
6903 memberchk_eq(Term,GroundVars)
6904 ).
6906 %% check_ground(+GroundVars,+Term,-Goal) is det.
6907 %
6908 % Return runtime check to see whether =Term= is ground.
6909 check_ground(GroundVars,Term,Goal) :-
6910 term_variables(Term,Variables),
6911 check_ground_variables(Variables,GroundVars,Goal).
6913 check_ground_variables([],_,true).
6914 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6915 ( memberchk_eq(Var,GroundVars) ->
6916 check_ground_variables(Vars,GroundVars,Goal)
6917 ;
6918 Goal = (ground(Var), RGoal),
6919 check_ground_variables(Vars,GroundVars,RGoal)
6920 ).
6922 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6923 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6925 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6926 ( Heads = [_|_] ->
6927 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6928 ;
6929 GoalList = [],
6930 Susps = [],
6931 VarDict = NVarDict,
6932 GroundVars = NGroundVars
6933 ).
6935 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6936 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6937 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6938 functor(H,F,A),
6939 head_info(H,A,Vars,_,_,Pairs),
6940 get_store_type(F/A,StoreType),
6941 ( StoreType == default ->
6942 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6943 delay_phase_end(validate_store_type_assumptions,
6944 ( static_suspension_term(F/A,Suspension),
6945 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6946 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6947 )
6948 ),
6949 % create_get_mutable_ref(active,State,GetMutable),
6950 get_constraint_mode(F/A,Mode),
6951 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6952 NPairs = Pairs,
6953 sbag_member_call(Susp,VarSusps,Sbag),
6954 ExistentialLookup = (
6955 ViaGoal,
6956 Sbag,
6957 Susp = Suspension, % not inlined
6958 GetState
6959 )
6960 ;
6961 delay_phase_end(validate_store_type_assumptions,
6962 ( static_suspension_term(F/A,Suspension),
6963 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6964 )
6965 ),
6966 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6967 get_constraint_mode(F/A,Mode),
6968 filter_mode(NPairs,Pairs,Mode,NMode),
6969 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6970 ),
6971 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6972 append(NPairs,VarDict1,DA_), % order important here
6973 translate(GroundVars1,DA_,GroundVarsA),
6974 translate(GroundVars1,VarDict1,GroundVarsB),
6975 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6976 Goal =
6977 (
6978 ExistentialLookup,
6979 DiffSuspGoals,
6980 MatchingGoal2
6981 ),
6982 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6984 inline_matching_goal(A==B,true,GVA,GVB) :-
6985 memberchk_eq(A,GVA),
6986 memberchk_eq(B,GVB),
6987 A=B, !.
6989 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6990 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6991 inline_matching_goal(A,A2,GVA,GVB),
6992 inline_matching_goal(B,B2,GVA,GVB).
6993 inline_matching_goal(X,X,_,_).
6996 filter_mode([],_,_,[]).
6997 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6998 ( Var == V ->
6999 Modes = [M|MT],
7000 filter_mode(Rest,R,Ms,MT)
7001 ;
7002 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7003 ).
7005 check_unique_keys([],_).
7006 check_unique_keys([V|Vs],Dict) :-
7007 lookup_eq(Dict,V,_),
7008 check_unique_keys(Vs,Dict).
7010 % Generates tests to ensure the found constraint differs from previously found constraints
7011 % TODO: detect more cases where constraints need be different
7012 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7013 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7014 list2conj(DiffSuspGoalList,DiffSuspGoals).
7016 different_from_other_susps_(_,[],_,_,[]) :- !.
7017 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7018 ( functor(Head,F,A), functor(PreHead,F,A),
7019 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7020 \+ \+ PreHeadCopy = HeadCopy ->
7022 List = [Susp \== PreSusp | Tail]
7023 ;
7024 List = Tail
7025 ),
7026 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7028 % passive_head_via(in,in,in,in,out,out,out) :-
7029 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7030 functor(Head,F,A),
7031 get_constraint_index(F/A,Pos),
7032 common_variables(Head,PrevHeads,CommonVars),
7033 global_list_store_name(F/A,Name),
7034 GlobalGoal = nb_getval(Name,AllSusps),
7035 get_constraint_mode(F/A,ArgModes),
7036 ( Vars == [] ->
7037 Goal = GlobalGoal
7038 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7039 translate([CommonVar],VarDict,[Var]),
7040 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7041 Goal = AttrGoal
7042 ;
7043 translate(CommonVars,VarDict,Vars),
7044 add_heads_types(PrevHeads,[],TypeDict),
7045 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7046 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7047 Goal =
7048 ( ViaGoal ->
7049 AttrGoal
7050 ;
7051 GlobalGoal
7052 )
7053 ).
7055 common_variables(T,Ts,Vs) :-
7056 term_variables(T,V1),
7057 term_variables(Ts,V2),
7058 intersect_eq(V1,V2,Vs).
7060 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7061 get_target_module(Mod),
7062 ( Vars = [A] ->
7063 lookup_eq(TypeDict,A,Type),
7064 ( atomic_type(Type) ->
7065 ViaGoal = var(A),
7066 A = V
7067 ;
7068 ViaGoal = 'chr newvia_1'(A,V)
7069 )
7070 ; Vars = [A,B] ->
7071 ViaGoal = 'chr newvia_2'(A,B,V)
7072 ;
7073 ViaGoal = 'chr newvia'(Vars,V)
7074 ),
7075 AttrGoal =
7076 ( get_attr(V,Mod,TSusps),
7077 TSuspsEqSusps % TSusps = Susps
7078 ),
7079 get_max_constraint_index(N),
7080 ( N == 1 ->
7081 TSuspsEqSusps = true, % TSusps = Susps
7082 AllSusps = TSusps
7083 ;
7084 get_constraint_index(FA,Pos),
7085 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7086 ).
7087 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7088 get_target_module(Mod),
7089 AttrGoal =
7090 ( get_attr(Var,Mod,TSusps),
7091 TSuspsEqSusps % TSusps = Susps
7092 ),
7093 get_max_constraint_index(N),
7094 ( N == 1 ->
7095 TSuspsEqSusps = true, % TSusps = Susps
7096 AllSusps = TSusps
7097 ;
7098 get_constraint_index(FA,Pos),
7099 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7100 ).
7102 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7103 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7104 list2conj(GuardCopyList,GuardCopy).
7106 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7107 Rule = rule(_,H,Guard,Body),
7108 conj2list(Guard,GuardList),
7109 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7110 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7112 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7113 term_variables(RestGuardList,GuardVars),
7114 term_variables(RestGuardListCopyCore,GuardCopyVars),
7115 % variables that are declared to be ground don't need to be locked
7116 ground_vars(H,GroundVars),
7117 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7118 ( chr_pp_flag(guard_locks,on),
7119 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7120 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7121 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7122 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7123 ),
7124 LocksUnlocks) ->
7125 once(pairup(Locks,Unlocks,LocksUnlocks))
7126 ;
7127 Locks = [],
7128 Unlocks = []
7129 ),
7130 list2conj(Locks,LockPhase),
7131 list2conj(Unlocks,UnlockPhase),
7132 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7133 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7134 my_term_copy(Body,VarDict2,BodyCopy).
7137 split_off_simple_guard([],_,[],[]).
7138 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7139 ( simple_guard(G,VarDict) ->
7140 S = [G|Ss],
7141 split_off_simple_guard(Gs,VarDict,Ss,C)
7142 ;
7143 S = [],
7144 C = [G|Gs]
7145 ).
7147 % simple guard: cheap and benign (does not bind variables)
7148 simple_guard(G,VarDict) :-
7149 binds_b(G,Vars),
7150 \+ (( member(V,Vars),
7151 lookup_eq(VarDict,V,_)
7152 )).
7154 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7155 functor(Head,F,A),
7156 C = F/A,
7157 ( is_stored(C) ->
7158 (
7159 (
7160 Id == [0], chr_pp_flag(store_in_guards, off)
7161 ;
7162 ( get_allocation_occurrence(C,AO),
7163 get_max_occurrence(C,MO),
7164 MO < AO )
7165 ),
7166 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7167 SuspDetachment = true
7168 ;
7169 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7170 ( chr_pp_flag(late_allocation,on) ->
7171 SuspDetachment =
7172 ( var(Susp) ->
7173 true
7174 ;
7175 UnCondSuspDetachment
7176 )
7177 ;
7178 SuspDetachment = UnCondSuspDetachment
7179 )
7180 )
7181 ;
7182 SuspDetachment = true
7183 ).
7185 partner_constraint_detachments([],[],_,true).
7186 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7187 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7188 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7190 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7191 functor(Head,F,A),
7192 C = F/A,
7193 ( is_stored(C) ->
7194 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7195 ( chr_pp_flag(debugable,on) ->
7196 DebugEvent = 'chr debug_event'(remove(Susp))
7197 ;
7198 DebugEvent = true
7199 ),
7200 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7201 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7202 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7203 detach_constraint_atom(C,Vars,Susp,Detach)
7204 ;
7205 Detach = true
7206 )
7207 ;
7208 SuspDetachment = true
7209 ).
7211 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7213 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7214 %% ____ _ _ _ _
7215 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7216 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7217 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7218 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7219 %% |_| |___/
7220 %% {{{
7222 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7223 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7224 Rule = rule(_Heads,Heads2,Guard,Body),
7226 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7227 get_constraint_mode(F/A,Mode),
7228 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7230 build_head(F,A,Id,HeadVars,ClauseHead),
7232 append(RestHeads,Heads2,Heads),
7233 append(OtherIDs,Heads2IDs,IDs),
7234 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7236 guard_splitting(Rule,GuardList0),
7237 ( is_stored_in_guard(F/A, RuleNb) ->
7238 GuardList = [Hole1|GuardList0]
7239 ;
7240 GuardList = GuardList0
7241 ),
7242 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7244 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7245 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7247 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7249 ( is_stored_in_guard(F/A, RuleNb) ->
7250 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7251 GuardCopyList = [Hole1Copy|_],
7252 Hole1Copy = Attachment
7253 ;
7254 true
7255 ),
7257 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7258 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7259 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7261 ( chr_pp_flag(debugable,on) ->
7262 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7263 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7264 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7265 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7266 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7267 instrument_goal((!),DebugTry,DebugApply,Cut)
7268 ;
7269 Cut = (!)
7270 ),
7272 Clause = ( ClauseHead :-
7273 FirstMatching,
7274 RescheduledTest,
7275 Cut,
7276 SuspsDetachments,
7277 SuspDetachment,
7278 BodyCopy
7279 ),
7280 add_location(Clause,RuleNb,LocatedClause),
7281 L = [LocatedClause | T].
7283 % }}}
7285 split_by_ids([],[],_,[],[]).
7286 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7287 ( memberchk_eq(I,I1s) ->
7288 S1s = [S | R1s],
7289 S2s = R2s
7290 ;
7291 S1s = R1s,
7292 S2s = [S | R2s]
7293 ),
7294 split_by_ids(Is,Ss,I1s,R1s,R2s).
7296 split_by_ids([],[],_,[],[],[],[]).
7297 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7298 ( memberchk_eq(I,I1s) ->
7299 S1s = [S | R1s],
7300 SI1s = [I|RSI1s],
7301 S2s = R2s,
7302 SI2s = RSI2s
7303 ;
7304 S1s = R1s,
7305 SI1s = RSI1s,
7306 S2s = [S | R2s],
7307 SI2s = [I|RSI2s]
7308 ),
7309 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7310 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7313 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7314 %% ____ _ _ _ ____
7315 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7316 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7317 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7318 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7319 %% |_| |___/
7321 %% Genereate prelude + worker predicate
7322 %% prelude calls worker
7323 %% worker iterates over one type of removed constraints
7324 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7325 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7326 Rule = rule(Heads1,_,Guard,Body),
7327 append(Heads1,RestHeads2,Heads),
7328 append(IDs1,RestIDs,IDs),
7329 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7330 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7331 extend_id(Id,Id1),
7332 ( memberchk_eq(NID,IDs2) ->
7333 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7334 ;
7335 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7336 ),
7337 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7338 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7340 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7341 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7342 Heads = [Head|RHeads],
7343 inc_id(Id,Id1),
7344 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7345 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7346 ( memberchk_eq(ID,IDs2) ->
7347 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7348 ;
7349 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7350 ).
7352 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7353 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7354 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7355 build_head(F,A,Id1,VarsSusp,ClauseHead),
7356 get_constraint_mode(F/A,Mode),
7357 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7359 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7361 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7363 extend_id(Id1,DelegateId),
7364 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7365 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7366 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7368 PreludeClause =
7369 ( ClauseHead :-
7370 FirstMatching,
7371 ModConstraintsGoal,
7372 !,
7373 ConstraintAllocationGoal,
7374 Delegate
7375 ),
7376 add_dummy_location(PreludeClause,LocatedPreludeClause),
7377 L = [LocatedPreludeClause|T].
7379 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7380 Term =.. [_|Args],
7381 delegate_variables(Term,Terms,VarDict,Args,Vars).
7383 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7384 term_variables(PrevTerms,PrevVars),
7385 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7387 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7388 term_variables(Term,V1),
7389 term_variables(Terms,V2),
7390 intersect_eq(V1,V2,V3),
7391 list_difference_eq(V3,PrevVars,V4),
7392 translate(V4,VarDict,Vars).
7395 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7396 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7397 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7398 Rule = rule(_,_,Guard,Body),
7399 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7401 gen_var(OtherSusp),
7402 gen_var(OtherSusps),
7404 functor(CurrentHead,OtherF,OtherA),
7405 gen_vars(OtherA,OtherVars),
7406 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7407 get_constraint_mode(OtherF/OtherA,Mode),
7408 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7410 delay_phase_end(validate_store_type_assumptions,
7411 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7412 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7413 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7414 )
7415 ),
7416 % create_get_mutable_ref(active,State,GetMutable),
7417 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7418 CurrentSuspTest = (
7419 OtherSusp = OtherSuspension,
7420 GetState,
7421 DiffSuspGoals,
7422 FirstMatching
7423 ),
7425 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7426 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7428 guard_splitting(Rule,GuardList0),
7429 ( is_stored_in_guard(F/A, RuleNb) ->
7430 GuardList = [Hole1|GuardList0]
7431 ;
7432 GuardList = GuardList0
7433 ),
7434 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7436 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7437 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7438 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7440 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7442 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7443 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7444 RecursiveVars2 = [[]|PreVarsAndSusps],
7445 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7447 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7448 ( is_stored_in_guard(F/A, RuleNb) ->
7449 GuardCopyList = [GuardAttachment|_] % once( ) ??
7450 ;
7451 true
7452 ),
7454 ( is_observed(F/A,O) ->
7455 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7456 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7457 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7458 ;
7459 Attachment = true,
7460 ConditionalRecursiveCall = RecursiveCall,
7461 ConditionalRecursiveCall2 = RecursiveCall2
7462 ),
7464 ( chr_pp_flag(debugable,on) ->
7465 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7466 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7467 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7468 ;
7469 DebugTry = true,
7470 DebugApply = true
7471 ),
7473 ( is_stored_in_guard(F/A, RuleNb) ->
7474 GuardAttachment = Attachment,
7475 BodyAttachment = true
7476 ;
7477 GuardAttachment = true,
7478 BodyAttachment = Attachment % will be true if not observed at all
7479 ),
7481 ( member(unique(ID1,UniqueKeys), Pragmas),
7482 check_unique_keys(UniqueKeys,VarDict) ->
7483 Clause =
7484 ( ClauseHead :-
7485 ( CurrentSuspTest ->
7486 ( RescheduledTest,
7487 DebugTry ->
7488 DebugApply,
7489 Susps1Detachments,
7490 BodyAttachment,
7491 BodyCopy,
7492 ConditionalRecursiveCall2
7493 ;
7494 RecursiveCall2
7495 )
7496 ;
7497 RecursiveCall
7498 )
7499 )
7500 ;
7501 Clause =
7502 ( ClauseHead :-
7503 ( CurrentSuspTest,
7504 RescheduledTest,
7505 DebugTry ->
7506 DebugApply,
7507 Susps1Detachments,
7508 BodyAttachment,
7509 BodyCopy,
7510 ConditionalRecursiveCall
7511 ;
7512 RecursiveCall
7513 )
7514 )
7515 ),
7516 add_location(Clause,RuleNb,LocatedClause),
7517 L = [LocatedClause | T].
7519 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7520 ( may_trigger(FA) ->
7521 does_use_field(FA,generation),
7522 delay_phase_end(validate_store_type_assumptions,
7523 ( static_suspension_term(FA,Suspension),
7524 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7525 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7526 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7527 )
7528 )
7529 ;
7530 delay_phase_end(validate_store_type_assumptions,
7531 ( static_suspension_term(FA,Suspension),
7532 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7533 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7534 )
7535 ),
7536 GetGeneration = true
7537 ),
7538 ConditionalCall =
7539 ( Susp = Suspension,
7540 GetState,
7541 GetGeneration ->
7542 UpdateState,
7543 Call
7544 ;
7545 true
7546 ).
7548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7551 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7552 %% ____ _ _
7553 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7554 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7555 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7556 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7557 %% |_| |___/
7559 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7560 ( RestHeads == [] ->
7561 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7562 ;
7563 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7564 ).
7565 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7566 %% Single headed propagation
7567 %% everything in a single clause
7568 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7569 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7570 build_head(F,A,Id,VarsSusp,ClauseHead),
7572 inc_id(Id,NextId),
7573 build_head(F,A,NextId,VarsSusp,NextHead),
7575 get_constraint_mode(F/A,Mode),
7576 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7577 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7579 % - recursive call -
7580 RecursiveCall = NextHead,
7582 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7583 ActualCut = true
7584 ;
7585 ActualCut = !
7586 ),
7588 Rule = rule(_,_,Guard,Body),
7589 ( chr_pp_flag(debugable,on) ->
7590 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7591 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7592 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7593 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7594 ;
7595 Cut = ActualCut
7596 ),
7597 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7598 use_auxiliary_predicate(novel_production),
7599 use_auxiliary_predicate(extend_history),
7600 does_use_history(F/A,O),
7601 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7603 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7604 ( HistoryIDs == [] ->
7605 empty_named_history_novel_production(HistoryName,NovelProduction),
7606 empty_named_history_extend_history(HistoryName,ExtendHistory)
7607 ;
7608 Tuple = HistoryName
7609 )
7610 ;
7611 Tuple = RuleNb
7612 ),
7614 ( var(NovelProduction) ->
7615 NovelProduction = '$novel_production'(Susp,Tuple),
7616 ExtendHistory = '$extend_history'(Susp,Tuple)
7617 ;
7618 true
7619 ),
7621 ( is_observed(F/A,O) ->
7622 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7623 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7624 ;
7625 Attachment = true,
7626 ConditionalRecursiveCall = RecursiveCall
7627 )
7628 ;
7629 Allocation = true,
7630 NovelProduction = true,
7631 ExtendHistory = true,
7633 ( is_observed(F/A,O) ->
7634 get_allocation_occurrence(F/A,AllocO),
7635 ( O == AllocO ->
7636 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7637 Generation = 0
7638 ; % more room for improvement?
7639 Attachment = (Attachment1, Attachment2),
7640 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7641 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7642 ),
7643 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7644 ;
7645 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7646 ConditionalRecursiveCall = RecursiveCall
7647 )
7648 ),
7650 ( is_stored_in_guard(F/A, RuleNb) ->
7651 GuardAttachment = Attachment,
7652 BodyAttachment = true
7653 ;
7654 GuardAttachment = true,
7655 BodyAttachment = Attachment % will be true if not observed at all
7656 ),
7658 Clause = (
7659 ClauseHead :-
7660 HeadMatching,
7661 Allocation,
7662 NovelProduction,
7663 GuardAttachment,
7664 GuardCopy,
7665 Cut,
7666 ExtendHistory,
7667 BodyAttachment,
7668 BodyCopy,
7669 ConditionalRecursiveCall
7670 ),
7671 add_location(Clause,RuleNb,LocatedClause),
7672 ProgramList = [LocatedClause | ProgramTail].
7674 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7675 %% multi headed propagation
7676 %% prelude + predicates to accumulate the necessary combinations of suspended
7677 %% constraints + predicate to execute the body
7678 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7679 RestHeads = [First|Rest],
7680 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7681 extend_id(Id,ExtendedId),
7682 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7684 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7685 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7686 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7687 build_head(F,A,Id,VarsSusp,PreludeHead),
7688 get_constraint_mode(F/A,Mode),
7689 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7690 Rule = rule(_,_,Guard,Body),
7691 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7693 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7695 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7697 extend_id(Id,NestedId),
7698 append([Susps|VarsSusp],ExtraVars,NestedVars),
7699 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7700 NestedCall = NestedHead,
7702 Prelude = (
7703 PreludeHead :-
7704 FirstMatching,
7705 FirstSuspGoal,
7706 !,
7707 CondAllocation,
7708 NestedCall
7709 ),
7710 add_dummy_location(Prelude,LocatedPrelude),
7711 L = [LocatedPrelude|T].
7713 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7714 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7715 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7716 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7718 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7719 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7720 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7721 inc_id(Id,IncId),
7722 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7724 %check_fd_lookup_condition(_,_,_,_) :- fail.
7725 check_fd_lookup_condition(F,A,_,_) :-
7726 get_store_type(F/A,global_singleton), !.
7727 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7728 \+ may_trigger(F/A),
7729 get_functional_dependency(F/A,1,P,K),
7730 copy_term(P-K,CurrentHead-Key),
7731 term_variables(PreHeads,PreVars),
7732 intersect_eq(Key,PreVars,Key),!.
7734 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7735 Rule = rule(_,H2,Guard,Body),
7736 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7737 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7738 init(AllSusps,RestSusps),
7739 last(AllSusps,Susp),
7740 gen_var(OtherSusp),
7741 gen_var(OtherSusps),
7742 functor(CurrentHead,OtherF,OtherA),
7743 gen_vars(OtherA,OtherVars),
7744 delay_phase_end(validate_store_type_assumptions,
7745 ( static_suspension_term(OtherF/OtherA,Suspension),
7746 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7747 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7748 )
7749 ),
7750 % create_get_mutable_ref(active,State,GetMutable),
7751 CurrentSuspTest = (
7752 OtherSusp = Suspension,
7753 GetState
7754 ),
7755 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7756 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7757 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7758 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7759 RecursiveVars = PreVarsAndSusps1
7760 ;
7761 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7762 PrevId0 = Id
7763 ),
7764 ( PrevId0 = [_] ->
7765 PrevId = PrevId0
7766 ;
7767 PrevId = [O|PrevId0]
7768 ),
7769 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7770 RecursiveCall = RecursiveHead,
7771 CurrentHead =.. [_|OtherArgs],
7772 pairup(OtherArgs,OtherVars,OtherPairs),
7773 get_constraint_mode(OtherF/OtherA,Mode),
7774 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7776 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7777 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7778 get_occurrence(F/A,O,_,ID),
7780 ( is_observed(F/A,O) ->
7781 init(FirstVarsSusp,FirstVars),
7782 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7783 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7784 ;
7785 Attachment = true,
7786 ConditionalRecursiveCall = RecursiveCall
7787 ),
7788 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7789 NovelProduction = true,
7790 ExtendHistory = true
7791 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7792 NovelProduction = true,
7793 ExtendHistory = true
7794 ;
7795 get_occurrence(F/A,O,_,ID),
7796 use_auxiliary_predicate(novel_production),
7797 use_auxiliary_predicate(extend_history),
7798 does_use_history(F/A,O),
7799 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7800 ( HistoryIDs == [] ->
7801 empty_named_history_novel_production(HistoryName,NovelProduction),
7802 empty_named_history_extend_history(HistoryName,ExtendHistory)
7803 ;
7804 reverse([OtherSusp|RestSusps],NamedSusps),
7805 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7806 HistorySusps = [HistorySusp|_],
7808 ( length(HistoryIDs, 1) ->
7809 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7810 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7811 ;
7812 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7813 Tuple =.. [t,HistoryName|HistorySusps]
7814 )
7815 )
7816 ;
7817 HistorySusp = Susp,
7818 maplist(extract_symbol,H2,ConstraintSymbols),
7819 sort([ID|RestIDs],HistoryIDs),
7820 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7821 Tuple =.. [t,RuleNb|HistorySusps]
7822 ),
7824 ( var(NovelProduction) ->
7825 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7826 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7827 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7828 ;
7829 true
7830 )
7831 ),
7834 ( chr_pp_flag(debugable,on) ->
7835 Rule = rule(_,_,Guard,Body),
7836 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7837 get_occurrence(F/A,O,_,ID),
7838 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7839 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7840 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7841 ;
7842 DebugTry = true,
7843 DebugApply = true
7844 ),
7846 ( is_stored_in_guard(F/A, RuleNb) ->
7847 GuardAttachment = Attachment,
7848 BodyAttachment = true
7849 ;
7850 GuardAttachment = true,
7851 BodyAttachment = Attachment % will be true if not observed at all
7852 ),
7854 Clause = (
7855 ClauseHead :-
7856 ( CurrentSuspTest,
7857 DiffSuspGoals,
7858 Matching,
7859 NovelProduction,
7860 GuardAttachment,
7861 GuardCopy,
7862 DebugTry ->
7863 DebugApply,
7864 ExtendHistory,
7865 BodyAttachment,
7866 BodyCopy,
7867 ConditionalRecursiveCall
7868 ; RecursiveCall
7869 )
7870 ),
7871 add_location(Clause,RuleNb,LocatedClause),
7872 L = [LocatedClause|T].
7874 extract_symbol(Head,F/A) :-
7875 functor(Head,F,A).
7877 novel_production_calls([],[],[],_,_,true).
7878 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7879 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7880 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7881 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7883 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7884 reverse(ReversedRestSusps,RestSusps),
7885 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7887 named_history_susps([],_,_,[]).
7888 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7889 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7890 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7894 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7895 !,
7896 functor(Head,F,A),
7897 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7898 get_constraint_mode(F/A,Mode),
7899 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7900 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7901 append(VarsSusp,ExtraVars,HeadVars).
7902 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7903 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7904 functor(Head,F,A),
7905 gen_var(Susps),
7906 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7907 get_constraint_mode(F/A,Mode),
7908 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7909 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7910 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7912 % returns
7913 % VarDict for the copies of variables in the original heads
7914 % VarsSuspsList list of lists of arguments for the successive heads
7915 % FirstVarsSusp top level arguments
7916 % SuspList list of all suspensions
7917 % Iterators list of all iterators
7918 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7919 !,
7920 functor(Head,F,A),
7921 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7922 get_constraint_mode(F/A,Mode),
7923 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7924 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7925 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7926 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7927 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7928 functor(Head,F,A),
7929 gen_var(Susps),
7930 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7931 get_constraint_mode(F/A,Mode),
7932 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7933 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7934 append(HeadVars,[Susp,Susps],Vars).
7936 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7937 !,
7938 functor(Head,F,A),
7939 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7940 get_constraint_mode(F/A,Mode),
7941 head_arg_matches(Pairs,Mode,[],_,VarDict),
7942 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7943 append(VarsSusp,ExtraVars,HeadVars).
7944 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7945 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7946 functor(Head,F,A),
7947 gen_var(Susps),
7948 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7949 get_constraint_mode(F/A,Mode),
7950 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7951 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7952 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7954 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7956 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7957 %% ____ _ _ _ _
7958 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7959 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7960 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7961 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7962 %%
7963 %% ____ _ _ _
7964 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7965 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7966 %% | _ < __/ |_| | | | __/\ V / (_| | |
7967 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7968 %%
7969 %% ____ _ _
7970 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7971 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7972 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7973 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7974 %% |___/
7976 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7977 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7978 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7979 ;
7980 NRestHeads = RestHeads,
7981 NRestIDs = RestIDs
7982 ).
7984 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7985 term_variables(Head,Vars),
7986 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7987 copy_term_nat(InitialData,InitialDataCopy),
7988 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7989 InitialDataCopy = InitialData,
7990 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7991 reverse(RNRestHeads,NRestHeads),
7992 reverse(RNRestIDs,NRestIDs).
7994 final_data(Entry) :-
7995 Entry = entry(_,_,_,_,[],_).
7997 expand_data(Entry,NEntry,Cost) :-
7998 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7999 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8000 term_variables([Head1|Vars],Vars1),
8001 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8002 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8004 % Assigns score to head based on known variables and heads to lookup
8005 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score).
8006 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8007 functor(Head,F,A),
8008 get_store_type(F/A,StoreType),
8009 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
8011 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
8012 term_variables(Head,HeadVars),
8013 term_variables(RestHeads,RestVars),
8014 order_score_vars(HeadVars,KnownVars,RestVars,Score).
8015 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
8016 order_score_indexes(Indexes,Head,KnownVars,0,Score).
8017 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
8018 order_score_indexes(Indexes,Head,KnownVars,0,Score).
8019 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8020 term_variables(Head,HeadVars),
8021 term_variables(RestHeads,RestVars),
8022 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8023 Score is Score_ * 2.
8024 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
8025 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
8026 Score = 1. % guaranteed O(1)
8028 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8029 maplist(order_score1(Head,ID,KnownVars,RestHeads,RuleNb),StoreTypes,Scores),
8030 min_list(Scores,Score).
8031 order_score1(Head,ID,KnownVars,RestHeads,RuleNb,StoreType,Score) :-
8032 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score) ->
8033 true
8034 ;
8035 Score = 10000
8036 ).
8037 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8038 Score = 10.
8039 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8040 Score = 10.
8042 order_score_indexes([],_,_,Score,NScore) :-
8043 Score > 0, NScore = 100.
8044 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
8045 multi_hash_key_args(I,Head,Args), % TOM: not accurate enough? should look at vars?
8046 ( maplist(memberchk_eq_flip(KnownVars),Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8047 Score1 is Score + 1
8048 ;
8049 Score1 = Score
8050 ),
8051 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
8053 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8055 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8056 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8057 ( K-R-O == 0-0-0 ->
8058 Score = 0
8059 ; K > 0 ->
8060 Score is max(10 - K,0)
8061 ; R > 0 ->
8062 Score is max(10 - R,1) * 10
8063 ;
8064 Score is max(10-O,1) * 100
8065 ).
8066 order_score_count_vars([],_,_,0-0-0).
8067 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8068 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8069 ( memberchk_eq(V,KnownVars) ->
8070 NK is K + 1,
8071 NR = R, NO = O
8072 ; memberchk_eq(V,RestVars) ->
8073 NR is R + 1,
8074 NK = K, NO = O
8075 ;
8076 NO is O + 1,
8077 NK = K, NR = R
8078 ).
8080 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8081 %% ___ _ _ _
8082 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8083 %% | || '_ \| | | '_ \| | '_ \ / _` |
8084 %% | || | | | | | | | | | | | | (_| |
8085 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8086 %% |___/
8088 %% SWI begin
8089 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8090 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8091 %% SWI end
8093 %% SICStus begin
8094 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8095 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8096 %% SICStus end
8098 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8100 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8101 %% _ _ _ _ _ _ _
8102 %% | | | | |_(_) (_) |_ _ _
8103 %% | | | | __| | | | __| | | |
8104 %% | |_| | |_| | | | |_| |_| |
8105 %% \___/ \__|_|_|_|\__|\__, |
8106 %% |___/
8108 % Create a fresh variable.
8109 gen_var(_).
8111 % Create =N= fresh variables.
8112 gen_vars(N,Xs) :-
8113 length(Xs,N).
8115 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8116 vars_susp(A,Vars,Susp,VarsSusp),
8117 Head =.. [_|Args],
8118 pairup(Args,Vars,HeadPairs).
8120 inc_id([N|Ns],[O|Ns]) :-
8121 O is N + 1.
8122 dec_id([N|Ns],[M|Ns]) :-
8123 M is N - 1.
8125 extend_id(Id,[0|Id]).
8127 next_id([_,N|Ns],[O|Ns]) :-
8128 O is N + 1.
8130 % return clause Head
8131 % for F/A constraint symbol, predicate identifier Id and arguments Head
8132 build_head(F,A,Id,Args,Head) :-
8133 buildName(F,A,Id,Name),
8134 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8135 ( may_trigger(F/A) ;
8136 get_allocation_occurrence(F/A,AO),
8137 get_max_occurrence(F/A,MO),
8138 MO >= AO ) ) ->
8139 Head =.. [Name|Args]
8140 ;
8141 init(Args,ArgsWOSusp), % XXX not entirely correct!
8142 Head =.. [Name|ArgsWOSusp]
8143 ).
8145 % return predicate name Result
8146 % for Fct/Aty constraint symbol and predicate identifier List
8147 buildName(Fct,Aty,List,Result) :-
8148 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8149 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8150 MO >= AO ) ; List \= [0])) ) ) ->
8151 atom_concat(Fct, '___' ,FctSlash),
8152 atomic_concat(FctSlash,Aty,FctSlashAty),
8153 buildName_(List,FctSlashAty,Result)
8154 ;
8155 Result = Fct
8156 ).
8158 buildName_([],Name,Name).
8159 buildName_([N|Ns],Name,Result) :-
8160 buildName_(Ns,Name,Name1),
8161 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8162 atomic_concat(NameDash,N,Result).
8164 vars_susp(A,Vars,Susp,VarsSusp) :-
8165 length(Vars,A),
8166 append(Vars,[Susp],VarsSusp).
8168 or_pattern(Pos,Pat) :-
8169 Pow is Pos - 1,
8170 Pat is 1 << Pow. % was 2 ** X
8172 and_pattern(Pos,Pat) :-
8173 X is Pos - 1,
8174 Y is 1 << X, % was 2 ** X
8175 Pat is (-1)*(Y + 1).
8177 make_name(Prefix,F/A,Name) :-
8178 atom_concat_list([Prefix,F,'___',A],Name).
8180 %===============================================================================
8181 % Attribute for attributed variables
8183 make_attr(N,Mask,SuspsList,Attr) :-
8184 length(SuspsList,N),
8185 Attr =.. [v,Mask|SuspsList].
8187 get_all_suspensions2(N,Attr,SuspensionsList) :-
8188 chr_pp_flag(dynattr,off), !,
8189 make_attr(N,_,SuspensionsList,Attr).
8191 % NEW
8192 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8193 % writeln(get_all_suspensions2),
8194 length(SuspensionsList,N),
8195 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8198 % NEW
8199 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8200 % writeln(normalize_attr),
8201 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8203 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8204 chr_pp_flag(dynattr,off), !,
8205 make_attr(N,_,SuspsList,Attr),
8206 nth1(Position,SuspsList,Suspensions).
8208 % NEW
8209 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8210 % writeln(get_suspensions),
8211 Goal =
8212 ( memberchk(Position-Suspensions,TAttr) ->
8213 true
8214 ;
8215 Suspensions = []
8216 ).
8218 %-------------------------------------------------------------------------------
8219 % +N: number of constraint symbols
8220 % +Suspension: source-level variable, for suspension
8221 % +Position: constraint symbol number
8222 % -Attr: source-level term, for new attribute
8223 singleton_attr(N,Suspension,Position,Attr) :-
8224 chr_pp_flag(dynattr,off), !,
8225 or_pattern(Position,Pattern),
8226 make_attr(N,Pattern,SuspsList,Attr),
8227 nth1(Position,SuspsList,[Suspension]),
8228 chr_delete(SuspsList,[Suspension],RestSuspsList),
8229 set_elems(RestSuspsList,[]).
8231 % NEW
8232 singleton_attr(N,Suspension,Position,Attr) :-
8233 % writeln(singleton_attr),
8234 Attr = [Position-[Suspension]].
8236 %-------------------------------------------------------------------------------
8237 % +N: number of constraint symbols
8238 % +Suspension: source-level variable, for suspension
8239 % +Position: constraint symbol number
8240 % +TAttr: source-level variable, for old attribute
8241 % -Goal: goal for creating new attribute
8242 % -NTAttr: source-level variable, for new attribute
8243 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8244 chr_pp_flag(dynattr,off), !,
8245 make_attr(N,Mask,SuspsList,Attr),
8246 or_pattern(Position,Pattern),
8247 nth1(Position,SuspsList,Susps),
8248 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8249 make_attr(N,Mask,SuspsList1,NewAttr1),
8250 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8251 make_attr(N,NewMask,SuspsList2,NewAttr2),
8252 Goal = (
8253 TAttr = Attr,
8254 ( Mask /\ Pattern =:= Pattern ->
8255 NTAttr = NewAttr1
8256 ;
8257 NewMask is Mask \/ Pattern,
8258 NTAttr = NewAttr2
8259 )
8260 ), !.
8262 % NEW
8263 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8264 % writeln(add_attr),
8265 Goal =
8266 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8267 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8268 ;
8269 NTAttr = [Position-[Suspension]|TAttr]
8270 ).
8272 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8273 chr_pp_flag(dynattr,off), !,
8274 or_pattern(Position,Pattern),
8275 and_pattern(Position,DelPattern),
8276 make_attr(N,Mask,SuspsList,Attr),
8277 nth1(Position,SuspsList,Susps),
8278 substitute_eq(Susps,SuspsList,[],SuspsList1),
8279 make_attr(N,NewMask,SuspsList1,Attr1),
8280 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8281 make_attr(N,Mask,SuspsList2,Attr2),
8282 get_target_module(Mod),
8283 Goal = (
8284 TAttr = Attr,
8285 ( Mask /\ Pattern =:= Pattern ->
8286 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8287 ( NewSusps == [] ->
8288 NewMask is Mask /\ DelPattern,
8289 ( NewMask == 0 ->
8290 del_attr(Var,Mod)
8291 ;
8292 put_attr(Var,Mod,Attr1)
8293 )
8294 ;
8295 put_attr(Var,Mod,Attr2)
8296 )
8297 ;
8298 true
8299 )
8300 ), !.
8302 % NEW
8303 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8304 % writeln(rem_attr),
8305 get_target_module(Mod),
8306 Goal =
8307 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8308 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8309 ( NSuspensions == [] ->
8310 ( RAttr == [] ->
8311 del_attr(Var,Mod)
8312 ;
8313 put_attr(Var,Mod,RAttr)
8314 )
8315 ;
8316 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8317 )
8318 ;
8319 true
8320 ).
8322 %-------------------------------------------------------------------------------
8323 % +N: number of constraint symbols
8324 % +TAttr1: source-level variable, for attribute
8325 % +TAttr2: source-level variable, for other attribute
8326 % -Goal: goal for merging the two attributes
8327 % -Attr: source-level term, for merged attribute
8328 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8329 chr_pp_flag(dynattr,off), !,
8330 make_attr(N,Mask1,SuspsList1,Attr1),
8331 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8332 Goal = (
8333 TAttr1 = Attr1,
8334 Goal2
8335 ).
8337 % NEW
8338 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8339 % writeln(merge_attributes),
8340 Goal = (
8341 sort(TAttr1,Sorted1),
8342 sort(TAttr2,Sorted2),
8343 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8344 ).
8347 %-------------------------------------------------------------------------------
8348 % +N: number of constraint symbols
8349 % +Mask1: ...
8350 % +SuspsList1: static term, for suspensions list
8351 % +TAttr2: source-level variable, for other attribute
8352 % -Goal: goal for merging the two attributes
8353 % -Attr: source-level term, for merged attribute
8354 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8355 make_attr(N,Mask2,SuspsList2,Attr2),
8356 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8357 list2conj(Gs,SortGoals),
8358 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8359 make_attr(N,Mask,SuspsList,Attr),
8360 Goal = (
8361 TAttr2 = Attr2,
8362 SortGoals,
8363 Mask is Mask1 \/ Mask2
8364 ).
8367 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8368 % Storetype dependent lookup
8370 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8371 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8372 %% -Goal,-SuspensionList) is det.
8373 %
8374 % Create a universal lookup goal for given head.
8375 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8376 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8377 functor(Head,F,A),
8378 get_store_type(F/A,StoreType),
8379 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8381 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8382 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8383 %% -Goal,-SuspensionList) is det.
8384 %
8385 % Create a universal lookup goal for given head.
8386 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8387 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8388 functor(Head,F,A),
8389 get_store_type(F/A,StoreType),
8390 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8392 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8393 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8394 %% +GroundVars,-Goal,-SuspensionList) is det.
8395 %
8396 % Create a universal lookup goal for given head.
8397 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8398 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8399 functor(Head,F,A),
8400 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8401 update_store_type(F/A,default).
8402 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8403 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8404 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8405 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8406 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,(Goal,AllSusps \== []),AllSusps) :-
8407 functor(Head,F,A),
8408 global_ground_store_name(F/A,StoreName),
8409 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8410 update_store_type(F/A,global_ground).
8411 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8412 arg(VarIndex,Head,OVar),
8413 arg(KeyIndex,Head,OKey),
8414 translate([OVar,OKey],VarDict,[Var,Key]),
8415 get_target_module(Module),
8416 Goal = (
8417 get_attr(Var,Module,AssocStore),
8418 lookup_assoc_store(AssocStore,Key,AllSusps)
8419 ).
8420 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8421 functor(Head,F,A),
8422 global_singleton_store_name(F/A,StoreName),
8423 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8424 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8425 update_store_type(F/A,global_singleton).
8426 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8427 once((
8428 member(ST,StoreTypes),
8429 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8430 )).
8431 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8432 functor(Head,F,A),
8433 arg(Index,Head,Var),
8434 translate([Var],VarDict,[KeyVar]),
8435 delay_phase_end(validate_store_type_assumptions,
8436 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8437 ),
8438 update_store_type(F/A,identifier_store(Index)),
8439 get_identifier_index(F/A,Index,_).
8440 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8441 functor(Head,F,A),
8442 arg(Index,Head,Var),
8443 ( var(Var) ->
8444 translate([Var],VarDict,[KeyVar]),
8445 Goal = StructGoal
8446 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8447 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8448 Goal = (LookupGoal,StructGoal)
8449 ),
8450 delay_phase_end(validate_store_type_assumptions,
8451 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8452 ),
8453 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8454 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8456 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8457 get_identifier_size(ISize),
8458 functor(Struct,struct,ISize),
8459 get_identifier_index(C,Index,IIndex),
8460 arg(IIndex,Struct,AllSusps),
8461 Goal = (KeyVar = Struct).
8463 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8464 type_indexed_identifier_structure(IndexType,Struct),
8465 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8466 arg(IIndex,Struct,AllSusps),
8467 Goal = (KeyVar = Struct).
8469 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8470 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8471 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8472 %
8473 % Create a universal hash lookup goal for given head.
8474 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8475 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8476 once((
8477 member(Index,Indexes),
8478 multi_hash_key_args(Index,Head,KeyArgs),
8479 (
8480 translate(KeyArgs,VarDict,KeyArgCopies)
8481 ;
8482 ground(KeyArgs), KeyArgCopies = KeyArgs
8483 )
8484 )),
8485 ( KeyArgCopies = [KeyCopy] ->
8486 true
8487 ;
8488 KeyCopy =.. [k|KeyArgCopies]
8489 ),
8490 functor(Head,F,A),
8491 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8493 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8494 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8496 Goal = (GroundCheck,LookupGoal),
8498 ( HashType == inthash ->
8499 update_store_type(F/A,multi_inthash([Index]))
8500 ;
8501 update_store_type(F/A,multi_hash([Index]))
8502 ).
8504 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8505 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8506 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8507 %% +VarArgDict,-NewVarArgDict) is det.
8508 %
8509 % Create existential lookup goal for given head.
8510 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8511 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8512 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8513 sbag_member_call(Susp,AllSusps,Sbag),
8514 functor(Head,F,A),
8515 delay_phase_end(validate_store_type_assumptions,
8516 ( static_suspension_term(F/A,SuspTerm),
8517 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8518 )
8519 ),
8520 Goal = (
8521 UniversalGoal,
8522 Sbag,
8523 Susp = SuspTerm,
8524 GetState
8525 ).
8526 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8527 functor(Head,F,A),
8528 global_singleton_store_name(F/A,StoreName),
8529 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8530 Goal = (
8531 GetStoreGoal, % nb_getval(StoreName,Susp),
8532 Susp \== [],
8533 Susp = SuspTerm
8534 ),
8535 update_store_type(F/A,global_singleton).
8536 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8537 once((
8538 member(ST,StoreTypes),
8539 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8540 )).
8541 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8542 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8543 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8544 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8545 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8546 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8547 hash_index_filter(Pairs,Index,NPairs),
8549 functor(Head,F,A),
8550 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8551 Sbag = (AllSusps = [Susp])
8552 ;
8553 sbag_member_call(Susp,AllSusps,Sbag)
8554 ),
8555 delay_phase_end(validate_store_type_assumptions,
8556 ( static_suspension_term(F/A,SuspTerm),
8557 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8558 )
8559 ),
8560 Goal = (
8561 LookupGoal,
8562 Sbag,
8563 Susp = SuspTerm, % not inlined
8564 GetState
8565 ).
8566 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8567 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8568 hash_index_filter(Pairs,Index,NPairs),
8570 functor(Head,F,A),
8571 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8572 Sbag = (AllSusps = [Susp])
8573 ;
8574 sbag_member_call(Susp,AllSusps,Sbag)
8575 ),
8576 delay_phase_end(validate_store_type_assumptions,
8577 ( static_suspension_term(F/A,SuspTerm),
8578 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8579 )
8580 ),
8581 Goal = (
8582 LookupGoal,
8583 Sbag,
8584 Susp = SuspTerm, % not inlined
8585 GetState
8586 ).
8587 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8588 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8589 sbag_member_call(Susp,Susps,Sbag),
8590 functor(Head,F,A),
8591 delay_phase_end(validate_store_type_assumptions,
8592 ( static_suspension_term(F/A,SuspTerm),
8593 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8594 )
8595 ),
8596 Goal = (
8597 UGoal,
8598 Sbag,
8599 Susp = SuspTerm, % not inlined
8600 GetState
8601 ).
8603 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8604 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8605 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8606 %% +VarArgDict,-NewVarArgDict) is det.
8607 %
8608 % Create existential hash lookup goal for given head.
8609 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8610 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8611 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8613 hash_index_filter(Pairs,Index,NPairs),
8615 functor(Head,F,A),
8616 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8617 Sbag = (AllSusps = [Susp])
8618 ;
8619 sbag_member_call(Susp,AllSusps,Sbag)
8620 ),
8621 delay_phase_end(validate_store_type_assumptions,
8622 ( static_suspension_term(F/A,SuspTerm),
8623 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8624 )
8625 ),
8626 Goal = (
8627 LookupGoal,
8628 Sbag,
8629 Susp = SuspTerm, % not inlined
8630 GetState
8631 ).
8633 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8634 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8635 %
8636 % Filter out pairs already covered by given hash index.
8637 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8638 hash_index_filter(Pairs,Index,NPairs) :-
8639 hash_index_filter(Pairs,Index,1,NPairs).
8641 hash_index_filter([],_,_,[]).
8642 hash_index_filter([P|Ps],Index,N,NPairs) :-
8643 ( Index = [I|Is] ->
8644 NN is N + 1,
8645 ( I > N ->
8646 NPairs = [P|NPs],
8647 hash_index_filter(Ps,[I|Is],NN,NPs)
8648 ; I == N ->
8649 hash_index_filter(Ps,Is,NN,NPairs)
8650 )
8651 ;
8652 NPairs = [P|Ps]
8653 ).
8655 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8656 %------------------------------------------------------------------------------%
8657 %% assume_constraint_stores(+ConstraintSymbols) is det.
8658 %
8659 % Compute all constraint store types that are possible for the given
8660 % =ConstraintSymbols=.
8661 %------------------------------------------------------------------------------%
8662 assume_constraint_stores([]).
8663 assume_constraint_stores([C|Cs]) :-
8664 ( chr_pp_flag(debugable,off),
8665 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8666 is_stored(C),
8667 get_store_type(C,default) ->
8668 get_indexed_arguments(C,AllIndexedArgs),
8669 get_constraint_mode(C,Modes),
8670 aggregate_all(bag(Index)-count,
8671 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8672 IndexedArgs-NbIndexedArgs),
8673 % Construct Index Combinations
8674 ( NbIndexedArgs > 10 ->
8675 findall([Index],member(Index,IndexedArgs),Indexes)
8676 ;
8677 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8678 predsort(longer_list,UnsortedIndexes,Indexes)
8679 ),
8680 % EXPERIMENTAL HEURISTIC
8681 % findall(Index, (
8682 % member(Arg1,IndexedArgs),
8683 % member(Arg2,IndexedArgs),
8684 % Arg1 =< Arg2,
8685 % sort([Arg1,Arg2], Index)
8686 % ), UnsortedIndexes),
8687 % predsort(longer_list,UnsortedIndexes,Indexes),
8688 % Choose Index Type
8689 ( get_functional_dependency(C,1,Pattern,Key),
8690 all_distinct_var_args(Pattern), Key == [] ->
8691 assumed_store_type(C,global_singleton)
8692 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8693 get_constraint_type_det(C,ArgTypes),
8694 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8696 ( IntHashIndexes = [] ->
8697 Stores = Stores1
8698 ;
8699 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8700 ),
8701 ( HashIndexes = [] ->
8702 Stores1 = Stores2
8703 ;
8704 Stores1 = [multi_hash(HashIndexes)|Stores2]
8705 ),
8706 ( IdentifierIndexes = [] ->
8707 Stores2 = Stores3
8708 ;
8709 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8710 append(WrappedIdentifierIndexes,Stores3,Stores2)
8711 ),
8712 append(CompoundIdentifierIndexes,Stores4,Stores3),
8713 ( only_ground_indexed_arguments(C)
8714 -> Stores4 = [global_ground]
8715 ; Stores4 = [default]
8716 ),
8717 assumed_store_type(C,multi_store(Stores))
8718 ; true
8719 )
8720 ;
8721 true
8722 ),
8723 assume_constraint_stores(Cs).
8725 %------------------------------------------------------------------------------%
8726 %% partition_indexes(+Indexes,+Types,
8727 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8728 %------------------------------------------------------------------------------%
8729 partition_indexes([],_,[],[],[],[]).
8730 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8731 ( Index = [I],
8732 nth1(I,Types,Type),
8733 unalias_type(Type,UnAliasedType),
8734 UnAliasedType == chr_identifier ->
8735 IdentifierIndexes = [I|RIdentifierIndexes],
8736 IntHashIndexes = RIntHashIndexes,
8737 HashIndexes = RHashIndexes,
8738 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8739 ; Index = [I],
8740 nth1(I,Types,Type),
8741 unalias_type(Type,UnAliasedType),
8742 nonvar(UnAliasedType),
8743 UnAliasedType = chr_identifier(IndexType) ->
8744 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8745 IdentifierIndexes = RIdentifierIndexes,
8746 IntHashIndexes = RIntHashIndexes,
8747 HashIndexes = RHashIndexes
8748 ; Index = [I],
8749 nth1(I,Types,Type),
8750 unalias_type(Type,UnAliasedType),
8751 UnAliasedType == dense_int ->
8752 IntHashIndexes = [Index|RIntHashIndexes],
8753 HashIndexes = RHashIndexes,
8754 IdentifierIndexes = RIdentifierIndexes,
8755 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8756 ; member(I,Index),
8757 nth1(I,Types,Type),
8758 unalias_type(Type,UnAliasedType),
8759 nonvar(UnAliasedType),
8760 UnAliasedType = chr_identifier(_) ->
8761 % don't use chr_identifiers in hash indexes
8762 IntHashIndexes = RIntHashIndexes,
8763 HashIndexes = RHashIndexes,
8764 IdentifierIndexes = RIdentifierIndexes,
8765 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8766 ;
8767 IntHashIndexes = RIntHashIndexes,
8768 HashIndexes = [Index|RHashIndexes],
8769 IdentifierIndexes = RIdentifierIndexes,
8770 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8771 ),
8772 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8774 longer_list(R,L1,L2) :-
8775 length(L1,N1),
8776 length(L2,N2),
8777 compare(Rt,N2,N1),
8778 ( Rt == (=) ->
8779 compare(R,L1,L2)
8780 ;
8781 R = Rt
8782 ).
8784 all_distinct_var_args(Term) :-
8785 copy_term_nat(Term,TermCopy),
8786 functor(Term,F,A),
8787 functor(Pattern,F,A),
8788 Pattern =@= TermCopy.
8790 get_indexed_arguments(C,IndexedArgs) :-
8791 C = F/A,
8792 get_indexed_arguments(1,A,C,IndexedArgs).
8794 get_indexed_arguments(I,N,C,L) :-
8795 ( I > N ->
8796 L = []
8797 ; ( is_indexed_argument(C,I) ->
8798 L = [I|T]
8799 ;
8800 L = T
8801 ),
8802 J is I + 1,
8803 get_indexed_arguments(J,N,C,T)
8804 ).
8806 validate_store_type_assumptions([]).
8807 validate_store_type_assumptions([C|Cs]) :-
8808 validate_store_type_assumption(C),
8809 validate_store_type_assumptions(Cs).
8811 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8812 % new code generation
8813 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8814 Rule = rule(H1,_,Guard,Body),
8815 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8816 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8817 flatten(VarsAndSuspsList,VarsAndSusps),
8818 Vars = [ [] | VarsAndSusps],
8819 build_head(F,A,[O|Id],Vars,Head),
8820 ( PrevId0 = [_] ->
8821 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8822 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8823 PrevId = [PredictedPrevId] % PrevId = PrevId0
8824 ;
8825 PrevId = [O|PrevId0]
8826 ),
8827 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8828 Clause = ( Head :- PredecessorCall),
8829 add_dummy_location(Clause,LocatedClause),
8830 L = [LocatedClause | T].
8831 % ( H1 == [],
8832 % functor(CurrentHead,CF,CA),
8833 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8834 % L = T
8835 % ;
8836 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8837 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8838 % flatten(VarsAndSuspsList,VarsAndSusps),
8839 % Vars = [ [] | VarsAndSusps],
8840 % build_head(F,A,Id,Vars,Head),
8841 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8842 % Clause = ( Head :- PredecessorCall),
8843 % L = [Clause | T]
8844 % ).
8846 % skips back intelligently over global_singleton lookups
8847 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8848 ( Id = [0|_] ->
8849 % TOM: add partial success continuation optimization here!
8850 next_id(Id,PrevId),
8851 PrevVarsAndSusps = BaseCallArgs
8852 ;
8853 VarsAndSuspsList = [_|AllButFirstList],
8854 dec_id(Id,PrevId1),
8855 ( PrevHeads = [PrevHead|PrevHeads1],
8856 functor(PrevHead,F,A),
8857 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8858 PrevIterators = [_|PrevIterators1],
8859 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8860 ;
8861 PrevId = PrevId1,
8862 flatten(AllButFirstList,AllButFirst),
8863 PrevIterators = [PrevIterator|_],
8864 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8865 )
8866 ).
8868 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8869 Rule = rule(_,_,Guard,Body),
8870 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8871 init(AllSusps,PreSusps),
8872 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8873 gen_var(OtherSusps),
8874 functor(CurrentHead,OtherF,OtherA),
8875 gen_vars(OtherA,OtherVars),
8876 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8877 get_constraint_mode(OtherF/OtherA,Mode),
8878 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8880 delay_phase_end(validate_store_type_assumptions,
8881 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8882 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8883 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8884 )
8885 ),
8887 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8888 % create_get_mutable_ref(active,State,GetMutable),
8889 CurrentSuspTest = (
8890 OtherSusp = OtherSuspension,
8891 GetState,
8892 DiffSuspGoals,
8893 FirstMatching
8894 ),
8895 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8896 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8897 inc_id(Id,NestedId),
8898 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8899 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8900 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8901 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8902 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
8904 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8905 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8906 RecursiveVars = PreVarsAndSusps1
8907 ;
8908 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8909 PrevId0 = Id
8910 ),
8911 ( PrevId0 = [_] ->
8912 PrevId = PrevId0
8913 ;
8914 PrevId = [O|PrevId0]
8915 ),
8916 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8918 Clause = (
8919 ClauseHead :-
8920 ( CurrentSuspTest,
8921 NextSuspGoal
8922 ->
8923 NestedHead
8924 ; RecursiveHead
8925 )
8926 ),
8927 add_dummy_location(Clause,LocatedClause),
8928 L = [LocatedClause|T].
8930 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8932 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8933 % Observation Analysis
8934 %
8935 % CLASSIFICATION
8936 % Enabled
8937 %
8938 % Analysis based on Abstract Interpretation paper.
8939 %
8940 % TODO:
8941 % stronger analysis domain [research]
8943 :- chr_constraint
8944 initial_call_pattern/1,
8945 call_pattern/1,
8946 call_pattern_worker/1,
8947 final_answer_pattern/2,
8948 abstract_constraints/1,
8949 depends_on/2,
8950 depends_on_ap/4,
8951 depends_on_goal/2,
8952 ai_observed_internal/2,
8953 % ai_observed/2,
8954 ai_not_observed_internal/2,
8955 ai_not_observed/2,
8956 ai_is_observed/2,
8957 depends_on_as/3,
8958 ai_observation_gather_results/0.
8960 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8961 :- chr_type program_point == any.
8963 :- chr_option(mode,initial_call_pattern(+)).
8964 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8966 :- chr_option(mode,call_pattern(+)).
8967 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8969 :- chr_option(mode,call_pattern_worker(+)).
8970 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8972 :- chr_option(mode,final_answer_pattern(+,+)).
8973 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8975 :- chr_option(mode,abstract_constraints(+)).
8976 :- chr_option(type_declaration,abstract_constraints(list)).
8978 :- chr_option(mode,depends_on(+,+)).
8979 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8981 :- chr_option(mode,depends_on_as(+,+,+)).
8982 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8983 :- chr_option(mode,depends_on_goal(+,+)).
8984 :- chr_option(mode,ai_is_observed(+,+)).
8985 :- chr_option(mode,ai_not_observed(+,+)).
8986 % :- chr_option(mode,ai_observed(+,+)).
8987 :- chr_option(mode,ai_not_observed_internal(+,+)).
8988 :- chr_option(mode,ai_observed_internal(+,+)).
8991 abstract_constraints_fd @
8992 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8994 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8995 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8996 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8998 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8999 ai_is_observed(_,_) <=> true.
9001 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9002 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9003 ai_observation_gather_results <=> true.
9005 %------------------------------------------------------------------------------%
9006 % Main Analysis Entry
9007 %------------------------------------------------------------------------------%
9008 ai_observation_analysis(ACs) :-
9009 ( chr_pp_flag(ai_observation_analysis,on),
9010 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9011 list_to_ord_set(ACs,ACSet),
9012 abstract_constraints(ACSet),
9013 ai_observation_schedule_initial_calls(ACSet,ACSet),
9014 ai_observation_gather_results
9015 ;
9016 true
9017 ).
9019 ai_observation_schedule_initial_calls([],_).
9020 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9021 ai_observation_schedule_initial_call(AC,ACs),
9022 ai_observation_schedule_initial_calls(RACs,ACs).
9024 ai_observation_schedule_initial_call(AC,ACs) :-
9025 ai_observation_top(AC,CallPattern),
9026 % ai_observation_bot(AC,ACs,CallPattern),
9027 initial_call_pattern(CallPattern).
9029 ai_observation_schedule_new_calls([],AP).
9030 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9031 AP = odom(_,Set),
9032 initial_call_pattern(odom(AC,Set)),
9033 ai_observation_schedule_new_calls(ACs,AP).
9035 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9036 <=>
9037 ai_observation_leq(AP2,AP1)
9038 |
9039 true.
9041 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9043 initial_call_pattern(CP) ==> call_pattern(CP).
9045 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9046 ==>
9047 ai_observation_schedule_new_calls(ACs,AP)
9048 pragma
9049 passive(ID3).
9051 call_pattern(CP) \ call_pattern(CP) <=> true.
9053 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9054 final_answer_pattern(CP1,AP).
9056 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9058 call_pattern(CP) ==> call_pattern_worker(CP).
9060 %------------------------------------------------------------------------------%
9061 % Abstract Goal
9062 %------------------------------------------------------------------------------%
9064 % AbstractGoala
9065 %call_pattern(odom([],Set)) ==>
9066 % final_answer_pattern(odom([],Set),odom([],Set)).
9068 call_pattern_worker(odom([],Set)) <=>
9069 % writeln(' - AbstractGoal'(odom([],Set))),
9070 final_answer_pattern(odom([],Set),odom([],Set)).
9072 % AbstractGoalb
9073 call_pattern_worker(odom([G|Gs],Set)) <=>
9074 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9075 CP1 = odom(G,Set),
9076 depends_on_goal(odom([G|Gs],Set),CP1),
9077 call_pattern(CP1).
9079 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9080 <=> true pragma passive(ID).
9081 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9082 ==>
9083 CP1 = odom([_|Gs],_),
9084 AP2 = odom([],Set),
9085 CCP = odom(Gs,Set),
9086 call_pattern(CCP),
9087 depends_on(CP1,CCP).
9089 %------------------------------------------------------------------------------%
9090 % Abstract Disjunction
9091 %------------------------------------------------------------------------------%
9093 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9094 CP = odom((AG1;AG2),Set),
9095 InitialAnswerApproximation = odom([],Set),
9096 final_answer_pattern(CP,InitialAnswerApproximation),
9097 CP1 = odom(AG1,Set),
9098 CP2 = odom(AG2,Set),
9099 call_pattern(CP1),
9100 call_pattern(CP2),
9101 depends_on_as(CP,CP1,CP2).
9103 %------------------------------------------------------------------------------%
9104 % Abstract Solve
9105 %------------------------------------------------------------------------------%
9106 call_pattern_worker(odom(builtin,Set)) <=>
9107 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9108 ord_empty(EmptySet),
9109 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9111 %------------------------------------------------------------------------------%
9112 % Abstract Drop
9113 %------------------------------------------------------------------------------%
9114 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9115 <=>
9116 O > MO
9117 |
9118 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9119 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9120 pragma
9121 passive(ID2).
9123 %------------------------------------------------------------------------------%
9124 % Abstract Activate
9125 %------------------------------------------------------------------------------%
9126 call_pattern_worker(odom(AC,Set))
9127 <=>
9128 AC = _ / _
9129 |
9130 % writeln(' - AbstractActivate'(odom(AC,Set))),
9131 CP = odom(occ(AC,1),Set),
9132 call_pattern(CP),
9133 depends_on(odom(AC,Set),CP).
9135 %------------------------------------------------------------------------------%
9136 % Abstract Passive
9137 %------------------------------------------------------------------------------%
9138 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9139 <=>
9140 is_passive(RuleNb,ID)
9141 |
9142 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9143 % DEFAULT
9144 NO is O + 1,
9145 DCP = odom(occ(C,NO),Set),
9146 call_pattern(DCP),
9147 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9148 depends_on(odom(occ(C,O),Set),DCP)
9149 pragma
9150 passive(ID2).
9151 %------------------------------------------------------------------------------%
9152 % Abstract Simplify
9153 %------------------------------------------------------------------------------%
9155 % AbstractSimplify
9156 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9157 <=>
9158 \+ is_passive(RuleNb,ID)
9159 |
9160 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9161 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9162 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9163 ai_observation_memo_abstract_goal(RuleNb,AG),
9164 call_pattern(odom(AG,Set2)),
9165 % DEFAULT
9166 NO is O + 1,
9167 DCP = odom(occ(C,NO),Set),
9168 call_pattern(DCP),
9169 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9170 % DEADLOCK AVOIDANCE
9171 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9172 pragma
9173 passive(ID2).
9175 depends_on_as(CP,CPS,CPD),
9176 final_answer_pattern(CPS,APS),
9177 final_answer_pattern(CPD,APD) ==>
9178 ai_observation_lub(APS,APD,AP),
9179 final_answer_pattern(CP,AP).
9182 :- chr_constraint
9183 ai_observation_memo_simplification_rest_heads/3,
9184 ai_observation_memoed_simplification_rest_heads/3.
9186 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9187 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9189 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9190 <=>
9191 QRH = RH.
9192 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9193 <=>
9194 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9195 once(select2(ID,_,IDs1,H1,_,RestH1)),
9196 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9197 ai_observation_abstract_constraints(H2,ACs,AH2),
9198 append(ARestHeads,AH2,AbstractHeads),
9199 sort(AbstractHeads,QRH),
9200 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9201 pragma
9202 passive(ID1),
9203 passive(ID2),
9204 passive(ID3).
9206 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9208 %------------------------------------------------------------------------------%
9209 % Abstract Propagate
9210 %------------------------------------------------------------------------------%
9213 % AbstractPropagate
9214 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9215 <=>
9216 \+ is_passive(RuleNb,ID)
9217 |
9218 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9219 % observe partners
9220 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9221 ai_observation_observe_set(Set,AHs,Set2),
9222 ord_add_element(Set2,C,Set3),
9223 ai_observation_memo_abstract_goal(RuleNb,AG),
9224 call_pattern(odom(AG,Set3)),
9225 ( ord_memberchk(C,Set2) ->
9226 Delete = no
9227 ;
9228 Delete = yes
9229 ),
9230 % DEFAULT
9231 NO is O + 1,
9232 DCP = odom(occ(C,NO),Set),
9233 call_pattern(DCP),
9234 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9235 pragma
9236 passive(ID2).
9238 :- chr_constraint
9239 ai_observation_memo_propagation_rest_heads/3,
9240 ai_observation_memoed_propagation_rest_heads/3.
9242 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9243 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9245 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9246 <=>
9247 QRH = RH.
9248 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9249 <=>
9250 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9251 once(select2(ID,_,IDs2,H2,_,RestH2)),
9252 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9253 ai_observation_abstract_constraints(H1,ACs,AH1),
9254 append(ARestHeads,AH1,AbstractHeads),
9255 sort(AbstractHeads,QRH),
9256 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9257 pragma
9258 passive(ID1),
9259 passive(ID2),
9260 passive(ID3).
9262 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9264 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9265 final_answer_pattern(CP,APD).
9266 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9267 final_answer_pattern(CPD,APD) ==>
9268 true |
9269 CP = odom(occ(C,O),_),
9270 ( ai_observation_is_observed(APP,C) ->
9271 ai_observed_internal(C,O)
9272 ;
9273 ai_not_observed_internal(C,O)
9274 ),
9275 ( Delete == yes ->
9276 APP = odom([],Set0),
9277 ord_del_element(Set0,C,Set),
9278 NAPP = odom([],Set)
9279 ;
9280 NAPP = APP
9281 ),
9282 ai_observation_lub(NAPP,APD,AP),
9283 final_answer_pattern(CP,AP).
9285 %------------------------------------------------------------------------------%
9286 % Catch All
9287 %------------------------------------------------------------------------------%
9289 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9291 %------------------------------------------------------------------------------%
9292 % Auxiliary Predicates
9293 %------------------------------------------------------------------------------%
9295 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9296 ord_intersection(S1,S2,S3).
9298 ai_observation_bot(AG,AS,odom(AG,AS)).
9300 ai_observation_top(AG,odom(AG,EmptyS)) :-
9301 ord_empty(EmptyS).
9303 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9304 ord_subset(S2,S1).
9306 ai_observation_observe_set(S,ACSet,NS) :-
9307 ord_subtract(S,ACSet,NS).
9309 ai_observation_abstract_constraint(C,ACs,AC) :-
9310 functor(C,F,A),
9311 AC = F/A,
9312 memberchk(AC,ACs).
9314 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9315 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9317 %------------------------------------------------------------------------------%
9318 % Abstraction of Rule Bodies
9319 %------------------------------------------------------------------------------%
9321 :- chr_constraint
9322 ai_observation_memoed_abstract_goal/2,
9323 ai_observation_memo_abstract_goal/2.
9325 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9326 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9328 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9329 <=>
9330 QAG = AG
9331 pragma
9332 passive(ID1).
9334 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9335 <=>
9336 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9337 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9338 QAG = AG,
9339 ai_observation_memoed_abstract_goal(RuleNb,AG)
9340 pragma
9341 passive(ID1),
9342 passive(ID2).
9344 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9345 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9346 term_variables((H1,H2,Guard),HVars),
9347 append(H1,H2,Heads),
9348 % variables that are declared to be ground are safe,
9349 ground_vars(Heads,GroundVars),
9350 % so we remove them from the list of 'dangerous' head variables
9351 list_difference_eq(HVars,GroundVars,HV),
9352 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9353 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9354 % HV are 'dangerous' variables, all others are fresh and safe
9356 ground_vars([],[]).
9357 ground_vars([H|Hs],GroundVars) :-
9358 functor(H,F,A),
9359 get_constraint_mode(F/A,Mode),
9360 % TOM: fix this code!
9361 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9362 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9363 ground_vars(Hs,GroundVars2),
9364 append(GroundVars1,GroundVars2,GroundVars).
9366 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9367 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9368 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9369 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9370 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9371 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9372 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9373 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9374 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9375 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9376 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9377 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9378 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9379 % non-CHR constraint is safe if it only binds fresh variables
9380 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9381 builtin_binds_b(G,Vars),
9382 intersect_eq(Vars,HV,[]),
9383 !.
9384 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9385 AG = builtin. % default case if goal is not recognized/safe
9387 ai_observation_is_observed(odom(_,ACSet),AC) :-
9388 \+ ord_memberchk(AC,ACSet).
9390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9391 unconditional_occurrence(C,O) :-
9392 get_occurrence(C,O,RuleNb,ID),
9393 get_rule(RuleNb,PRule),
9394 PRule = pragma(ORule,_,_,_,_),
9395 copy_term_nat(ORule,Rule),
9396 Rule = rule(H1,H2,Guard,_),
9397 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9398 once((
9399 H1 = [Head], H2 == []
9400 ;
9401 H2 = [Head], H1 == [], \+ may_trigger(C)
9402 )),
9403 all_distinct_var_args(Head).
9405 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9407 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9408 % Partial wake analysis
9409 %
9410 % In a Var = Var unification do not wake up constraints of both variables,
9411 % but rather only those of one variable.
9412 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9414 :- chr_constraint partial_wake_analysis/0.
9415 :- chr_constraint no_partial_wake/1.
9416 :- chr_option(mode,no_partial_wake(+)).
9417 :- chr_constraint wakes_partially/1.
9418 :- chr_option(mode,wakes_partially(+)).
9420 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9421 ==>
9422 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9423 ( is_passive(RuleNb,ID) ->
9424 true
9425 ; Type == simplification ->
9426 select(H,H1,RestH1),
9427 H =.. [_|Args],
9428 term_variables(Guard,Vars),
9429 partial_wake_args(Args,ArgModes,Vars,FA)
9430 ; % Type == propagation ->
9431 select(H,H2,RestH2),
9432 H =.. [_|Args],
9433 term_variables(Guard,Vars),
9434 partial_wake_args(Args,ArgModes,Vars,FA)
9435 ).
9437 partial_wake_args([],_,_,_).
9438 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9439 ( Mode \== (+) ->
9440 ( nonvar(Arg) ->
9441 no_partial_wake(C)
9442 ; memberchk_eq(Arg,Vars) ->
9443 no_partial_wake(C)
9444 ;
9445 true
9446 )
9447 ;
9448 true
9449 ),
9450 partial_wake_args(Args,Modes,Vars,C).
9452 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9454 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9456 wakes_partially(C) <=> true.
9459 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9460 % Generate rules that implement chr_show_store/1 functionality.
9461 %
9462 % CLASSIFICATION
9463 % Experimental
9464 % Unused
9465 %
9466 % Generates additional rules:
9467 %
9468 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9469 % ...
9470 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9471 % $show <=> true.
9473 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9474 ( chr_pp_flag(show,on) ->
9475 Constraints = ['$show'/0|Constraints0],
9476 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9477 inc_rule_count(RuleNb),
9478 Rule = pragma(
9479 rule(['$show'],[],true,true),
9480 ids([0],[]),
9481 [],
9482 no,
9483 RuleNb
9484 )
9485 ;
9486 Constraints = Constraints0,
9487 Rules = Rules0
9488 ).
9490 generate_show_rules([],Rules,Rules).
9491 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9492 functor(C,F,A),
9493 inc_rule_count(RuleNb),
9494 Rule = pragma(
9495 rule([],['$show',C],true,writeln(C)),
9496 ids([],[0,1]),
9497 [passive(1)],
9498 no,
9499 RuleNb
9500 ),
9501 generate_show_rules(Rest,Tail,Rules).
9503 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9504 % Custom supension term layout
9506 static_suspension_term(F/A,Suspension) :-
9507 suspension_term_base(F/A,Base),
9508 Arity is Base + A,
9509 functor(Suspension,suspension,Arity).
9511 has_suspension_field(FA,Field) :-
9512 suspension_term_base_fields(FA,Fields),
9513 memberchk(Field,Fields).
9515 suspension_term_base(FA,Base) :-
9516 suspension_term_base_fields(FA,Fields),
9517 length(Fields,Base).
9519 suspension_term_base_fields(FA,Fields) :-
9520 ( chr_pp_flag(debugable,on) ->
9521 % 1. ID
9522 % 2. State
9523 % 3. Propagation History
9524 % 4. Generation Number
9525 % 5. Continuation Goal
9526 % 6. Functor
9527 Fields = [id,state,history,generation,continuation,functor]
9528 ;
9529 ( uses_history(FA) ->
9530 Fields = [id,state,history|Fields2]
9531 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9532 Fields = [state|Fields2]
9533 ;
9534 Fields = [id,state|Fields2]
9535 ),
9536 ( only_ground_indexed_arguments(FA) ->
9537 get_store_type(FA,StoreType),
9538 basic_store_types(StoreType,BasicStoreTypes),
9539 ( memberchk(global_ground,BasicStoreTypes) ->
9540 % 1. ID
9541 % 2. State
9542 % 3. Propagation History
9543 % 4. Global List Prev
9544 Fields2 = [global_list_prev|Fields3]
9545 ;
9546 % 1. ID
9547 % 2. State
9548 % 3. Propagation History
9549 Fields2 = Fields3
9550 ),
9551 ( chr_pp_flag(ht_removal,on)
9552 -> ht_prev_fields(BasicStoreTypes,Fields3)
9553 ; Fields3 = []
9554 )
9555 ; may_trigger(FA) ->
9556 % 1. ID
9557 % 2. State
9558 % 3. Propagation History
9559 ( uses_field(FA,generation) ->
9560 % 4. Generation Number
9561 % 5. Global List Prev
9562 Fields2 = [generation,global_list_prev|Fields3]
9563 ;
9564 Fields2 = [global_list_prev|Fields3]
9565 ),
9566 ( chr_pp_flag(mixed_stores,on),
9567 chr_pp_flag(ht_removal,on)
9568 -> get_store_type(FA,StoreType),
9569 basic_store_types(StoreType,BasicStoreTypes),
9570 ht_prev_fields(BasicStoreTypes,Fields3)
9571 ; Fields3 = []
9572 )
9573 ;
9574 % 1. ID
9575 % 2. State
9576 % 3. Propagation History
9577 % 4. Global List Prev
9578 Fields2 = [global_list_prev|Fields3],
9579 ( chr_pp_flag(mixed_stores,on),
9580 chr_pp_flag(ht_removal,on)
9581 -> get_store_type(FA,StoreType),
9582 basic_store_types(StoreType,BasicStoreTypes),
9583 ht_prev_fields(BasicStoreTypes,Fields3)
9584 ; Fields3 = []
9585 )
9586 )
9587 ).
9589 ht_prev_fields(Stores,Prevs) :-
9590 ht_prev_fields_int(Stores,PrevsList),
9591 append(PrevsList,Prevs).
9592 ht_prev_fields_int([],[]).
9593 ht_prev_fields_int([H|T],Fields) :-
9594 ( H = multi_hash(Indexes)
9595 -> maplist(ht_prev_field,Indexes,FH),
9596 Fields = [FH|FT]
9597 ; Fields = FT
9598 ),
9599 ht_prev_fields_int(T,FT).
9601 ht_prev_field(Index,Field) :-
9602 concat_atom(['multi_hash_prev-'|Index],Field).
9604 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9605 suspension_term_base_fields(FA,Fields),
9606 nth1(Index,Fields,FieldName), !,
9607 arg(Index,StaticSuspension,Field).
9608 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9609 suspension_term_base(FA,Base),
9610 StaticSuspension =.. [_|Args],
9611 drop(Base,Args,Field).
9612 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9613 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9616 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9617 suspension_term_base_fields(FA,Fields),
9618 nth1(Index,Fields,FieldName), !,
9619 Goal = arg(Index,DynamicSuspension,Field).
9620 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9621 static_suspension_term(FA,StaticSuspension),
9622 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9623 Goal = (DynamicSuspension = StaticSuspension).
9624 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9625 suspension_term_base(FA,Base),
9626 Index is I + Base,
9627 Goal = arg(Index,DynamicSuspension,Field).
9628 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9629 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9632 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9633 suspension_term_base_fields(FA,Fields),
9634 nth1(Index,Fields,FieldName), !,
9635 Goal = setarg(Index,DynamicSuspension,Field).
9636 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9637 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9639 basic_store_types(multi_store(Types),Types) :- !.
9640 basic_store_types(Type,[Type]).
9642 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9643 %
9645 :- chr_constraint
9646 phase_end/1,
9647 delay_phase_end/2.
9649 :- chr_option(mode,phase_end(+)).
9650 :- chr_option(mode,delay_phase_end(+,?)).
9652 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9653 % phase_end(Phase) <=> true.
9656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9657 :- chr_constraint
9658 does_use_history/2,
9659 uses_history/1,
9660 novel_production_call/4.
9662 :- chr_option(mode,uses_history(+)).
9663 :- chr_option(mode,does_use_history(+,+)).
9664 :- chr_option(mode,novel_production_call(+,+,?,?)).
9666 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9667 does_use_history(FA,_) \ uses_history(FA) <=> true.
9668 uses_history(_FA) <=> fail.
9670 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9671 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9673 :- chr_constraint
9674 does_use_field/2,
9675 uses_field/2.
9677 :- chr_option(mode,uses_field(+,+)).
9678 :- chr_option(mode,does_use_field(+,+)).
9680 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9681 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9682 uses_field(_FA,_Field) <=> fail.
9684 :- chr_constraint
9685 uses_state/2,
9686 if_used_state/5,
9687 used_states_known/0.
9689 :- chr_option(mode,uses_state(+,+)).
9690 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9693 % states ::= not_stored_yet | passive | active | triggered | removed
9694 %
9695 % allocate CREATES not_stored_yet
9696 % remove CHECKS not_stored_yet
9697 % activate CHECKS not_stored_yet
9698 %
9699 % ==> no allocate THEN no not_stored_yet
9701 % recurs CREATES inactive
9702 % lookup CHECKS inactive
9704 % insert CREATES active
9705 % activate CREATES active
9706 % lookup CHECKS active
9707 % recurs CHECKS active
9709 % runsusp CREATES triggered
9710 % lookup CHECKS triggered
9711 %
9712 % ==> no runsusp THEN no triggered
9714 % remove CREATES removed
9715 % runsusp CHECKS removed
9716 % lookup CHECKS removed
9717 % recurs CHECKS removed
9718 %
9719 % ==> no remove THEN no removed
9721 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9723 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9725 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9726 <=> ResultGoal = Used.
9727 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9728 <=> ResultGoal = NotUsed.
9730 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9731 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9732 % (Feature for SSS)
9733 %
9734 % 1. Checking
9735 % ~~~~~~~~~~~
9736 %
9737 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9738 %
9739 % :- chr_option(declare_stored_constraints,on).
9740 %
9741 % the compiler will check for the storedness of constraints.
9742 %
9743 % By default, the compiler assumes that the programmer wants his constraints to
9744 % be never-stored. Hence, a warning will be issues when a constraint is actually
9745 % stored.
9746 %
9747 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9748 % to a constraint declaration, i.e. writes
9749 %
9750 % :- chr_constraint c(...) # stored.
9751 %
9752 % In that case a warning is issued when the constraint is never-stored.
9753 %
9754 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9755 % constraints are stored anyway.
9756 %
9757 %
9758 % 2. Rule Generation
9759 % ~~~~~~~~~~~~~~~~~~
9760 %
9761 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9762 %
9763 % :- chr_option(declare_stored_constraints,on).
9764 %
9765 % the compiler will generate default simplification rules for constraints.
9766 %
9767 % By default, no default rule is generated for a constraint. However, if the
9768 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9769 %
9770 % :- chr_constraint c(...) # default(Goal).
9771 %
9772 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9773 % the compiler generates a rule:
9774 %
9775 % c(_,...,_) <=> Goal.
9776 %
9777 % at the end of the program. If multiple default rules are generated, for several constraints,
9778 % then the order of the default rules is not specified.
9781 :- chr_constraint stored_assertion/1.
9782 :- chr_option(mode,stored_assertion(+)).
9783 :- chr_option(type_declaration,stored_assertion(constraint)).
9785 :- chr_constraint never_stored_default/2.
9786 :- chr_option(mode,never_stored_default(+,?)).
9787 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9789 % Rule Generation
9790 % ~~~~~~~~~~~~~~~
9792 generate_never_stored_rules(Constraints,Rules) :-
9793 ( chr_pp_flag(declare_stored_constraints,on) ->
9794 never_stored_rules(Constraints,Rules)
9795 ;
9796 Rules = []
9797 ).
9799 :- chr_constraint never_stored_rules/2.
9800 :- chr_option(mode,never_stored_rules(+,?)).
9801 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9803 never_stored_rules([],Rules) <=> Rules = [].
9804 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9805 Constraint = F/A,
9806 functor(Head,F,A),
9807 inc_rule_count(RuleNb),
9808 Rule = pragma(
9809 rule([Head],[],true,Goal),
9810 ids([0],[]),
9811 [],
9812 no,
9813 RuleNb
9814 ),
9815 Rules = [Rule|Tail],
9816 never_stored_rules(Constraints,Tail).
9817 never_stored_rules([_|Constraints],Rules) <=>
9818 never_stored_rules(Constraints,Rules).
9820 % Checking
9821 % ~~~~~~~~
9823 check_storedness_assertions(Constraints) :-
9824 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9825 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9826 ;
9827 true
9828 ).
9831 :- chr_constraint check_storedness_assertion/1.
9832 :- chr_option(mode,check_storedness_assertion(+)).
9833 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9835 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9836 <=> ( is_stored(Constraint) ->
9837 true
9838 ;
9839 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9840 ).
9841 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9842 <=> ( is_finally_stored(Constraint) ->
9843 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9844 ; is_stored(Constraint) ->
9845 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9846 ;
9847 true
9848 ).
9849 % never-stored, no default goal
9850 check_storedness_assertion(Constraint)
9851 <=> ( is_finally_stored(Constraint) ->
9852 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9853 ; is_stored(Constraint) ->
9854 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9855 ;
9856 true
9857 ).
9859 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9860 % success continuation analysis
9862 % TODO
9863 % also use for forward jumping improvement!
9864 % use Prolog indexing for generated code
9865 %
9866 % EXPORTED
9867 %
9868 % should_skip_to_next_id(C,O)
9869 %
9870 % get_occurrence_code_id(C,O,Id)
9871 %
9872 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9874 continuation_analysis(ConstraintSymbols) :-
9875 maplist(analyse_continuations,ConstraintSymbols).
9877 analyse_continuations(C) :-
9878 % 1. compute success continuations of the
9879 % occurrences of constraint C
9880 continuation_analysis(C,1),
9881 % 2. determine for which occurrences
9882 % to skip to next code id
9883 get_max_occurrence(C,MO),
9884 LO is MO + 1,
9885 bulk_propagation(C,1,LO),
9886 % 3. determine code id for each occurrence
9887 set_occurrence_code_id(C,1,0).
9889 % 1. Compute the success continuations of constrait C
9890 %-------------------------------------------------------------------------------
9892 continuation_analysis(C,O) :-
9893 get_max_occurrence(C,MO),
9894 ( O > MO ->
9895 true
9896 ; O == MO ->
9897 NextO is O + 1,
9898 continuation_occurrence(C,O,NextO)
9899 ;
9900 constraint_continuation(C,O,MO,NextO),
9901 continuation_occurrence(C,O,NextO),
9902 NO is O + 1,
9903 continuation_analysis(C,NO)
9904 ).
9906 constraint_continuation(C,O,MO,NextO) :-
9907 ( get_occurrence_head(C,O,Head) ->
9908 NO is O + 1,
9909 ( between(NO,MO,NextO),
9910 get_occurrence_head(C,NextO,NextHead),
9911 unifiable(Head,NextHead,_) ->
9912 true
9913 ;
9914 NextO is MO + 1
9915 )
9916 ; % current occurrence is passive
9917 NextO = MO
9918 ).
9920 get_occurrence_head(C,O,Head) :-
9921 get_occurrence(C,O,RuleNb,Id),
9922 \+ is_passive(RuleNb,Id),
9923 get_rule(RuleNb,Rule),
9924 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
9925 ( select2(Id,Head,Ids1,H1,_,_) -> true
9926 ; select2(Id,Head,Ids2,H2,_,_)
9927 ).
9929 :- chr_constraint continuation_occurrence/3.
9930 :- chr_option(mode,continuation_occurrence(+,+,+)).
9932 :- chr_constraint get_success_continuation_occurrence/3.
9933 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
9935 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
9936 <=>
9937 X = NO.
9939 get_success_continuation_occurrence(C,O,X)
9940 <=>
9941 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
9943 % 2. figure out when to skip to next code id
9944 %-------------------------------------------------------------------------------
9945 % don't go beyond the last occurrence
9946 % we have to go to next id for storage here
9948 :- chr_constraint skip_to_next_id/2.
9949 :- chr_option(mode,skip_to_next_id(+,+)).
9951 :- chr_constraint should_skip_to_next_id/2.
9952 :- chr_option(mode,should_skip_to_next_id(+,+)).
9954 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
9955 <=>
9956 true.
9958 should_skip_to_next_id(_,_)
9959 <=>
9960 fail.
9962 :- chr_constraint bulk_propagation/3.
9963 :- chr_option(mode,bulk_propagation(+,+,+)).
9965 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
9966 <=>
9967 O >= MO
9968 |
9969 skip_to_next_id(C,O).
9970 % we have to go to the next id here because
9971 % a predecessor needs it
9972 bulk_propagation(C,O,LO)
9973 <=>
9974 LO =:= O + 1
9975 |
9976 skip_to_next_id(C,O),
9977 get_max_occurrence(C,MO),
9978 NLO is MO + 1,
9979 bulk_propagation(C,LO,NLO).
9980 % we have to go to the next id here because
9981 % we're running into a simplification rule
9982 % IMPROVE: propagate back to propagation predecessor (IF ANY)
9983 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
9984 <=>
9985 NO =:= O + 1
9986 |
9987 skip_to_next_id(C,O),
9988 get_max_occurrence(C,MO),
9989 NLO is MO + 1,
9990 bulk_propagation(C,NO,NLO).
9991 % we skip the next id here
9992 % and go to the next occurrence
9993 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
9994 <=>
9995 NextO > O + 1
9996 |
9997 NLO is min(LO,NextO),
9998 NO is O + 1,
9999 bulk_propagation(C,NO,NLO).
10000 % default case
10001 % err on the safe side
10002 bulk_propagation(C,O,LO)
10003 <=>
10004 skip_to_next_id(C,O),
10005 get_max_occurrence(C,MO),
10006 NLO is MO + 1,
10007 NO is O + 1,
10008 bulk_propagation(C,NO,NLO).
10010 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10012 % if this occurrence is passive, but has to skip,
10013 % then the previous one must skip instead...
10014 % IMPROVE reasoning is conservative
10015 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10016 ==>
10017 O > 1
10018 |
10019 PO is O - 1,
10020 skip_to_next_id(C,PO).
10022 % 3. determine code id of each occurrence
10023 %-------------------------------------------------------------------------------
10025 :- chr_constraint set_occurrence_code_id/3.
10026 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10028 :- chr_constraint occurrence_code_id/3.
10029 :- chr_option(mode,occurrence_code_id(+,+,+)).
10031 % stop at the end
10032 set_occurrence_code_id(C,O,IdNb)
10033 <=>
10034 get_max_occurrence(C,MO),
10035 O > MO
10036 |
10037 occurrence_code_id(C,O,IdNb).
10039 % passive occurrences don't change the code id
10040 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10041 <=>
10042 occurrence_code_id(C,O,IdNb),
10043 NO is O + 1,
10044 set_occurrence_code_id(C,NO,IdNb).
10046 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10047 <=>
10048 occurrence_code_id(C,O,IdNb),
10049 NO is O + 1,
10050 set_occurrence_code_id(C,NO,IdNb).
10052 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10053 <=>
10054 occurrence_code_id(C,O,IdNb),
10055 NO is O + 1,
10056 NIdNb is IdNb + 1,
10057 set_occurrence_code_id(C,NO,NIdNb).
10059 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10060 <=>
10061 occurrence_code_id(C,O,IdNb),
10062 NO is O + 1,
10063 set_occurrence_code_id(C,NO,IdNb).
10065 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10067 :- chr_constraint get_occurrence_code_id/3.
10068 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10070 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10071 <=>
10072 X = IdNb.
10074 get_occurrence_code_id(C,O,X)
10075 <=>
10076 ( O == 0 ->
10077 true % X = 0
10078 ;
10079 format('no occurrence code for ~w!\n',[C:O])
10080 ).
10082 get_success_continuation_code_id(C,O,NextId) :-
10083 get_success_continuation_occurrence(C,O,NextO),
10084 get_occurrence_code_id(C,NextO,NextId).
10086 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10087 % COLLECT CONSTANTS FOR INLINING
10088 %
10089 % for SSS
10091 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10092 collect_constants(Rules,Constraints,Clauses0) :-
10093 ( not_restarted ->
10094 maplist(collect_rule_constants(Constraints),Rules),
10095 ( chr_pp_flag(verbose,on) ->
10096 print_chr_constants
10097 ;
10098 true
10099 ),
10100 ( chr_pp_flag(experiment,on) ->
10101 flattening_dictionary(Constraints,Dictionary),
10102 copy_term_nat([dict(Dictionary)|Clauses0],Clauses),
10103 flatten_clauses(Clauses,FlatClauses),
10104 install_new_declarations_and_restart(FlatClauses)
10105 ;
10106 true
10107 )
10108 ;
10109 true
10110 ).
10112 :- chr_constraint chr_constants/2.
10113 :- chr_option(mode,chr_constants(+,+)).
10115 :- chr_constraint get_chr_constants/2.
10117 chr_constants(Key,Constants) \ get_chr_constants(Key,Q) <=> Q = Constants.
10119 get_chr_constants(Key,Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10121 % collect_rule_constants(+constraint_symbols,+rule) {{{
10122 collect_rule_constants(Constraints,Rule) :-
10123 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10124 maplist(collect_head_constants,H1),
10125 maplist(collect_head_constants,H2),
10126 collect_body_constants(B,Constraints).
10128 collect_body_constants(Body,Constraints) :-
10129 conj2list(Body,Goals),
10130 maplist(collect_goal_constants(Constraints),Goals).
10132 collect_goal_constants(Constraints,Goal) :-
10133 ( nonvar(Goal),
10134 functor(Goal,C,N),
10135 memberchk(C/N,Constraints) ->
10136 collect_head_constants(Goal)
10137 ; nonvar(Goal),
10138 Goal = Mod : TheGoal,
10139 get_target_module(Module),
10140 Mod == Module,
10141 nonvar(TheGoal),
10142 functor(TheGoal,C,N),
10143 memberchk(C/N,Constraints) ->
10144 collect_head_constants(TheGoal)
10145 ;
10146 true
10147 ).
10149 collect_head_constants(Head) :-
10150 functor(Head,C,N),
10151 get_constraint_type_det(C/N,Types),
10152 Head =.. [_|Args],
10153 maplist(collect_arg_constants,Args,Types).
10155 collect_arg_constants(Arg,Type) :-
10156 ( ground(Arg),
10157 unalias_type(Type,chr_constants(Key)) ->
10158 add_chr_constant(Key,Arg)
10159 ;
10160 true
10161 ).
10162 :- chr_constraint add_chr_constant/2.
10163 :- chr_option(mode,add_chr_constant(+,+)).
10165 add_chr_constant(Key,Constant) , chr_constants(Key,Constants) <=>
10166 sort([Constant|Constants],NConstants),
10167 chr_constants(Key,NConstants).
10169 add_chr_constant(Key,Constant) <=>
10170 chr_constants(Key,[Constant]).
10172 % }}}
10174 :- chr_constraint print_chr_constants/0. % {{{
10176 print_chr_constants, chr_constants(Key,Constants) # Id ==>
10177 format('\t* chr_constants ~w : ~w.\n',[Key,Constants])
10178 pragma passive(Id).
10180 print_chr_constants <=>
10181 true.
10183 % }}}
10185 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10186 flattening_dictionary([],[]).
10187 flattening_dictionary([CS|CSs],Dictionary) :-
10188 ( flattening_dictionary_entry(CS,Entry) ->
10189 Dictionary = [Entry|Rest]
10190 ;
10191 Dictionary = Rest
10192 ),
10193 flattening_dictionary(CSs,Rest).
10195 flattening_dictionary_entry(CS,Entry) :-
10196 get_constraint_arg_type(CS,Pos,Type),
10197 Type = chr_constants(Key), !,
10198 get_chr_constants(Key,Constants),
10199 Entry = CS-Pos-Specs,
10200 maplist(flat_spec(CS,Pos),Constants,Specs).
10202 flat_spec(C/N,Pos,Term,Spec) :-
10203 Spec = Term - Functor,
10204 term_to_atom(Term,TermAtom),
10205 atom_concat_list(['$flat_',C,'/',N,'___',Pos,'___',TermAtom],Functor).
10206 % }}}
10208 % }}}
10209 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10210 % RESTART AFTER FLATTENING {{{
10212 restart_after_flattening(Declarations,Declarations) :-
10213 nb_setval('$chr_restart_after_flattening',started).
10214 restart_after_flattening(_,Declarations) :-
10215 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10216 nb_setval('$chr_restart_after_flattening',restarted).
10218 not_restarted :-
10219 nb_getval('$chr_restart_after_flattening',started).
10221 install_new_declarations_and_restart(Declarations) :-
10222 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10223 fail. /* fails to choicepoint of restart_after_flattening */
10224 % }}}
10225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10226 % FLATTENING {{{
10228 % DONE
10229 % -) generate dictionary from collected chr_constants
10230 % enable with :- chr_option(experiment,on).
10231 % -) issue constraint declarations for constraints not present in
10232 % dictionary
10233 %
10234 % TODO:
10235 % -) integrate with CHR compiler
10236 % RELEASE-----------------------------------------------------------------
10237 % -) pass Mike's test code (full syntactic support for current CHR code)
10238 % -) rewrite the body using the inliner
10239 % -) refined semantics correctness issue
10240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10242 flatten_clauses(Clauses0,NClauses) :-
10243 select(dict(Dict),Clauses0,Clauses),
10244 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10245 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10247 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10248 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10249 dispatching_rules(Dict,NClauses1),
10250 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10251 flatten_rules(Clauses,Dict,NClauses3),
10252 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10254 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10255 % Declarations for non-flattened constraints
10257 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10258 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10259 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_,Dict)),Symbols),
10260 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10261 flatten(DeclarationsList,Declarations).
10263 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10264 [(:- chr_constraint ConstraintSymbol),
10265 (:- chr_option(mode,ModeDeclPattern)),
10266 (:- chr_option(type_declaration,TypeDeclPattern))
10267 ]) :-
10268 ConstraintSymbol = Functor / Arity,
10269 % print optional mode declaration
10270 functor(ModeDeclPattern,Functor,Arity),
10271 ( memberchk(ModeDeclPattern,ModeDecls) ->
10272 true
10273 ;
10274 replicate(Arity,(?),Modes),
10275 ModeDeclPattern =.. [_|Modes]
10276 ),
10277 % print optional type declaration
10278 functor(TypeDeclPattern,Functor,Arity),
10279 ( memberchk(TypeDeclPattern,TypeDecls) ->
10280 true
10281 ;
10282 replicate(Arity,any,Types),
10283 TypeDeclPattern =.. [_|Types]
10284 ).
10285 % }}}
10286 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10287 % read clauses from file
10288 % CHR are returned
10289 % declared constaints are returned
10290 % type definitions are returned and printed
10291 % mode declarations are returned
10292 % other clauses are returned
10294 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10295 flatten_readcontent([],[],[],[],[],[],[]).
10296 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10297 % read(Clause),
10298 ( Clause == end_of_file ->
10299 Rules = [],
10300 ConstraintSymbols = [],
10301 ModeDecls = [],
10302 TypeDecls = [],
10303 TypeDefs = [],
10304 RestClauses = []
10305 ; crude_is_rule(Clause) ->
10306 Rules = [Clause|RestRules],
10307 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10308 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10309 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10310 append(SomeModeDecls,RestModeDecls,ModeDecls),
10311 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10312 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10313 ; is_mode_declaration(Clause,ModeDecl) ->
10314 ModeDecls = [ModeDecl|RestModeDecls],
10315 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10316 ; is_type_declaration(Clause,TypeDecl) ->
10317 TypeDecls = [TypeDecl|RestTypeDecls],
10318 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10319 ; is_type_definition(Clause,TypeDef) ->
10320 RestClauses = [Clause|NRestClauses],
10321 TypeDefs = [TypeDef|RestTypeDefs],
10322 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10323 ; ( Clause = (:- op(A,B,C)) ->
10324 % assert operators in order to read and print them out properly
10325 op(A,B,C)
10326 ;
10327 true
10328 ),
10329 RestClauses = [Clause|NRestClauses],
10330 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10331 ).
10333 crude_is_rule(_ @ _).
10334 crude_is_rule(_ pragma _).
10335 crude_is_rule(_ ==> _).
10336 crude_is_rule(_ <=> _).
10338 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10339 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10340 conj2list(Cs,Constraints0),
10341 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10343 pure_extract_type_mode([],[],[],[]).
10344 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10345 pure_extract_type_mode(R,R2,Modes,Types).
10346 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10347 functor(C,F,A),
10348 ConstraintSymbol = F/A,
10349 C =.. [_|Args],
10350 extract_types_and_modes(Args,ArgTypes,ArgModes),
10351 Mode =.. [F|ArgModes],
10352 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10353 Types = RTypes
10354 ;
10355 Types = [Type|RTypes],
10356 Type =.. [F|ArgTypes]
10357 ),
10358 pure_extract_type_mode(R,R2,Modes,RTypes).
10360 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10362 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10363 % }}}
10364 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10365 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10366 % including mode and type declarations
10368 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10369 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10370 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10371 flatten(ConstraintSpecs0,ConstraintSpecs).
10373 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10374 [(:- chr_constraint ConstraintSpec),
10375 (:- chr_option(mode,NewModeDecl)),
10376 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10377 member(C/N-I-SFs,Dict),
10378 arg_modes(C,N,ModeDecls,Modes),
10379 specialize_modes(Modes,I,SpecializedModes),
10380 arg_types(C,N,TypeDecls,Types),
10381 specialize_types(Types,I,SpecializedTypes),
10382 AN is N - 1,
10383 member(_Term-F,SFs),
10384 ConstraintSpec = F/AN,
10385 NewModeDecl =.. [F|SpecializedModes],
10386 NewTypeDecl =.. [F|SpecializedTypes].
10388 arg_modes(C,N,ModeDecls,ArgModes) :-
10389 functor(ConstraintPattern,C,N),
10390 ( memberchk(ConstraintPattern,ModeDecls) ->
10391 ConstraintPattern =.. [_|ArgModes]
10392 ;
10393 replicate(N,?,ArgModes)
10394 ).
10396 specialize_modes(Modes,I,SpecializedModes) :-
10397 split(Modes,I,Before,_At,After),
10398 append(Before,After,SpecializedModes).
10400 arg_types(C,N,TypeDecls,ArgTypes) :-
10401 functor(ConstraintPattern,C,N),
10402 ( memberchk(ConstraintPattern,TypeDecls) ->
10403 ConstraintPattern =.. [_|ArgTypes]
10404 ;
10405 replicate(N,any,ArgTypes)
10406 ).
10408 specialize_types(Types,I,SpecializedTypes) :-
10409 split(Types,I,Before,_At,After),
10410 append(Before,After,SpecializedTypes).
10411 % }}}
10413 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10414 % DISPATCHING RULES
10415 %
10416 % dispatching_rules(+dict,-newrules)
10418 % {{{
10419 dispatching_rules([],[]).
10420 dispatching_rules([CN-I-SFs|Dict], DispatchingRules) :-
10421 constraint_dispatching_rule(SFs,CN,I,DispatchingRules,RestDispatchingRules),
10422 dispatching_rules(Dict,RestDispatchingRules).
10424 constraint_dispatching_rule(SFs,CN,I,Rules,RestRules) :-
10425 ( I == 1 ->
10426 /* index on first argument */
10427 Rules0 = Rules,
10428 NCN = CN
10429 ;
10430 CN = C/N,
10431 /* reorder arguments for 1st argument indexing */
10432 functor(Head,C,N),
10433 Head =.. [_|Args],
10434 split(Args,I,BeforeArgs,IndexArg,AfterArgs),
10435 append([IndexArg|BeforeArgs],AfterArgs,ShuffledArgs),
10436 atom_concat(C,'_$shuffled',NC),
10437 Body =.. [NC|ShuffledArgs],
10438 [(Head :- Body)|Rules0] = Rules,
10439 NCN = NC / N
10440 ),
10441 dispatching_rule_term_cases(SFs,NCN,Rules0,RestRules).
10442 % dispatching_rule_cases(SFs,NCN,Rules0,RestRules).
10444 dispatching_rule_term_cases(SFs,NC/N,Rules,RestRules) :-
10445 once(pairup(Terms,Functors,SFs)),
10446 length(Terms,K),
10447 replicate(K,[],MorePatterns),
10448 Payload is N - 1,
10449 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10450 dispatch_trie_index([Terms|MorePatterns],Payload,Actions,NC,Rules,RestRules).
10452 dispatching_action(Functor,PayloadArgs,Goal) :-
10453 Goal =.. [Functor|PayloadArgs].
10455 % dispatching_rule_cases([],C/N,Rules,RestRules) :-
10456 % functor(Head,C,N),
10457 % arg(1,Head,IndexArg),
10458 % Body = throw(wrong_argument(C/N,IndexArg)),
10459 % Rules = [(Head :- Body)|RestRules].
10460 % dispatching_rule_cases([Term-Name|SFs],C/N,[Rule|Rules],RestRules) :-
10461 % functor(Head,C,N),
10462 % Head =.. [_,IndexArg|RestArgs],
10463 % IndexArg = Term,
10464 % Body =.. [Name|RestArgs],
10465 % Rule = (Head :- !, Body),
10466 % dispatching_rule_special(SFs,C/N,Rules,RestRules).
10468 dispatch_trie_index([Patterns|MorePatterns],Payload,Actions,Prefix,Clauses,Tail) :-
10469 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,Actions,Clauses,Tail).
10471 dispatch_trie_step([],_,_,_,[],[],L,L) :- !.
10472 % length MorePatterns == length Patterns == length Results
10473 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,Actions,Clauses,T) :-
10474 writeln(dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,Actions,Clauses,T)),
10475 MorePatterns = [List|_],
10476 length(List,N),
10477 aggregate_all(set(F/A),
10478 ( member(Pattern,Patterns),
10479 functor(Pattern,F,A)
10480 ),
10481 FAs),
10482 N1 is N + 1,
10483 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,T).
10485 dispatch_trie_step_cases([],_,_,_,_,_,_,_,Clauses,Clauses).
10486 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,Tail) :-
10487 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,Clauses1),
10488 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses1,Tail).
10490 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10491 Clause = (Head :- Body),
10492 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10493 N1 is N + Payload,
10494 functor(Head,Symbol,N1),
10495 arg(1,Head,IndexPattern),
10496 Head =.. [_,_|RestArgs],
10497 length(PayloadArgs,Payload),
10498 once(append(Vs,PayloadArgs,RestArgs)),
10499 /* IndexPattern = F(...) */
10500 functor(IndexPattern,F,A),
10501 IndexPattern =.. [_|Args],
10502 append(Args,RestArgs,RecArgs),
10503 ( RecArgs == PayloadArgs ->
10504 /* nothing more to match on */
10505 List = Tail,
10506 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10507 MoreActions = [Action],
10508 call(Action,PayloadArgs,Body)
10509 ; /* more things to match on */
10510 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10511 ( MoreActions = [OneMoreAction] ->
10512 /* only one more thing to match on */
10513 List = Tail,
10514 call(OneMoreAction,PayloadArgs,Body)
10515 ;
10516 /* more than one thing to match on */
10517 /* [ x1,..., xn]
10518 [xs1,...,xsn]
10519 */
10520 pairup(Cases,MoreCases,CasePairs),
10521 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10522 append(Args,Vs,[First|Rest]),
10523 First-Rest = CommonPatternPair,
10524 gensym(Prefix,RSymbol),
10525 append(DiffVars,PayloadArgs,RecCallVars),
10526 Body =.. [RSymbol|RecCallVars],
10527 findall(CH-CT,member([CH|CT],Differences),CPairs),
10528 once(pairup(CHs,CTs,CPairs)),
10529 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MoreActions,List,Tail)
10530 )
10531 ).
10534 % split(list,int,before,at,after).
10536 split([X|Xs],I,Before,At,After) :-
10537 ( I == 1 ->
10538 Before = [],
10539 At = X,
10540 After = Xs
10541 ;
10542 J is I - 1,
10543 Before = [X|RBefore],
10544 split(Xs,J,RBefore,At,After)
10545 ).
10547 % }}}
10548 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10549 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10550 %
10551 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10552 %
10553 % dict :== list(functor/arity-int-list(term-functor))
10555 % {{{
10556 flatten_rules(Rules,Dict,FlatRules) :-
10557 flatten_rules1(Rules,Dict,FlatRulesList),
10558 flatten(FlatRulesList,FlatRules).
10560 flatten_rules1([],_,[]).
10561 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10562 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10563 flatten_rules1(Rules,Dict,FlatRulesList).
10565 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10566 flatten_rule(Rule,Dict,NRule).
10567 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10568 flatten_rule(Rule,Dict,NRule).
10569 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10570 flatten_heads(H,Dict,NH),
10571 flatten_body(B,Dict,NB).
10572 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10573 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10574 flatten_body(B,Dict,NB).
10575 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10576 flatten_heads(H,Dict,NH),
10577 flatten_body(B,Dict,NB).
10579 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10580 flatten_heads(H1,Dict,NH1),
10581 flatten_heads(H2,Dict,NH2).
10582 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10583 flatten_heads(H,Dict,NH).
10584 flatten_heads(H,Dict,NH) :-
10585 ( functor(H,C,N),
10586 memberchk(C/N-I-SFs,Dict) ->
10587 H =.. [_|AllArgs],
10588 split(AllArgs,I,PreArgs,Arg,PostArgs),
10589 member(Term-Name,SFs),
10590 Arg = Term,
10591 append(PreArgs,PostArgs,FlatArgs),
10592 NH =.. [Name|FlatArgs]
10593 ;
10594 NH = H
10595 ).
10597 flatten_body(Body,Dict,NBody) :-
10598 conj2list(Body,Goals),
10599 maplist(flatten_goal(Dict),Goals,NGoals),
10600 list2conj(NGoals,NBody).
10602 flatten_goal(Dict,Goal,NGoal) :-
10603 ( is_specializable_goal(Goal,Dict,ArgPos)
10604 ->
10605 specialize_goal(Goal,ArgPos,NGoal)
10606 ; nonvar(Goal),
10607 Goal = Mod : TheGoal,
10608 get_target_module(Module),
10609 Mod == Module,
10610 is_specializable_goal(TheGoal,Dict,ArgPos)
10611 ->
10612 specialize_goal(TheGoal,ArgPos,NTheGoal),
10613 NGoal = Mod : NTheGoal
10614 ;
10615 NGoal = Goal
10616 ).
10618 is_specializable_goal(Goal,Dict,ArgPos) :-
10619 nonvar(Goal),
10620 functor(Goal,C,N),
10621 memberchk(C/N-ArgPos-_,Dict),
10622 arg(ArgPos,Goal,Arg),
10623 ground(Arg).
10626 specialize_goal(Goal,ArgPos,NGoal) :-
10627 functor(Goal,C,N),
10628 Goal =.. [_|Args],
10629 split(Args,ArgPos,Before,Arg,After),
10630 append(Before,After,NArgs),
10631 flat_spec(C/N,ArgPos,Arg,_-Functor),
10632 NGoal =.. [Functor|NArgs].
10633 % }}}
10635 % }}}
10636 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10637 dump_code(Clauses) :-
10638 ( chr_pp_flag(dump,on) ->
10639 maplist(portray_clause,Clauses)
10640 ;
10641 true
10642 ).
10644 chr_banner :-
10645 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',[]).