| blob | e373202bd1912d62a834b6b7cd146aaf9d21428d |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% TODO {{{
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * analyze history usage to determine whether/when
64 %% cheaper suspension is possible:
65 %% don't use history when all partners are passive and self never triggers
66 %% * store constraint unconditionally for unconditional propagation rule,
67 %% if first, i.e. without checking history and set trigger cont to next occ
68 %% * get rid of suspension passing for never triggered constraints,
69 %% up to allocation occurrence
70 %% * get rid of call indirection for never triggered constraints
71 %% up to first allocation occurrence.
72 %% * get rid of unnecessary indirection if last active occurrence
73 %% before unconditional removal is head2, e.g.
74 %% a \ b <=> true.
75 %% a <=> true.
76 %% * Eliminate last clause of never stored constraint, if its body
77 %% is fail, e.g.
78 %% a ...
79 %% a <=> fail.
80 %% * Specialize lookup operations and indexes for functional dependencies.
81 %%
82 %% MORE TODO
83 %%
84 %% * map A \ B <=> true | true rules
85 %% onto efficient code that empties the constraint stores of B
86 %% in O(1) time for ground constraints where A and B do not share
87 %% any variables
88 %% * ground matching seems to be not optimized for compound terms
89 %% in case of simpagation_head2 and propagation occurrences
90 %% * analysis for storage delaying (see primes for case)
91 %% * internal constraints declaration + analyses?
92 %% * Do not store in global variable store if not necessary
93 %% NOTE: affects show_store/1
94 %% * var_assoc multi-level store: variable - ground
95 %% * Do not maintain/check unnecessary propagation history
96 %% for reasons of anti-monotony
97 %% * Strengthen storage analysis for propagation rules
98 %% reason about bodies of rules only containing constraints
99 %% -> fixpoint with observation analysis
100 %% * instantiation declarations
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
103 %%
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * fd -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
112 %% ...
113 %% if( (
114 %% generator_n(Y),
115 %% test(X,Y)
116 %% ),
117 %% true,
118 %% ('_$cutto'(CP_1), fail)
119 %% ),
120 %% ...
121 %%
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
129 %% }}}
130 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :- module(chr_translate,
132 [ chr_translate/2 % +Decls, -TranslatedDecls
133 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
134 ]).
135 %% SWI begin {{{
136 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
137 :- use_module(library(ordsets)).
138 :- use_module(library(aggregate)).
139 :- use_module(library(apply_macros)).
140 :- use_module(library(occurs)).
141 :- use_module(library(assoc)).
142 %% SWI end }}}
144 % imports and operators {{{
145 :- use_module(hprolog).
146 :- use_module(pairlist).
147 :- use_module(a_star).
148 :- use_module(listmap).
149 :- use_module(clean_code).
150 :- use_module(builtins).
151 :- use_module(find).
152 :- use_module(binomialheap).
153 :- use_module(guard_entailment).
154 :- use_module(chr_compiler_options).
155 :- use_module(chr_compiler_utility).
156 :- use_module(chr_compiler_errors).
157 :- include(chr_op).
158 :- op(1150, fx, chr_type).
159 :- op(1150, fx, chr_declaration).
160 :- op(1130, xfx, --->).
161 :- op(980, fx, (+)).
162 :- op(980, fx, (-)).
163 :- op(980, fx, (?)).
164 :- op(1150, fx, constraints).
165 :- op(1150, fx, chr_constraint).
166 % }}}
168 :- chr_option(debug,off).
169 :- chr_option(optimize,full).
170 :- chr_option(check_guard_bindings,off).
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 % Type Declarations {{{
174 :- chr_type list(T) ---> [] ; [T|list(T)].
176 :- chr_type list == list(any).
178 :- chr_type mode ---> (+) ; (-) ; (?).
180 :- chr_type maybe(T) ---> yes(T) ; no.
182 :- chr_type constraint ---> any / any.
184 :- chr_type module_name == any.
186 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
187 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
188 :- chr_type idspair ---> ids(list(id),list(id)).
190 :- chr_type pragma_type ---> passive(id)
191 ; mpassive(list(id))
192 ; already_in_heads
193 ; already_in_heads(id)
194 ; no_history
195 ; history(history_name,list(id)).
196 :- chr_type history_name== any.
198 :- chr_type rule_name == any.
199 :- chr_type rule_nb == natural.
200 :- chr_type id == natural.
201 :- chr_type occurrence == int.
203 :- chr_type goal == any.
205 :- chr_type store_type ---> default
206 ; multi_store(list(store_type))
207 ; multi_hash(list(list(int)))
208 ; multi_inthash(list(list(int)))
209 ; global_singleton
210 ; global_ground
211 % EXPERIMENTAL STORES
212 ; atomic_constants(list(int),list(any),coverage)
213 ; ground_constants(list(int),list(any),coverage)
214 ; var_assoc_store(int,list(int))
215 ; identifier_store(int)
216 ; type_indexed_identifier_store(int,any).
217 :- chr_type coverage ---> complete ; incomplete.
218 % }}}
219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
221 %------------------------------------------------------------------------------%
222 :- chr_constraint chr_source_file/1.
223 :- chr_option(mode,chr_source_file(+)).
224 :- chr_option(type_declaration,chr_source_file(module_name)).
225 %------------------------------------------------------------------------------%
226 chr_source_file(_) \ chr_source_file(_) <=> true.
228 %------------------------------------------------------------------------------%
229 :- chr_constraint get_chr_source_file/1.
230 :- chr_option(mode,get_chr_source_file(-)).
231 :- chr_option(type_declaration,get_chr_source_file(module_name)).
232 %------------------------------------------------------------------------------%
233 chr_source_file(Mod) \ get_chr_source_file(Query)
234 <=> Query = Mod .
235 get_chr_source_file(Query)
236 <=> Query = user.
239 %------------------------------------------------------------------------------%
240 :- chr_constraint target_module/1.
241 :- chr_option(mode,target_module(+)).
242 :- chr_option(type_declaration,target_module(module_name)).
243 %------------------------------------------------------------------------------%
244 target_module(_) \ target_module(_) <=> true.
246 %------------------------------------------------------------------------------%
247 :- chr_constraint get_target_module/1.
248 :- chr_option(mode,get_target_module(-)).
249 :- chr_option(type_declaration,get_target_module(module_name)).
250 %------------------------------------------------------------------------------%
251 target_module(Mod) \ get_target_module(Query)
252 <=> Query = Mod .
253 get_target_module(Query)
254 <=> Query = user.
256 %------------------------------------------------------------------------------%
257 :- chr_constraint line_number/2.
258 :- chr_option(mode,line_number(+,+)).
259 :- chr_option(type_declaration,line_number(rule_nb,int)).
260 %------------------------------------------------------------------------------%
261 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
263 %------------------------------------------------------------------------------%
264 :- chr_constraint get_line_number/2.
265 :- chr_option(mode,get_line_number(+,-)).
266 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
267 %------------------------------------------------------------------------------%
268 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
269 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
271 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
272 :- chr_option(mode,indexed_argument(+,+)).
273 :- chr_option(type_declaration,indexed_argument(constraint,int)).
275 :- chr_constraint is_indexed_argument/2.
276 :- chr_option(mode,is_indexed_argument(+,+)).
277 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
279 :- chr_constraint constraint_mode/2.
280 :- chr_option(mode,constraint_mode(+,+)).
281 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
283 :- chr_constraint get_constraint_mode/2.
284 :- chr_option(mode,get_constraint_mode(+,-)).
285 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
287 :- chr_constraint may_trigger/1.
288 :- chr_option(mode,may_trigger(+)).
289 :- chr_option(type_declaration,may_trigger(constraint)).
291 :- chr_constraint only_ground_indexed_arguments/1.
292 :- chr_option(mode,only_ground_indexed_arguments(+)).
293 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
295 :- chr_constraint none_suspended_on_variables/0.
297 :- chr_constraint are_none_suspended_on_variables/0.
299 :- chr_constraint store_type/2.
300 :- chr_option(mode,store_type(+,+)).
301 :- chr_option(type_declaration,store_type(constraint,store_type)).
303 :- chr_constraint get_store_type/2.
304 :- chr_option(mode,get_store_type(+,?)).
305 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
307 :- chr_constraint update_store_type/2.
308 :- chr_option(mode,update_store_type(+,+)).
309 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
311 :- chr_constraint actual_store_types/2.
312 :- chr_option(mode,actual_store_types(+,+)).
313 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
315 :- chr_constraint assumed_store_type/2.
316 :- chr_option(mode,assumed_store_type(+,+)).
317 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
319 :- chr_constraint validate_store_type_assumption/1.
320 :- chr_option(mode,validate_store_type_assumption(+)).
321 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
323 :- chr_constraint rule_count/1.
324 :- chr_option(mode,rule_count(+)).
325 :- chr_option(type_declaration,rule_count(natural)).
327 :- chr_constraint inc_rule_count/1.
328 :- chr_option(mode,inc_rule_count(-)).
329 :- chr_option(type_declaration,inc_rule_count(natural)).
331 rule_count(_) \ rule_count(_)
332 <=> true.
333 rule_count(C), inc_rule_count(NC)
334 <=> NC is C + 1, rule_count(NC).
335 inc_rule_count(NC)
336 <=> NC = 1, rule_count(NC).
338 :- chr_constraint passive/2.
339 :- chr_option(mode,passive(+,+)).
341 :- chr_constraint is_passive/2.
342 :- chr_option(mode,is_passive(+,+)).
344 :- chr_constraint any_passive_head/1.
345 :- chr_option(mode,any_passive_head(+)).
347 :- chr_constraint new_occurrence/4.
348 :- chr_option(mode,new_occurrence(+,+,+,+)).
350 :- chr_constraint occurrence/5.
351 :- chr_option(mode,occurrence(+,+,+,+,+)).
352 :- chr_type occurrence_type ---> simplification ; propagation.
353 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
355 :- chr_constraint get_occurrence/4.
356 :- chr_option(mode,get_occurrence(+,+,-,-)).
358 :- chr_constraint get_occurrence_from_id/4.
359 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
361 :- chr_constraint max_occurrence/2.
362 :- chr_option(mode,max_occurrence(+,+)).
364 :- chr_constraint get_max_occurrence/2.
365 :- chr_option(mode,get_max_occurrence(+,-)).
367 :- chr_constraint allocation_occurrence/2.
368 :- chr_option(mode,allocation_occurrence(+,+)).
370 :- chr_constraint get_allocation_occurrence/2.
371 :- chr_option(mode,get_allocation_occurrence(+,-)).
373 :- chr_constraint rule/2.
374 :- chr_option(mode,rule(+,+)).
375 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
377 :- chr_constraint get_rule/2.
378 :- chr_option(mode,get_rule(+,-)).
379 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
381 :- chr_constraint least_occurrence/2.
382 :- chr_option(mode,least_occurrence(+,+)).
383 :- chr_option(type_declaration,least_occurrence(any,list)).
385 :- chr_constraint is_least_occurrence/1.
386 :- chr_option(mode,is_least_occurrence(+)).
389 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
390 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
391 is_indexed_argument(_,_) <=> fail.
393 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
395 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
396 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
397 Q = Mode.
398 get_constraint_mode(FA,Q) <=>
399 FA = _ / N,
400 replicate(N,(?),Q).
402 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
404 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
405 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
406 nth1(I,Mode,M),
407 M \== (+) |
408 is_stored(FA).
409 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
411 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
412 <=>
413 nth1(I,Mode,M),
414 M \== (+)
415 |
416 fail.
417 only_ground_indexed_arguments(_) <=>
418 true.
420 none_suspended_on_variables \ none_suspended_on_variables <=> true.
421 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
422 are_none_suspended_on_variables <=> fail.
423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
424 % STORE TYPES
425 %
426 % The functionality for inspecting and deciding on the different types of constraint
427 % store / indexes for constraints.
429 store_type(FA,StoreType)
430 ==> chr_pp_flag(verbose,on)
431 |
432 format('The indexes for ~w are:\n',[FA]),
433 format_storetype(StoreType).
434 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
436 format_storetype(multi_store(StoreTypes)) :- !,
437 maplist(format_storetype,StoreTypes).
438 format_storetype(atomic_constants(Index,Constants,_)) :-
439 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
440 format_storetype(ground_constants(Index,Constants,_)) :-
441 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
442 format_storetype(StoreType) :-
443 format('\t* ~w\n',[StoreType]).
446 % 1. Inspection
447 % ~~~~~~~~~~~~~
448 %
449 %
451 get_store_type_normal @
452 store_type(FA,Store) \ get_store_type(FA,Query)
453 <=> Query = Store.
455 get_store_type_assumed @
456 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
457 <=> Query = Store.
459 get_store_type_default @
460 get_store_type(_,Query)
461 <=> Query = default.
463 % 2. Store type registration
464 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
466 actual_store_types(C,STs) \ update_store_type(C,ST)
467 <=> memberchk(ST,STs) | true.
468 update_store_type(C,ST), actual_store_types(C,STs)
469 <=>
470 actual_store_types(C,[ST|STs]).
471 update_store_type(C,ST)
472 <=>
473 actual_store_types(C,[ST]).
475 % 3. Final decision on store types
476 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
479 <=>
480 true % chr_pp_flag(experiment,on)
481 |
482 delete(STs,multi_hash([Index]),STs0),
483 Index = [IndexPos],
484 ( get_constraint_arg_type(C,IndexPos,Type),
485 enumerated_atomic_type(Type,Atoms) ->
486 /* use the type constants rather than the collected keys */
487 Constants = Atoms,
488 Completeness = complete
489 ;
490 Constants = Keys,
491 Completeness = incomplete
492 ),
493 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
494 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
495 <=>
496 true % chr_pp_flag(experiment,on)
497 |
498 ( Index = [IndexPos],
499 get_constraint_arg_type(C,IndexPos,Type),
500 ( fail, is_chr_constants_type(Type,Key,_) -> get_chr_constants(Key,Constants)
501 ; 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 ; fail, is_chr_constants_type(Type,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,Clauses) :-
3513 enumerate_stores_code(Constraints,Enumerate),
3514 append(Enumerate,L,Clauses),
3515 generate_attach_code(Constraints,L,T),
3516 module_initializers(Initializers),
3517 prolog_global_variables_code(PrologGlobalVariables),
3518 % Do not rename or the 'chr_initialization' predicate
3519 % without warning SSS
3520 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3522 generate_attach_code([],L,L).
3523 generate_attach_code([C|Cs],L,T) :-
3524 get_store_type(C,StoreType),
3525 generate_attach_code(StoreType,C,L,L1),
3526 generate_attach_code(Cs,L1,T).
3528 generate_attach_code(default,C,L,T) :-
3529 global_list_store_initialisation(C,L,T).
3530 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3531 multi_inthash_store_initialisations(Indexes,C,L,L1),
3532 multi_inthash_via_lookups(Indexes,C,L1,T).
3533 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3534 multi_hash_store_initialisations(Indexes,C,L,L1),
3535 multi_hash_lookups(Indexes,C,L1,T).
3536 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3537 constants_initializers(C,Index,Constants),
3538 atomic_constants_code(C,Index,Constants,L,T).
3539 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3540 constants_initializers(C,Index,Constants),
3541 ground_constants_code(C,Index,Constants,L,T).
3542 generate_attach_code(global_ground,C,L,T) :-
3543 global_ground_store_initialisation(C,L,T).
3544 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3545 use_auxiliary_module(chr_assoc_store).
3546 generate_attach_code(global_singleton,C,L,T) :-
3547 global_singleton_store_initialisation(C,L,T).
3548 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3549 multi_store_generate_attach_code(StoreTypes,C,L,T).
3550 generate_attach_code(identifier_store(Index),C,L,T) :-
3551 get_identifier_index(C,Index,IIndex),
3552 ( IIndex == 2 ->
3553 get_identifier_size(ISize),
3554 functor(Struct,struct,ISize),
3555 Struct =.. [_,Label|Stores],
3556 set_elems(Stores,[]),
3557 Clause1 = new_identifier(Label,Struct),
3558 functor(Struct2,struct,ISize),
3559 arg(1,Struct2,Label2),
3560 Clause2 =
3561 ( user:portray(Struct2) :-
3562 write('<id:'),
3563 print(Label2),
3564 write('>')
3565 ),
3566 functor(Struct3,struct,ISize),
3567 arg(1,Struct3,Label3),
3568 Clause3 = identifier_label(Struct3,Label3),
3569 L = [Clause1,Clause2,Clause3|T]
3570 ;
3571 L = T
3572 ).
3573 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3574 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3575 ( IIndex == 2 ->
3576 identifier_store_initialization(IndexType,L,L1),
3577 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3578 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3579 get_type_indexed_identifier_size(IndexType,ISize),
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3581 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3582 type_indexed_identifier_structure(IndexType,Struct),
3583 Struct =.. [_,Label|Stores],
3584 set_elems(Stores,[]),
3585 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3586 Clause1 =.. [Name1,Label,Struct],
3587 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3588 Goal1 =.. [Name1,Label1b,S1b],
3589 type_indexed_identifier_structure(IndexType,Struct1b),
3590 Struct1b =.. [_,Label1b|Stores1b],
3591 set_elems(Stores1b,[]),
3592 Expansion1 = (S1b = Struct1b),
3593 Clause1b = user:goal_expansion(Goal1,Expansion1),
3594 % writeln(Clause1-Clause1b),
3595 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3596 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3597 type_indexed_identifier_structure(IndexType,Struct2),
3598 arg(1,Struct2,Label2),
3599 Clause2 =
3600 ( user:portray(Struct2) :-
3601 write('<id:'),
3602 print(Label2),
3603 write('>')
3604 ),
3605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3606 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3607 type_indexed_identifier_structure(IndexType,Struct3),
3608 arg(1,Struct3,Label3),
3609 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3610 Clause3 =.. [Name3,Struct3,Label3],
3611 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3612 Goal3b =.. [Name3,S3b,L3b],
3613 type_indexed_identifier_structure(IndexType,Struct3b),
3614 arg(1,Struct3b,L3b),
3615 Expansion3b = (S3 = Struct3b),
3616 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3617 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3618 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3619 identifier_store_name(IndexType,GlobalVariable),
3620 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3621 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3622 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3623 Clause4 =
3624 ( LookupAtom :-
3625 nb_getval(GlobalVariable,HT),
3626 ( lookup_ht(HT,X,[IX]) ->
3627 true
3628 ;
3629 NewIdentifierGoal,
3630 insert_ht(HT,X,IX)
3631 )
3632 ),
3633 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3634 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3635 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3636 ;
3637 L = T
3638 ).
3640 constants_initializers(C,Index,Constants) :-
3641 maplist(constant_initializer(C,Index),Constants).
3643 constant_initializer(C,Index,Constant) :-
3644 constants_store_name(C,Index,Constant,StoreName),
3645 module_initializer(nb_setval(StoreName,[])).
3647 lookup_identifier_atom(Key,X,IX,Atom) :-
3648 atom_concat('lookup_identifier_',Key,LookupFunctor),
3649 Atom =.. [LookupFunctor,X,IX].
3651 identifier_label_atom(IndexType,IX,X,Atom) :-
3652 type_indexed_identifier_name(IndexType,identifier_label,Name),
3653 Atom =.. [Name,IX,X].
3655 multi_store_generate_attach_code([],_,L,L).
3656 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3657 generate_attach_code(ST,C,L,L1),
3658 multi_store_generate_attach_code(STs,C,L1,T).
3660 multi_inthash_store_initialisations([],_,L,L).
3661 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3662 use_auxiliary_module(chr_integertable_store),
3663 multi_hash_store_name(FA,Index,StoreName),
3664 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3665 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3666 L1 = L,
3667 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3668 multi_hash_store_initialisations([],_,L,L).
3669 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3670 use_auxiliary_module(chr_hashtable_store),
3671 multi_hash_store_name(FA,Index,StoreName),
3672 prolog_global_variable(StoreName),
3673 make_init_store_goal(StoreName,HT,InitStoreGoal),
3674 module_initializer((new_ht(HT),InitStoreGoal)),
3675 L1 = L,
3676 multi_hash_store_initialisations(Indexes,FA,L1,T).
3678 global_list_store_initialisation(C,L,T) :-
3679 ( is_stored(C) ->
3680 global_list_store_name(C,StoreName),
3681 prolog_global_variable(StoreName),
3682 make_init_store_goal(StoreName,[],InitStoreGoal),
3683 module_initializer(InitStoreGoal)
3684 ;
3685 true
3686 ),
3687 L = T.
3688 global_ground_store_initialisation(C,L,T) :-
3689 global_ground_store_name(C,StoreName),
3690 prolog_global_variable(StoreName),
3691 make_init_store_goal(StoreName,[],InitStoreGoal),
3692 module_initializer(InitStoreGoal),
3693 L = T.
3694 global_singleton_store_initialisation(C,L,T) :-
3695 global_singleton_store_name(C,StoreName),
3696 prolog_global_variable(StoreName),
3697 make_init_store_goal(StoreName,[],InitStoreGoal),
3698 module_initializer(InitStoreGoal),
3699 L = T.
3700 identifier_store_initialization(IndexType,L,T) :-
3701 use_auxiliary_module(chr_hashtable_store),
3702 identifier_store_name(IndexType,StoreName),
3703 prolog_global_variable(StoreName),
3704 make_init_store_goal(StoreName,HT,InitStoreGoal),
3705 module_initializer((new_ht(HT),InitStoreGoal)),
3706 L = T.
3709 multi_inthash_via_lookups([],_,L,L).
3710 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3711 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3712 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3713 L = [(Head :- Body)|L1],
3714 multi_inthash_via_lookups(Indexes,C,L1,T).
3715 multi_hash_lookups([],_,L,L).
3716 multi_hash_lookups([Index|Indexes],C,L,T) :-
3717 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3718 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3719 L = [(Head :- Body)|L1],
3720 multi_hash_lookups(Indexes,C,L1,T).
3722 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3723 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3724 Head =.. [Name,Key,SuspsList].
3726 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3727 %
3728 % Returns goal that performs hash table lookup.
3729 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3730 % INLINED:
3731 get_store_type(ConstraintSymbol,multi_store(Stores)),
3732 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3733 ( ground(Key) ->
3734 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3735 Goal = nb_getval(StoreName,SuspsList)
3736 ;
3737 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3738 Lookup =.. [IndexName,Key,StoreName],
3739 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3740 )
3741 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3742 ( ground(Key) ->
3743 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3744 Goal = nb_getval(StoreName,SuspsList)
3745 ;
3746 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3747 Lookup =.. [IndexName,Key,StoreName],
3748 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3749 )
3750 ; memberchk(multi_hash([Index]),Stores) ->
3751 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3752 make_get_store_goal(StoreName,HT,GetStoreGoal),
3753 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3754 Goal =
3755 (
3756 GetStoreGoal, % nb_getval(StoreName,HT),
3757 HashCall, % hash_term(Key,Hash),
3758 lookup_ht1(HT,Hash,Key,SuspsList)
3759 )
3760 ;
3761 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3762 Goal =
3763 (
3764 GetStoreGoal, % nb_getval(StoreName,HT),
3765 Lookup
3766 )
3767 )
3768 ; HashType == inthash ->
3769 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3770 make_get_store_goal(StoreName,HT,GetStoreGoal),
3771 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3772 Goal =
3773 (
3774 GetStoreGoal, % nb_getval(StoreName,HT),
3775 Lookup
3776 )
3777 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3778 % find alternative index
3779 % -> SubIndex + RestIndex
3780 % -> SubKey + RestKeys
3781 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3782 % instantiate rest goal?
3783 % Goal = (SubGoal,RestGoal)
3784 ).
3787 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3788 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3790 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3791 ( ground(Key) ->
3792 % This is based on a property of SWI-Prolog's
3793 % hash_term/2 predicate:
3794 % the hash value is stable over repeated invocations
3795 % of SWI-Prolog
3796 hash_term(Key,Hash),
3797 Call = true
3798 ; Index = [IndexPos],
3799 get_constraint_type(Constraint,ArgTypes),
3800 nth1(IndexPos,ArgTypes,Type),
3801 unalias_type(Type,NormalType),
3802 memberchk_eq(NormalType,[int,natural]) ->
3803 ( NormalType == int ->
3804 Call = (Hash is abs(Key))
3805 ;
3806 Hash = Key,
3807 Call = true
3808 )
3809 ;
3810 nonvar(Key),
3811 specialize_hash_term(Key,NewKey),
3812 NewKey \== Key,
3813 Call = hash_term(NewKey,Hash)
3814 ).
3816 specialize_hash_term(Term,NewTerm) :-
3817 ( ground(Term) ->
3818 hash_term(Term,NewTerm)
3819 ; var(Term) ->
3820 NewTerm = Term
3821 ;
3822 Term =.. [F|Args],
3823 maplist(specialize_hash_term,Args,NewArgs),
3824 NewTerm =.. [F|NewArgs]
3825 ).
3827 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3828 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3829 ( /* chr_pp_flag(experiment,off) ->
3830 true
3831 ; */ atomic(Key) ->
3832 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3833 ; ground(Key) ->
3834 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3835 ;
3836 ( Index = [Pos],
3837 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3838 is_chr_constants_type(Type,_,_)
3839 ->
3840 true
3841 ;
3842 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3843 )
3844 ),
3845 delay_phase_end(validate_store_type_assumptions,
3846 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3848 :- chr_constraint actual_atomic_multi_hash_keys/3.
3849 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3851 :- chr_constraint actual_ground_multi_hash_keys/3.
3852 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3854 :- chr_constraint actual_non_ground_multi_hash_key/2.
3855 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3857 /*
3858 actual_atomic_multi_hash_keys(C,Index,Keys)
3859 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3861 actual_ground_multi_hash_keys(C,Index,Keys)
3862 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3864 actual_non_ground_multi_hash_key(C,Index)
3865 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3866 */
3867 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3868 <=> append(Keys1,Keys2,Keys0),
3869 sort(Keys0,Keys),
3870 actual_atomic_multi_hash_keys(C,Index,Keys).
3872 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3873 <=> append(Keys1,Keys2,Keys0),
3874 sort(Keys0,Keys),
3875 actual_ground_multi_hash_keys(C,Index,Keys).
3877 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3878 <=> append(Keys1,Keys2,Keys0),
3879 sort(Keys0,Keys),
3880 actual_ground_multi_hash_keys(C,Index,Keys).
3882 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3883 <=> true.
3885 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3886 <=> true.
3888 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3889 <=> true.
3891 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3892 %
3893 % Returns predicate name of hash table lookup predicate.
3894 multi_hash_lookup_name(F/A,Index,Name) :-
3895 atom_concat_list(Index,IndexName),
3896 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3898 multi_hash_store_name(F/A,Index,Name) :-
3899 get_target_module(Mod),
3900 atom_concat_list(Index,IndexName),
3901 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3903 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3904 ( Index = [I] ->
3905 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3906 ;
3907 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
3908 Key =.. [k|Keys],
3909 list2conj(Bodies,KeyBody)
3910 ).
3912 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3913 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3915 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3916 ( Index = [I] ->
3917 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3918 ;
3919 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
3920 Key =.. [k|Keys],
3921 list2conj(Bodies,KeyBody)
3922 ).
3924 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3925 arg(Index,Head,OriginalArg),
3926 ( term_variables(OriginalArg,OriginalVars),
3927 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
3928 translate(OriginalVars,VarDict,Vars) ->
3929 Goal = true
3930 ;
3931 functor(Head,F,A),
3932 C = F/A,
3933 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3934 ).
3936 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3937 ( Index = [I] ->
3938 UsedVars = [I-Key]
3939 ;
3940 pairup(Index,Keys,UsedVars),
3941 Key =.. [k|Keys]
3942 ).
3944 args(Index,Head,KeyArgs) :-
3945 maplist(arg1(Head),Index,KeyArgs).
3947 split_args(Indexes,Args,IArgs,NIArgs) :-
3948 split_args(Indexes,Args,1,IArgs,NIArgs).
3950 split_args([],Args,_,[],Args).
3951 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
3952 NJ is J + 1,
3953 ( I == J ->
3954 IArgs = [Arg|Rest],
3955 split_args(Is,Args,NJ,Rest,NIArgs)
3956 ;
3957 NIArgs = [Arg|Rest],
3958 split_args([I|Is],Args,NJ,IArgs,Rest)
3959 ).
3962 %-------------------------------------------------------------------------------
3963 atomic_constants_code(C,Index,Constants,L,T) :-
3964 constants_store_index_name(C,Index,IndexName),
3965 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3966 append(Clauses,T,L).
3968 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3969 constants_store_name(C,Index,Constant,StoreName),
3970 Clause =.. [IndexName,Constant,StoreName].
3972 %-------------------------------------------------------------------------------
3973 ground_constants_code(C,Index,Terms,L,T) :-
3974 constants_store_index_name(C,Index,IndexName),
3975 maplist(constants_store_name(C,Index),Terms,StoreNames),
3976 length(Terms,N),
3977 replicate(N,[],More),
3978 trie_index([Terms|More],StoreNames,IndexName,L,T).
3980 constants_store_name(F/A,Index,Term,Name) :-
3981 get_target_module(Mod),
3982 term_to_atom(Term,Constant),
3983 term_to_atom(Index,IndexAtom),
3984 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3986 constants_store_index_name(F/A,Index,Name) :-
3987 get_target_module(Mod),
3988 term_to_atom(Index,IndexAtom),
3989 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3991 % trie index code {{{
3992 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3993 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3995 trie_step([],_,_,[],[],L,L) :- !.
3996 % length MorePatterns == length Patterns == length Results
3997 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3998 MorePatterns = [List|_],
3999 length(List,N),
4000 aggregate_all(set(F/A),
4001 ( member(Pattern,Patterns),
4002 functor(Pattern,F,A)
4003 ),
4004 FAs),
4005 N1 is N + 1,
4006 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4008 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4009 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4010 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4011 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4013 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4014 Clause = (Head :- Body),
4015 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4016 N1 is N + 1,
4017 functor(Head,Symbol,N1),
4018 arg(1,Head,IndexPattern),
4019 Head =.. [_,_|RestArgs],
4020 once(append(Vs,[Result],RestArgs)),
4021 /* IndexPattern = F() */
4022 functor(IndexPattern,F,A),
4023 IndexPattern =.. [_|Args],
4024 append(Args,RestArgs,RecArgs),
4025 ( RecArgs == [Result] ->
4026 /* nothing more to match on */
4027 List = Tail,
4028 Body = true,
4029 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4030 MoreResults = [Result]
4031 ; /* more things to match on */
4032 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4033 ( MoreCases = [OneMoreCase] ->
4034 /* only one more thing to match on */
4035 List = Tail,
4036 Body = true,
4037 append([Cases,OneMoreCase,MoreResults],RecArgs)
4038 ;
4039 /* more than one thing to match on */
4040 /* [ x1,..., xn]
4041 [xs1,...,xsn]
4042 */
4043 pairup(Cases,MoreCases,CasePairs),
4044 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4045 append(Args,Vs,[First|Rest]),
4046 First-Rest = CommonPatternPair,
4047 % Body = RSymbol(DiffVars,Result)
4048 gensym(Prefix,RSymbol),
4049 append(DiffVars,[Result],RecCallVars),
4050 Body =.. [RSymbol|RecCallVars],
4051 maplist(head_tail,Differences,CHs,CTs),
4052 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4053 )
4054 ).
4056 head_tail([H|T],H,T).
4058 rec_cases([],[],[],_,[],[],[]).
4059 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4060 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4061 Cases = [Case|NCases],
4062 MoreCases = [MoreCase|NMoreCases],
4063 MoreResults = [Result|NMoreResults],
4064 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4065 ;
4066 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4067 ).
4068 % }}}
4070 %% common_pattern(+terms,-term,-vars,-differences) is det.
4071 common_pattern(Ts,T,Vars,Differences) :-
4072 fold1(gct,Ts,T),
4073 term_variables(T,Vars),
4074 findall(Vars,member(T,Ts),Differences).
4076 gct(T1,T2,T) :-
4077 gct_(T1,T2,T,[],_).
4079 gct_(T1,T2,T,Dict0,Dict) :-
4080 ( nonvar(T1),
4081 nonvar(T2),
4082 functor(T1,F1,A1),
4083 functor(T2,F2,A2),
4084 F1 == F2,
4085 A1 == A2 ->
4086 functor(T,F1,A1),
4087 T1 =.. [_|Args1],
4088 T2 =.. [_|Args2],
4089 T =.. [_|Args],
4090 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4091 ;
4092 /* T is a variable */
4093 ( lookup_eq(Dict0,T1+T2,T) ->
4094 /* we already have a variable for this difference */
4095 Dict = Dict0
4096 ;
4097 /* T is a fresh variable */
4098 Dict = [(T1+T2)-T|Dict0]
4099 )
4100 ).
4103 fold1(P,[Head|Tail],Result) :-
4104 fold(Tail,P,Head,Result).
4106 fold([],_,Acc,Acc).
4107 fold([X|Xs],P,Acc,Res) :-
4108 call(P,X,Acc,NAcc),
4109 fold(Xs,P,NAcc,Res).
4111 maplist_dcg(P,L1,L2,L) -->
4112 maplist_dcg_(L1,L2,L,P).
4114 maplist_dcg_([],[],[],_) --> [].
4115 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4116 call(P,X,Y,Z),
4117 maplist_dcg_(Xs,Ys,Zs,P).
4119 %-------------------------------------------------------------------------------
4120 global_list_store_name(F/A,Name) :-
4121 get_target_module(Mod),
4122 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4123 global_ground_store_name(F/A,Name) :-
4124 get_target_module(Mod),
4125 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4126 global_singleton_store_name(F/A,Name) :-
4127 get_target_module(Mod),
4128 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4130 identifier_store_name(TypeName,Name) :-
4131 get_target_module(Mod),
4132 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4134 :- chr_constraint prolog_global_variable/1.
4135 :- chr_option(mode,prolog_global_variable(+)).
4137 :- chr_constraint prolog_global_variables/1.
4138 :- chr_option(mode,prolog_global_variables(-)).
4140 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4142 prolog_global_variables(List), prolog_global_variable(Name) <=>
4143 List = [Name|Tail],
4144 prolog_global_variables(Tail).
4145 prolog_global_variables(List) <=> List = [].
4147 %% SWI begin
4148 prolog_global_variables_code(Code) :-
4149 prolog_global_variables(Names),
4150 ( Names == [] ->
4151 Code = []
4152 ;
4153 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4154 Code = [(:- dynamic user:exception/3),
4155 (:- multifile user:exception/3),
4156 (user:exception(undefined_global_variable,Name,retry) :-
4157 (
4158 '$chr_prolog_global_variable'(Name),
4159 '$chr_initialization'
4160 )
4161 )
4162 |
4163 NameDeclarations
4164 ]
4165 ).
4166 %% SWI end
4167 %% SICStus begin
4168 % prolog_global_variables_code([]).
4169 %% SICStus end
4170 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4171 %sbag_member_call(S,L,sysh:mem(S,L)).
4172 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4173 %sbag_member_call(S,L,member(S,L)).
4174 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4175 %update_mutable_call(A,B,setarg(1, B, A)).
4176 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4177 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4179 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4180 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4181 % create_get_mutable(Value,Field,Get1).
4182 %
4183 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4184 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4185 % update_mutable_call(NewValue,Field,Set).
4186 %
4187 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4188 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4189 % create_get_mutable_ref(Value,Field,Get1),
4190 % update_mutable_call(NewValue,Field,Set).
4191 %
4192 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4193 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4194 % create_mutable_call(Value,Field,Create).
4195 %
4196 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4197 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4198 % create_get_mutable(Value,Field,Get).
4199 %
4200 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4201 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4202 % create_get_mutable_ref(Value,Field,Get),
4203 % update_mutable_call(NewValue,Field,Set).
4205 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4206 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4208 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4209 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4211 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4212 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4213 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4215 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4216 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4218 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4219 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4221 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4222 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4223 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4227 enumerate_stores_code(Constraints,[Clause|List]) :-
4228 Head = '$enumerate_constraints'(Constraint),
4229 Clause = ( Head :- Body),
4230 enumerate_store_bodies(Constraints,Constraint,List),
4231 ( List = [] ->
4232 Body = fail
4233 ;
4234 Body = ( nonvar(Constraint) ->
4235 functor(Constraint,Functor,_),
4236 '$enumerate_constraints'(Functor,Constraint)
4237 ;
4238 '$enumerate_constraints'(_,Constraint)
4239 )
4240 ).
4242 enumerate_store_bodies([],_,[]).
4243 enumerate_store_bodies([C|Cs],Constraint,L) :-
4244 ( is_stored(C) ->
4245 get_store_type(C,StoreType),
4246 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4247 true
4248 ;
4249 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4250 ),
4251 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4252 C = F/_,
4253 Constraint0 =.. [F|Arguments],
4254 Head = '$enumerate_constraints'(F,Constraint),
4255 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4256 L = [(Head :- Body)|T]
4257 ;
4258 L = T
4259 ),
4260 enumerate_store_bodies(Cs,Constraint,T).
4262 enumerate_store_body(default,C,Susp,Body) :-
4263 global_list_store_name(C,StoreName),
4264 sbag_member_call(Susp,List,Sbag),
4265 make_get_store_goal(StoreName,List,GetStoreGoal),
4266 Body =
4267 (
4268 GetStoreGoal, % nb_getval(StoreName,List),
4269 Sbag
4270 ).
4271 % get_constraint_index(C,Index),
4272 % get_target_module(Mod),
4273 % get_max_constraint_index(MaxIndex),
4274 % Body1 =
4275 % (
4276 % 'chr default_store'(GlobalStore),
4277 % get_attr(GlobalStore,Mod,Attr)
4278 % ),
4279 % ( MaxIndex > 1 ->
4280 % NIndex is Index + 1,
4281 % sbag_member_call(Susp,List,Sbag),
4282 % Body2 =
4283 % (
4284 % arg(NIndex,Attr,List),
4285 % Sbag
4286 % )
4287 % ;
4288 % sbag_member_call(Susp,Attr,Sbag),
4289 % Body2 = Sbag
4290 % ),
4291 % Body = (Body1,Body2).
4292 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4293 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4294 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4295 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4296 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4297 Completeness == complete, % fail if incomplete
4298 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4299 list2disj(Disjuncts, Disjunction),
4300 Body = ( Disjunction, member(Susp,Susps) ).
4301 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4302 constants_store_name(C,Index,Constant,StoreName).
4304 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4305 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4306 enumerate_store_body(global_ground,C,Susp,Body) :-
4307 global_ground_store_name(C,StoreName),
4308 sbag_member_call(Susp,List,Sbag),
4309 make_get_store_goal(StoreName,List,GetStoreGoal),
4310 Body =
4311 (
4312 GetStoreGoal, % nb_getval(StoreName,List),
4313 Sbag
4314 ).
4315 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4316 Body = fail.
4317 enumerate_store_body(global_singleton,C,Susp,Body) :-
4318 global_singleton_store_name(C,StoreName),
4319 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4320 Body =
4321 (
4322 GetStoreGoal, % nb_getval(StoreName,Susp),
4323 Susp \== []
4324 ).
4325 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4326 ( memberchk(global_ground,STs) ->
4327 enumerate_store_body(global_ground,C,Susp,Body)
4328 ;
4329 once((
4330 member(ST,STs),
4331 enumerate_store_body(ST,C,Susp,Body)
4332 ))
4333 ).
4334 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4335 Body = fail.
4336 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4337 Body = fail.
4339 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4340 multi_hash_store_name(C,I,StoreName),
4341 B =
4342 (
4343 nb_getval(StoreName,HT),
4344 value_iht(HT,Susp)
4345 ).
4346 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4347 multi_hash_store_name(C,I,StoreName),
4348 make_get_store_goal(StoreName,HT,GetStoreGoal),
4349 B =
4350 (
4351 GetStoreGoal, % nb_getval(StoreName,HT),
4352 value_ht(HT,Susp)
4353 ).
4355 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4356 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4357 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4359 :- chr_constraint
4360 background_info/1,
4361 background_info/2,
4362 get_bg_info/1,
4363 get_bg_info/2,
4364 get_bg_info_answer/1.
4366 background_info(X), background_info(Y) <=>
4367 append(X,Y,XY), background_info(XY).
4368 background_info(X) \ get_bg_info(Q) <=> Q=X.
4369 get_bg_info(Q) <=> Q = [].
4371 background_info(T,I), get_bg_info(A,Q) ==>
4372 copy_term_nat(T,T1),
4373 subsumes_chk(T1,A)
4374 |
4375 copy_term_nat(T-I,A-X),
4376 get_bg_info_answer([X]).
4377 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4378 append(X,Y,XY), get_bg_info_answer(XY).
4380 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4381 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4383 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4386 :- chr_constraint
4387 prev_guard_list/8,
4388 prev_guard_list/6,
4389 simplify_guards/1,
4390 set_all_passive/1.
4392 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4393 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4394 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4395 :- chr_option(mode,simplify_guards(+)).
4396 :- chr_option(mode,set_all_passive(+)).
4398 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4399 % GUARD SIMPLIFICATION
4400 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4401 % If the negation of the guards of earlier rules entails (part of)
4402 % the current guard, the current guard can be simplified. We can only
4403 % use earlier rules with a head that matches if the head of the current
4404 % rule does, and which make it impossible for the current rule to match
4405 % if they fire (i.e. they shouldn't be propagation rules and their
4406 % head constraints must be subsets of those of the current rule).
4407 % At this point, we know for sure that the negation of the guard
4408 % of such a rule has to be true (otherwise the earlier rule would have
4409 % fired, because of the refined operational semantics), so we can use
4410 % that information to simplify the guard by replacing all entailed
4411 % conditions by true/0. As a consequence, the never-stored analysis
4412 % (in a further phase) will detect more cases of never-stored constraints.
4413 %
4414 % e.g. c(X),d(Y) <=> X > 0 | ...
4415 % e(X) <=> X < 0 | ...
4416 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4417 % \____________/
4418 % true
4420 guard_simplification :-
4421 ( chr_pp_flag(guard_simplification,on) ->
4422 precompute_head_matchings,
4423 simplify_guards(1)
4424 ;
4425 true
4426 ).
4428 % for every rule, we create a prev_guard_list where the last argument
4429 % eventually is a list of the negations of earlier guards
4430 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4431 <=>
4432 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4433 append(Head1,Head2,Heads),
4434 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4435 tree_set_empty(Done),
4436 multiple_occ_constraints_checked(Done),
4437 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4439 append(IDs1,IDs2,IDs),
4440 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4441 empty_q(EmptyHeap),
4442 insert_list_q(HeapData,EmptyHeap,Heap),
4443 next_prev_rule(Heap,_,Heap1),
4444 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4445 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4446 NextRule is RuleNb+1,
4447 simplify_guards(NextRule).
4449 next_prev_rule(Heap,RuleNb,NHeap) :-
4450 ( find_min_q(Heap,_-Priority) ->
4451 Priority = (-RuleNb),
4452 normalize_heap(Heap,Priority,NHeap)
4453 ;
4454 RuleNb = 0,
4455 NHeap = Heap
4456 ).
4458 normalize_heap(Heap,Priority,NHeap) :-
4459 ( find_min_q(Heap,_-Priority) ->
4460 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4461 ( O > 1 ->
4462 NO is O -1,
4463 get_occurrence(C,NO,RuleNb,_),
4464 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4465 ;
4466 Heap2 = Heap1
4467 ),
4468 normalize_heap(Heap2,Priority,NHeap)
4469 ;
4470 NHeap = Heap
4471 ).
4473 % no more rule
4474 simplify_guards(_)
4475 <=>
4476 true.
4478 % The negation of the guard of a non-propagation rule is added
4479 % if its kept head constraints are a subset of the kept constraints of
4480 % the rule we're working on, and its removed head constraints (at least one)
4481 % are a subset of the removed constraints.
4483 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4484 <=>
4485 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4486 H1 \== [],
4487 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4488 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4489 |
4490 append(H1,H2,Heads),
4491 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4492 append(GuardList,DerivedInfo,GL1),
4493 normalize_conj_list(GL1,GL),
4494 append(GH_New1,GH,GH1),
4495 normalize_conj_list(GH1,GH_New),
4496 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4497 % PrevPrevRuleNb is PrevRuleNb-1,
4498 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4500 % if this isn't the case, we skip this one and try the next rule
4501 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4502 <=>
4503 ( N > 0 ->
4504 next_prev_rule(Heap,N1,NHeap),
4505 % N1 is N-1,
4506 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4507 ;
4508 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4509 ).
4511 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4512 <=>
4513 GH \== []
4514 |
4515 head_types_modes_condition(GH,H,TypeInfo),
4516 conj2list(TypeInfo,TI),
4517 term_variables(H,HeadVars),
4518 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4519 normalize_conj_list(Info,InfoL),
4520 append(H,InfoL,RelevantTerms),
4521 add_background_info([G|RelevantTerms],BGInfo),
4522 append(InfoL,BGInfo,AllInfo_),
4523 normalize_conj_list(AllInfo_,AllInfo),
4524 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4526 head_types_modes_condition([],H,true).
4527 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4528 types_modes_condition(H,GH,TI1),
4529 head_types_modes_condition(GHs,H,TI2).
4531 add_background_info(Term,Info) :-
4532 get_bg_info(GeneralInfo),
4533 add_background_info2(Term,TermInfo),
4534 append(GeneralInfo,TermInfo,Info).
4536 add_background_info2(X,[]) :- var(X), !.
4537 add_background_info2([],[]) :- !.
4538 add_background_info2([X|Xs],Info) :- !,
4539 add_background_info2(X,Info1),
4540 add_background_info2(Xs,Infos),
4541 append(Info1,Infos,Info).
4543 add_background_info2(X,Info) :-
4544 (functor(X,_,A), A>0 ->
4545 X =.. [_|XArgs],
4546 add_background_info2(XArgs,XArgInfo)
4547 ;
4548 XArgInfo = []
4549 ),
4550 get_bg_info(X,XInfo),
4551 append(XInfo,XArgInfo,Info).
4553 %%
4554 % when all earlier guards are added or skipped, we simplify the guard.
4555 % if it's different from the original one, we change the rule
4557 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4558 <=>
4559 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4560 G \== true, % let's not try to simplify this ;)
4561 append(M,GuardList,Info),
4562 (% if guard + context is a contradiction, it should be simplified to "fail"
4563 conj2list(G,GL), append(Info,GL,GuardWithContext),
4564 guard_entailment:entails_guard(GuardWithContext,fail) ->
4565 SimpleGuard = fail
4566 ;
4567 % otherwise we try to remove redundant conjuncts
4568 simplify_guard(G,B,Info,SimpleGuard,NB)
4569 ),
4570 G \== SimpleGuard % only do this if we can change the guard
4571 |
4572 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4573 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4575 %% normalize_conj_list(+List,-NormalList) is det.
4576 %
4577 % Removes =true= elements and flattens out conjunctions.
4579 normalize_conj_list(List,NormalList) :-
4580 list2conj(List,Conj),
4581 conj2list(Conj,NormalList).
4583 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4584 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4585 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4587 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4588 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4589 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4590 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4591 append(Renaming1,ExtraRenaming,Renaming2),
4592 list2conj(PrevMatchings,Match),
4593 negate_b(Match,HeadsDontMatch),
4594 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4595 list2conj(HeadsMatch,HeadsMatchBut),
4596 term_variables(Renaming2,RenVars),
4597 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4598 new_vars(MGVars,RenVars,ExtraRenaming2),
4599 append(Renaming2,ExtraRenaming2,Renaming),
4600 ( PrevGuard == true -> % true can't fail
4601 Info_ = HeadsDontMatch
4602 ;
4603 negate_b(PrevGuard,TheGuardFailed),
4604 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4605 ),
4606 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4607 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4608 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4609 list2conj(RenamedMatchings_,RenamedMatchings),
4610 apply_guard_wrt_term(H,RenamedG2,GH2),
4611 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4612 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4614 simplify_guard(G,B,Info,SG,NB) :-
4615 conj2list(G,LG),
4616 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4617 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4618 list2conj(SGL,SG).
4621 new_vars([],_,[]).
4622 new_vars([A|As],RV,ER) :-
4623 ( memberchk_eq(A,RV) ->
4624 new_vars(As,RV,ER)
4625 ;
4626 ER = [A-NewA,NewA-A|ER2],
4627 new_vars(As,RV,ER2)
4628 ).
4630 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4631 %
4632 % check if a list of constraints is a subset of another list of constraints
4633 % (multiset-subset), meanwhile computing a variable renaming to convert
4634 % one into the other.
4635 head_subset(H,Head,Renaming) :-
4636 head_subset(H,Head,Renaming,[],_).
4638 head_subset([],Remainder,Renaming,Renaming,Remainder).
4639 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4640 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4641 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4643 % check if A is in the list, remove it from Headleft
4644 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4645 ( variable_replacement(A,X,Acc,Renaming),
4646 Remainder = Xs
4647 ;
4648 Remainder = [X|RRemainder],
4649 head_member(Xs,A,Renaming,Acc,RRemainder)
4650 ).
4651 %-------------------------------------------------------------------------------%
4652 % memoing code to speed up repeated computation
4654 :- chr_constraint precompute_head_matchings/0.
4656 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4657 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4658 append(H1,H2,Heads),
4659 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4660 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4661 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4663 precompute_head_matchings <=> true.
4665 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4666 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4668 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4669 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4671 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4672 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4673 <=>
4674 Q1 = NHeads,
4675 Q2 = Matchings.
4676 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4678 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4679 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4680 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4681 %-------------------------------------------------------------------------------%
4683 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4684 extract_arguments(Heads,Arguments),
4685 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4686 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4688 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4689 extract_arguments(Heads,Arguments),
4690 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4691 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4693 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4694 extract_arguments(Heads,Arguments1),
4695 extract_arguments(MatchingFreeHeads,Arguments2),
4696 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4698 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4699 %
4700 % Returns list of arguments of given list of constraints.
4701 extract_arguments([],[]).
4702 extract_arguments([Constraint|Constraints],AllArguments) :-
4703 Constraint =.. [_|Arguments],
4704 append(Arguments,RestArguments,AllArguments),
4705 extract_arguments(Constraints,RestArguments).
4707 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4708 %
4709 % Substitutes arguments of constraints with those in the given list.
4711 substitute_arguments([],[],[]).
4712 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4713 functor(Constraint,F,N),
4714 split_at(N,Variables,Arguments,RestVariables),
4715 NConstraint =.. [F|Arguments],
4716 substitute_arguments(Constraints,RestVariables,NConstraints).
4718 make_matchings_explicit([],[],_,MC,MC,[]).
4719 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4720 ( var(Arg) ->
4721 ( memberchk_eq(Arg,VarAcc) ->
4722 list2disj(MatchingCondition,MatchingCondition_disj),
4723 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4724 NVarAcc = VarAcc
4725 ;
4726 Matchings = RestMatchings,
4727 NewVar = Arg,
4728 NVarAcc = [Arg|VarAcc]
4729 ),
4730 MatchingCondition2 = MatchingCondition
4731 ;
4732 functor(Arg,F,A),
4733 Arg =.. [F|RecArgs],
4734 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4735 FlatArg =.. [F|RecVars],
4736 ( RecMatchings == [] ->
4737 Matchings = [functor(NewVar,F,A)|RestMatchings]
4738 ;
4739 list2conj(RecMatchings,ArgM_conj),
4740 list2disj(MatchingCondition,MatchingCondition_disj),
4741 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4742 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4743 ),
4744 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4745 term_variables(Args,ArgVars),
4746 append(ArgVars,VarAcc,NVarAcc)
4747 ),
4748 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4751 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4752 %
4753 % Returns list of new variables and list of pairwise unifications between given list and variables.
4755 make_matchings_explicit_not_negated([],[],[]).
4756 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4757 Matchings = [Var = X|RMatchings],
4758 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4760 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4761 %
4762 % (Partially) applies substitutions of =Goal= to given list.
4764 apply_guard_wrt_term([],_Guard,[]).
4765 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4766 ( var(Term) ->
4767 apply_guard_wrt_variable(Guard,Term,NTerm)
4768 ;
4769 Term =.. [F|HArgs],
4770 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4771 NTerm =.. [F|NewHArgs]
4772 ),
4773 apply_guard_wrt_term(RH,Guard,RGH).
4775 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4776 %
4777 % (Partially) applies goal =Guard= wrt variable.
4779 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4780 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4781 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4782 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4783 ( Guard = (X = Y), Variable == X ->
4784 NVariable = Y
4785 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4786 functor(NVariable,Functor,Arity)
4787 ;
4788 NVariable = Variable
4789 ).
4792 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4793 % ALWAYS FAILING GUARDS
4794 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4796 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4797 ==>
4798 chr_pp_flag(check_impossible_rules,on),
4799 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4800 conj2list(G,GL),
4801 append(M,GuardList,Info),
4802 append(Info,GL,GuardWithContext),
4803 guard_entailment:entails_guard(GuardWithContext,fail)
4804 |
4805 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4806 set_all_passive(RuleNb).
4808 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4809 % HEAD SIMPLIFICATION
4810 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4812 % now we check the head matchings (guard may have been simplified meanwhile)
4813 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4814 <=>
4815 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4816 simplify_heads(M,GuardList,G,B,NewM,NewB),
4817 NewM \== [],
4818 extract_arguments(Head1,VH1),
4819 extract_arguments(Head2,VH2),
4820 extract_arguments(H,VH),
4821 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4822 substitute_arguments(Head1,H1,NewH1),
4823 substitute_arguments(Head2,H2,NewH2),
4824 append(NewB,NewB_,NewBody),
4825 list2conj(NewBody,BodyMatchings),
4826 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4827 (Head1 \== NewH1 ; Head2 \== NewH2 )
4828 |
4829 rule(RuleNb,NewRule).
4831 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4832 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4833 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4835 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4836 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4837 ( NH == M ->
4838 H2_ = M,
4839 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4840 ;
4841 (M = functor(X,F,A), NH == X ->
4842 length(A_args,A),
4843 (var(H2) ->
4844 NewB1 = [],
4845 H2_ =.. [F|A_args]
4846 ;
4847 H2 =.. [F|OrigArgs],
4848 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4849 H2_ =.. [F|A_args_]
4850 ),
4851 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4852 append(NewB1,NewB2,NewB)
4853 ;
4854 H2_ = H2,
4855 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4856 )
4857 ).
4859 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4860 ( NH == M ->
4861 H1_ = M,
4862 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4863 ;
4864 (M = functor(X,F,A), NH == X ->
4865 length(A_args,A),
4866 (var(H1) ->
4867 NewB1 = [],
4868 H1_ =.. [F|A_args]
4869 ;
4870 H1 =.. [F|OrigArgs],
4871 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4872 H1_ =.. [F|A_args_]
4873 ),
4874 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4875 append(NewB1,NewB2,NewB)
4876 ;
4877 H1_ = H1,
4878 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4879 )
4880 ).
4882 use_same_args([],[],[],_,_,[]).
4883 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4884 var(OA),!,
4885 Out = OA,
4886 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4887 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4888 nonvar(OA),!,
4889 ( common_variables(OA,Body) ->
4890 NewB = [NA = OA|NextB]
4891 ;
4892 NewB = NextB
4893 ),
4894 Out = NA,
4895 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4898 simplify_heads([],_GuardList,_G,_Body,[],[]).
4899 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4900 M = (A = B),
4901 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4902 guard_entailment:entails_guard(GuardList,(A=B)) ->
4903 ( common_variables(B,G-RM-GuardList) ->
4904 NewB = NextB,
4905 NewM = NextM
4906 ;
4907 ( common_variables(B,Body) ->
4908 NewB = [A = B|NextB]
4909 ;
4910 NewB = NextB
4911 ),
4912 NewM = [A|NextM]
4913 )
4914 ;
4915 ( nonvar(B), functor(B,BFu,BAr),
4916 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4917 NewB = NextB,
4918 ( common_variables(B,G-RM-GuardList) ->
4919 NewM = NextM
4920 ;
4921 NewM = [functor(A,BFu,BAr)|NextM]
4922 )
4923 ;
4924 NewM = NextM,
4925 NewB = NextB
4926 )
4927 ),
4928 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4930 common_variables(B,G) :-
4931 term_variables(B,BVars),
4932 term_variables(G,GVars),
4933 intersect_eq(BVars,GVars,L),
4934 L \== [].
4937 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4938 set_all_passive(_) <=> true.
4942 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4943 % OCCURRENCE SUBSUMPTION
4944 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4946 :- chr_constraint
4947 first_occ_in_rule/4,
4948 next_occ_in_rule/6.
4950 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4951 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4953 :- chr_constraint multiple_occ_constraints_checked/1.
4954 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4956 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4957 occurrence(C,O,RuleNb,ID,_),
4958 occurrence(C,O2,RuleNb,ID2,_),
4959 rule(RuleNb,Rule)
4960 \
4961 multiple_occ_constraints_checked(Done)
4962 <=>
4963 O < O2,
4964 chr_pp_flag(occurrence_subsumption,on),
4965 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4966 H1 \== [],
4967 \+ tree_set_memberchk(C,Done)
4968 |
4969 first_occ_in_rule(RuleNb,C,O,ID),
4970 tree_set_add(Done,C,NDone),
4971 multiple_occ_constraints_checked(NDone).
4973 % Find first occurrence of constraint =C= in rule =RuleNb=
4974 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4975 <=>
4976 O < O2
4977 |
4978 first_occ_in_rule(RuleNb,C,O,ID).
4980 first_occ_in_rule(RuleNb,C,O,ID_o1)
4981 <=>
4982 C = F/A,
4983 functor(FreshHead,F,A),
4984 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4986 % Skip passive occurrences.
4987 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4988 <=>
4989 O2 is O+1
4990 |
4991 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4993 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)
4994 <=>
4995 O2 is O+1,
4996 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4997 |
4998 append(H1,H2,Heads),
4999 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5000 ( ExtraCond == [chr_pp_void_info] ->
5001 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5002 ;
5003 append(ExtraCond,Cond,NewCond),
5004 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5005 copy_term(GuardList,FGuardList),
5006 variable_replacement(GuardList,FGuardList,GLRepl),
5007 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5008 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5009 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5010 append(NewCond,GuardList2,BigCond),
5011 append(BigCond,GuardList3,BigCond2),
5012 copy_with_variable_replacement(M,M2,Repl),
5013 copy_with_variable_replacement(M,M3,Repl2),
5014 append(M3,BigCond2,BigCond3),
5015 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5016 list2conj(CheckCond,OccSubsum),
5017 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5018 ( OccSubsum \= chr_pp_void_info ->
5019 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5020 passive(RuleNb,ID_o2)
5021 ;
5022 true
5023 )
5024 ;
5025 true
5026 ),!,
5027 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5028 ).
5031 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5032 <=>
5033 true.
5035 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5036 <=>
5037 true.
5039 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5040 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5041 append(ID2,ID1,IDs),
5042 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5043 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5044 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5045 copy_with_variable_replacement(G,FG,Repl),
5046 extract_explicit_matchings(FG,FG2),
5047 negate_b(FG2,NotFG),
5048 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5049 ( subsumes(FH,FH2) ->
5050 FailCond = [(NotFG;FMPCond)]
5051 ;
5052 % in this case, not much can be done
5053 % e.g. c(f(...)), c(g(...)) <=> ...
5054 FailCond = [chr_pp_void_info]
5055 ).
5057 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5058 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5059 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5060 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5061 Cond = (chr_pp_not_in_store(H);Cond1),
5062 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5064 extract_explicit_matchings((A,B),D) :- !,
5065 ( extract_explicit_matchings(A) ->
5066 extract_explicit_matchings(B,D)
5067 ;
5068 D = (A,E),
5069 extract_explicit_matchings(B,E)
5070 ).
5071 extract_explicit_matchings(A,D) :- !,
5072 ( extract_explicit_matchings(A) ->
5073 D = true
5074 ;
5075 D = A
5076 ).
5078 extract_explicit_matchings(A=B) :-
5079 var(A), var(B), !, A=B.
5080 extract_explicit_matchings(A==B) :-
5081 var(A), var(B), !, A=B.
5083 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5084 % TYPE INFORMATION
5085 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5087 :- chr_constraint
5088 type_definition/2,
5089 type_alias/2,
5090 constraint_type/2,
5091 get_type_definition/2,
5092 get_constraint_type/2.
5095 :- chr_option(mode,type_definition(?,?)).
5096 :- chr_option(mode,get_type_definition(?,?)).
5097 :- chr_option(mode,type_alias(?,?)).
5098 :- chr_option(mode,constraint_type(+,+)).
5099 :- chr_option(mode,get_constraint_type(+,-)).
5101 assert_constraint_type(Constraint,ArgTypes) :-
5102 ( ground(ArgTypes) ->
5103 constraint_type(Constraint,ArgTypes)
5104 ;
5105 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5106 ).
5108 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5109 % Consistency checks of type aliases
5111 type_alias(T1,T2) <=>
5112 var(T1)
5113 |
5114 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5116 type_alias(T1,T2) <=>
5117 var(T2)
5118 |
5119 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5121 type_alias(T,T2) <=>
5122 functor(T,F,A),
5123 functor(T2,F,A),
5124 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5125 |
5126 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5128 type_alias(T1,A1), type_alias(T2,A2) <=>
5129 functor(T1,F,A),
5130 functor(T2,F,A),
5131 \+ (T1\=T2)
5132 |
5133 copy_term_nat(T1,T1_),
5134 copy_term_nat(T2,T2_),
5135 T1_ = T2_,
5136 chr_error(type_error,
5137 '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_]).
5139 type_alias(T,B) \ type_alias(X,T2) <=>
5140 functor(T,F,A),
5141 functor(T2,F,A),
5142 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5143 subsumes(T1,T3)
5144 |
5145 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5146 type_alias(X2,D1).
5148 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5149 % Consistency checks of type definitions
5151 type_definition(T1,_), type_definition(T2,_)
5152 <=>
5153 functor(T1,F,A), functor(T2,F,A)
5154 |
5155 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5157 type_definition(T1,_), type_alias(T2,_)
5158 <=>
5159 functor(T1,F,A), functor(T2,F,A)
5160 |
5161 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5163 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5164 %% get_type_definition(+Type,-Definition) is semidet.
5165 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5167 get_type_definition(T,Def)
5168 <=>
5169 \+ ground(T)
5170 |
5171 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5173 type_alias(T,D) \ get_type_definition(T2,Def)
5174 <=>
5175 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5176 copy_term_nat((T,D),(T1,D1)),T1=T2
5177 |
5178 ( get_type_definition(D1,Def) ->
5179 true
5180 ;
5181 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5182 ).
5184 type_definition(T,D) \ get_type_definition(T2,Def)
5185 <=>
5186 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5187 copy_term_nat((T,D),(T1,D1)),T1=T2
5188 |
5189 Def = D1.
5191 get_type_definition(Type,Def)
5192 <=>
5193 atomic_builtin_type(Type,_,_)
5194 |
5195 Def = [Type].
5197 get_type_definition(Type,Def)
5198 <=>
5199 compound_builtin_type(Type,_,_,_)
5200 |
5201 Def = [Type].
5203 get_type_definition(X,Y) <=> fail.
5205 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5206 %% get_type_definition_det(+Type,-Definition) is det.
5207 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5208 get_type_definition_det(Type,Definition) :-
5209 ( get_type_definition(Type,Definition) ->
5210 true
5211 ;
5212 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5213 ).
5215 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5216 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5217 %
5218 % Return argument types of =ConstraintSymbol=, but fails if none where
5219 % declared.
5220 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5221 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5222 get_constraint_type(_,_) <=> fail.
5224 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5225 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5226 %
5227 % Like =get_constraint_type/2=, but returns list of =any= types when
5228 % no types are declared.
5229 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5230 get_constraint_type_det(ConstraintSymbol,Types) :-
5231 ( get_constraint_type(ConstraintSymbol,Types) ->
5232 true
5233 ;
5234 ConstraintSymbol = _ / N,
5235 replicate(N,any,Types)
5236 ).
5237 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5238 %% unalias_type(+Alias,-Type) is det.
5239 %
5240 % Follows alias chain until base type is reached.
5241 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5242 :- chr_constraint unalias_type/2.
5244 unalias_var @
5245 unalias_type(Alias,BaseType)
5246 <=>
5247 var(Alias)
5248 |
5249 BaseType = Alias.
5251 unalias_alias @
5252 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5253 <=>
5254 nonvar(AliasProtoType),
5255 nonvar(Alias),
5256 functor(AliasProtoType,F,A),
5257 functor(Alias,F,A),
5258 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5259 Alias = AliasInstance
5260 |
5261 unalias_type(Type,BaseType).
5263 unalias_type_definition @
5264 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5265 <=>
5266 nonvar(ProtoType),
5267 nonvar(Alias),
5268 functor(ProtoType,F,A),
5269 functor(Alias,F,A)
5270 |
5271 BaseType = Alias.
5273 unalias_atomic_builtin @
5274 unalias_type(Alias,BaseType)
5275 <=>
5276 atomic_builtin_type(Alias,_,_)
5277 |
5278 BaseType = Alias.
5280 unalias_compound_builtin @
5281 unalias_type(Alias,BaseType)
5282 <=>
5283 compound_builtin_type(Alias,_,_,_)
5284 |
5285 BaseType = Alias.
5287 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5288 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5289 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5290 :- chr_constraint types_modes_condition/3.
5291 :- chr_option(mode,types_modes_condition(+,+,?)).
5292 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5294 types_modes_condition([],[],T) <=> T=true.
5296 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5297 <=>
5298 functor(Head,F,A)
5299 |
5300 Head =.. [_|Args],
5301 Condition = (ModesCondition, TypesCondition, RestCondition),
5302 modes_condition(Modes,Args,ModesCondition),
5303 get_constraint_type_det(F/A,Types),
5304 UnrollHead =.. [_|RealArgs],
5305 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5306 types_modes_condition(Heads,UnrollHeads,RestCondition).
5308 types_modes_condition([Head|_],_,_)
5309 <=>
5310 functor(Head,F,A),
5311 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5314 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5315 %% modes_condition(+Modes,+Args,-Condition) is det.
5316 %
5317 % Return =Condition= on =Args= that checks =Modes=.
5318 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5319 modes_condition([],[],true).
5320 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5321 ( Mode == (+) ->
5322 Condition = ( ground(Arg) , RCondition )
5323 ; Mode == (-) ->
5324 Condition = ( var(Arg) , RCondition )
5325 ;
5326 Condition = RCondition
5327 ),
5328 modes_condition(Modes,Args,RCondition).
5330 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5331 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5332 %
5333 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5334 % =UnrollArgs= controls the depth of type definition unrolling.
5335 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5336 types_condition([],[],[],[],true).
5337 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5338 ( Mode == (-) ->
5339 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5340 ;
5341 get_type_definition_det(Type,Def),
5342 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5343 ( Mode == (+) ->
5344 TypeConditionList = TypeConditionList1
5345 ;
5346 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5347 )
5348 ),
5349 list2disj(TypeConditionList,DisjTypeConditionList),
5350 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5352 type_condition([],_,_,_,[]).
5353 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5354 ( var(DefCase) ->
5355 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5356 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5357 true
5358 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5359 true
5360 ;
5361 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5362 ),
5363 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5365 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5366 :- chr_type atomic_builtin_type ---> any
5367 ; number
5368 ; float
5369 ; int
5370 ; natural
5371 ; dense_int
5372 ; chr_identifier
5373 ; chr_identifier(any)
5374 ; /* all possible values are given */
5375 chr_enum(list(any))
5376 ; /* all possible values appear in rule heads;
5377 to distinguish between multiple chr_constants
5378 we have a key*/
5379 chr_constants(any)
5380 ; /* all relevant values appear in rule heads;
5381 for other values a handler is provided */
5382 chr_constants(any,any).
5383 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5385 atomic_builtin_type(any,_Arg,true).
5386 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5387 atomic_builtin_type(int,Arg,integer(Arg)).
5388 atomic_builtin_type(number,Arg,number(Arg)).
5389 atomic_builtin_type(float,Arg,float(Arg)).
5390 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5391 atomic_builtin_type(chr_identifier,_Arg,true).
5393 compound_builtin_type(chr_constants(_),_Arg,true,true).
5394 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5395 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5396 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5397 once(( member(Constant,Constants),
5398 unifiable(Arg,Constant,_)
5399 )
5400 )
5401 ).
5403 is_chr_constants_type(chr_constants(Key),Key,no).
5404 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5406 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5407 ( nonvar(DefCase) ->
5408 functor(DefCase,F,A),
5409 ( A == 0 ->
5410 Condition = (Arg = DefCase)
5411 ; var(UnrollArg) ->
5412 Condition = functor(Arg,F,A)
5413 ; functor(UnrollArg,F,A) ->
5414 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5415 DefCase =.. [_|ArgTypes],
5416 UnrollArg =.. [_|UnrollArgs],
5417 functor(Template,F,A),
5418 Template =.. [_|TemplateArgs],
5419 replicate(A,Mode,ArgModes),
5420 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5421 ;
5422 Condition = functor(Arg,F,A)
5423 )
5424 ;
5425 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5426 ).
5429 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5430 % STATIC TYPE CHECKING
5431 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5432 % Checks head constraints and CHR constraint calls in bodies.
5433 %
5434 % TODO:
5435 % - type clashes involving built-in types
5436 % - Prolog built-ins in guard and body
5437 % - indicate position in terms in error messages
5438 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5439 :- chr_constraint
5440 static_type_check/0.
5443 % 1. Check the declared types
5445 constraint_type(Constraint,ArgTypes), static_type_check
5446 ==>
5447 forall(
5448 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5449 ( get_type_definition(Type,_) ->
5450 true
5451 ;
5452 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5453 )
5454 ).
5456 % 2. Check the rules
5458 :- chr_type type_error_src ---> head(any) ; body(any).
5460 rule(_,Rule), static_type_check
5461 ==>
5462 copy_term_nat(Rule,RuleCopy),
5463 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5464 (
5465 catch(
5466 ( static_type_check_heads(Head1),
5467 static_type_check_heads(Head2),
5468 conj2list(Body,GoalList),
5469 static_type_check_body(GoalList)
5470 ),
5471 type_error(Error),
5472 ( Error = invalid_functor(Src,Term,Type) ->
5473 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5474 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5475 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5476 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5477 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5478 )
5479 ),
5480 fail % cleanup constraints
5481 ;
5482 true
5483 ).
5486 static_type_check <=> true.
5488 static_type_check_heads([]).
5489 static_type_check_heads([Head|Heads]) :-
5490 static_type_check_head(Head),
5491 static_type_check_heads(Heads).
5493 static_type_check_head(Head) :-
5494 functor(Head,F,A),
5495 get_constraint_type_det(F/A,Types),
5496 Head =..[_|Args],
5497 maplist(static_type_check_term(head(Head)),Args,Types).
5499 static_type_check_body([]).
5500 static_type_check_body([Goal|Goals]) :-
5501 functor(Goal,F,A),
5502 get_constraint_type_det(F/A,Types),
5503 Goal =..[_|Args],
5504 maplist(static_type_check_term(body(Goal)),Args,Types),
5505 static_type_check_body(Goals).
5507 :- chr_constraint static_type_check_term/3.
5508 :- chr_option(mode,static_type_check_term(?,?,?)).
5509 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5511 static_type_check_term(Src,Term,Type)
5512 <=>
5513 var(Term)
5514 |
5515 static_type_check_var(Src,Term,Type).
5516 static_type_check_term(Src,Term,Type)
5517 <=>
5518 atomic_builtin_type(Type,Term,Goal)
5519 |
5520 ( call(Goal) ->
5521 true
5522 ;
5523 throw(type_error(invalid_functor(Src,Term,Type)))
5524 ).
5525 static_type_check_term(Src,Term,Type)
5526 <=>
5527 compound_builtin_type(Type,Term,_,Goal)
5528 |
5529 ( call(Goal) ->
5530 true
5531 ;
5532 throw(type_error(invalid_functor(Src,Term,Type)))
5533 ).
5534 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5535 <=>
5536 functor(Type,F,A),
5537 functor(AType,F,A)
5538 |
5539 copy_term_nat(AType-ADef,Type-Def),
5540 static_type_check_term(Src,Term,Def).
5542 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5543 <=>
5544 functor(Type,F,A),
5545 functor(AType,F,A)
5546 |
5547 copy_term_nat(AType-ADef,Type-Variants),
5548 functor(Term,TF,TA),
5549 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5550 Term =.. [_|Args],
5551 Variant =.. [_|Types],
5552 maplist(static_type_check_term(Src),Args,Types)
5553 ;
5554 throw(type_error(invalid_functor(Src,Term,Type)))
5555 ).
5557 static_type_check_term(Src,Term,Type)
5558 <=>
5559 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5561 :- chr_constraint static_type_check_var/3.
5562 :- chr_option(mode,static_type_check_var(?,-,?)).
5563 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5565 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5566 <=>
5567 functor(AType,F,A),
5568 functor(Type,F,A)
5569 |
5570 copy_term_nat(AType-ADef,Type-Def),
5571 static_type_check_var(Src,Var,Def).
5573 static_type_check_var(Src,Var,Type)
5574 <=>
5575 atomic_builtin_type(Type,_,_)
5576 |
5577 static_atomic_builtin_type_check_var(Src,Var,Type).
5579 static_type_check_var(Src,Var,Type)
5580 <=>
5581 compound_builtin_type(Type,_,_,_)
5582 |
5583 true.
5586 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5587 <=>
5588 Type1 \== Type2
5589 |
5590 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5592 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5593 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5594 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5595 :- chr_constraint static_atomic_builtin_type_check_var/3.
5596 :- chr_option(mode,static_type_check_var(?,-,+)).
5597 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5599 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5600 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5601 <=>
5602 true.
5603 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5604 <=>
5605 true.
5606 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5607 <=>
5608 true.
5609 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5610 <=>
5611 true.
5612 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5613 <=>
5614 true.
5615 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5616 <=>
5617 true.
5618 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5619 <=>
5620 true.
5621 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5622 <=>
5623 true.
5624 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5625 <=>
5626 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5628 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5629 %% format_src(+type_error_src) is det.
5630 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5631 format_src(head(Head)) :- format('head ~w',[Head]).
5632 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5634 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5635 % Dynamic type checking
5636 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5638 :- chr_constraint
5639 dynamic_type_check/0,
5640 dynamic_type_check_clauses/1,
5641 get_dynamic_type_check_clauses/1.
5643 generate_dynamic_type_check_clauses(Clauses) :-
5644 ( chr_pp_flag(debugable,on) ->
5645 dynamic_type_check,
5646 get_dynamic_type_check_clauses(Clauses0),
5647 append(Clauses0,
5648 [('$dynamic_type_check'(Type,Term) :-
5649 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5650 )],
5651 Clauses)
5652 ;
5653 Clauses = []
5654 ).
5656 type_definition(T,D), dynamic_type_check
5657 ==>
5658 copy_term_nat(T-D,Type-Definition),
5659 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5660 dynamic_type_check_clauses(DynamicChecks).
5661 type_alias(A,B), dynamic_type_check
5662 ==>
5663 copy_term_nat(A-B,Alias-Body),
5664 dynamic_type_check_alias_clause(Alias,Body,Clause),
5665 dynamic_type_check_clauses([Clause]).
5667 dynamic_type_check <=>
5668 findall(
5669 ('$dynamic_type_check'(Type,Term) :- Goal),
5670 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5671 BuiltinChecks
5672 ),
5673 dynamic_type_check_clauses(BuiltinChecks).
5675 dynamic_type_check_clause(T,DC,Clause) :-
5676 copy_term(T-DC,Type-DefinitionClause),
5677 functor(DefinitionClause,F,A),
5678 functor(Term,F,A),
5679 DefinitionClause =.. [_|DCArgs],
5680 Term =.. [_|TermArgs],
5681 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5682 list2conj(RecursiveCallList,RecursiveCalls),
5683 Clause = (
5684 '$dynamic_type_check'(Type,Term) :-
5685 RecursiveCalls
5686 ).
5688 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5689 Clause = (
5690 '$dynamic_type_check'(Alias,Term) :-
5691 '$dynamic_type_check'(Body,Term)
5692 ).
5694 dynamic_type_check_call(Type,Term,Call) :-
5695 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5696 % Call = when(nonvar(Term),Goal)
5697 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5698 % Call = when(nonvar(Term),Goal)
5699 % ;
5700 ( Type == any ->
5701 Call = true
5702 ;
5703 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5704 )
5705 % )
5706 .
5708 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5709 <=>
5710 append(C1,C2,C),
5711 dynamic_type_check_clauses(C).
5713 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5714 <=>
5715 Q = C.
5716 get_dynamic_type_check_clauses(Q)
5717 <=>
5718 Q = [].
5720 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5721 % Atomic Types
5722 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5723 % Some optimizations can be applied for atomic types...
5724 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5726 atomic_types_suspended_constraint(C) :-
5727 C = _/N,
5728 get_constraint_type(C,ArgTypes),
5729 get_constraint_mode(C,ArgModes),
5730 numlist(1,N,Indexes),
5731 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5733 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5734 ( is_indexed_argument(C,Index) ->
5735 ( Mode == (?) ->
5736 atomic_type(Type)
5737 ;
5738 true
5739 )
5740 ;
5741 true
5742 ).
5744 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5745 %% atomic_type(+Type) is semidet.
5746 %
5747 % Succeeds when all values of =Type= are atomic.
5748 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5749 :- chr_constraint atomic_type/1.
5751 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5753 type_definition(TypePat,Def) \ atomic_type(Type)
5754 <=>
5755 functor(Type,F,A), functor(TypePat,F,A)
5756 |
5757 maplist(atomic,Def).
5759 type_alias(TypePat,Alias) \ atomic_type(Type)
5760 <=>
5761 functor(Type,F,A), functor(TypePat,F,A)
5762 |
5763 atomic(Alias),
5764 copy_term_nat(TypePat-Alias,Type-NType),
5765 atomic_type(NType).
5767 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5768 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5769 %
5770 % Succeeds when all values of =Type= are atomic
5771 % and the atom values are finitely enumerable.
5772 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5773 :- chr_constraint enumerated_atomic_type/2.
5775 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5777 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5778 <=>
5779 functor(Type,F,A), functor(TypePat,F,A)
5780 |
5781 maplist(atomic,Def),
5782 Atoms = Def.
5784 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5785 <=>
5786 functor(Type,F,A), functor(TypePat,F,A)
5787 |
5788 atomic(Alias),
5789 copy_term_nat(TypePat-Alias,Type-NType),
5790 enumerated_atomic_type(NType,Atoms).
5791 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5793 :- chr_constraint
5794 stored/3, % constraint,occurrence,(yes/no/maybe)
5795 stored_completing/3,
5796 stored_complete/3,
5797 is_stored/1,
5798 is_finally_stored/1,
5799 check_all_passive/2.
5801 :- chr_option(mode,stored(+,+,+)).
5802 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5803 :- chr_type storedinfo ---> yes ; no ; maybe.
5804 :- chr_option(mode,stored_complete(+,+,+)).
5805 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5806 :- chr_option(mode,guard_list(+,+,+,+)).
5807 :- chr_option(mode,check_all_passive(+,+)).
5808 :- chr_option(type_declaration,check_all_passive(any,list)).
5810 % change yes in maybe when yes becomes passive
5811 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5812 stored(C,O,yes), stored_complete(C,RO,Yesses)
5813 <=> O < RO | NYesses is Yesses - 1,
5814 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5815 % change yes in maybe when not observed
5816 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5817 <=> O < RO |
5818 NYesses is Yesses - 1,
5819 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5821 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5822 ==> RO =< MO2 | % C2 is never stored
5823 passive(RuleNb,ID).
5828 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5830 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5831 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5832 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5834 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5835 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5836 check_all_passive(RuleNb,IDs2).
5838 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5839 check_all_passive(RuleNb,IDs).
5841 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5842 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5844 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5846 % collect the storage information
5847 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5848 <=> NO is O + 1, NYesses is Yesses + 1,
5849 stored_completing(C,NO,NYesses).
5850 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5851 <=> NO is O + 1,
5852 stored_completing(C,NO,Yesses).
5854 stored(C,O,no) \ stored_completing(C,O,Yesses)
5855 <=> stored_complete(C,O,Yesses).
5856 stored_completing(C,O,Yesses)
5857 <=> stored_complete(C,O,Yesses).
5859 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5860 O2 > O | passive(RuleNb,Id).
5862 % decide whether a constraint is stored
5863 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5864 <=> RO =< MO | fail.
5865 is_stored(C) <=> true.
5867 % decide whether a constraint is suspends after occurrences
5868 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5869 <=> RO =< MO | fail.
5870 is_finally_stored(C) <=> true.
5872 storage_analysis(Constraints) :-
5873 ( chr_pp_flag(storage_analysis,on) ->
5874 check_constraint_storages(Constraints)
5875 ;
5876 true
5877 ).
5879 check_constraint_storages([]).
5880 check_constraint_storages([C|Cs]) :-
5881 check_constraint_storage(C),
5882 check_constraint_storages(Cs).
5884 check_constraint_storage(C) :-
5885 get_max_occurrence(C,MO),
5886 check_occurrences_storage(C,1,MO).
5888 check_occurrences_storage(C,O,MO) :-
5889 ( O > MO ->
5890 stored_completing(C,1,0)
5891 ;
5892 check_occurrence_storage(C,O),
5893 NO is O + 1,
5894 check_occurrences_storage(C,NO,MO)
5895 ).
5897 check_occurrence_storage(C,O) :-
5898 get_occurrence(C,O,RuleNb,ID),
5899 ( is_passive(RuleNb,ID) ->
5900 stored(C,O,maybe)
5901 ;
5902 get_rule(RuleNb,PragmaRule),
5903 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5904 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5905 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5906 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5907 check_storage_head2(Head2,O,Heads1,Body)
5908 )
5909 ).
5911 check_storage_head1(Head,O,H1,H2,G) :-
5912 functor(Head,F,A),
5913 C = F/A,
5914 ( H1 == [Head],
5915 H2 == [],
5916 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5917 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5918 Head =.. [_|L],
5919 no_matching(L,[]) ->
5920 stored(C,O,no)
5921 ;
5922 stored(C,O,maybe)
5923 ).
5925 no_matching([],_).
5926 no_matching([X|Xs],Prev) :-
5927 var(X),
5928 \+ memberchk_eq(X,Prev),
5929 no_matching(Xs,[X|Prev]).
5931 check_storage_head2(Head,O,H1,B) :-
5932 functor(Head,F,A),
5933 C = F/A,
5934 ( %(
5935 ( H1 \== [], B == true )
5936 %;
5937 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5938 %)
5939 ->
5940 stored(C,O,maybe)
5941 ;
5942 stored(C,O,yes)
5943 ).
5945 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5947 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5948 %% ____ _ ____ _ _ _ _
5949 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5950 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5951 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5952 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5953 %% |_|
5955 constraints_code(Constraints,Clauses) :-
5956 (chr_pp_flag(reduced_indexing,on),
5957 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5958 none_suspended_on_variables
5959 ;
5960 true
5961 ),
5962 constraints_code1(Constraints,Clauses,[]).
5964 %===============================================================================
5965 :- chr_constraint constraints_code1/3.
5966 :- chr_option(mode,constraints_code1(+,+,+)).
5967 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5968 %-------------------------------------------------------------------------------
5969 constraints_code1([],L,T) <=> L = T.
5970 constraints_code1([C|RCs],L,T)
5971 <=>
5972 constraint_code(C,L,T1),
5973 constraints_code1(RCs,T1,T).
5974 %===============================================================================
5975 :- chr_constraint constraint_code/3.
5976 :- chr_option(mode,constraint_code(+,+,+)).
5977 %-------------------------------------------------------------------------------
5978 %% Generate code for a single CHR constraint
5979 constraint_code(Constraint, L, T)
5980 <=> true
5981 | ( (chr_pp_flag(debugable,on) ;
5982 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5983 ( may_trigger(Constraint) ;
5984 get_allocation_occurrence(Constraint,AO),
5985 get_max_occurrence(Constraint,MO), MO >= AO ) )
5986 ->
5987 constraint_prelude(Constraint,Clause),
5988 add_dummy_location(Clause,LocatedClause),
5989 L = [LocatedClause | L1]
5990 ;
5991 L = L1
5992 ),
5993 Id = [0],
5994 occurrences_code(Constraint,1,Id,NId,L1,L2),
5995 gen_cond_attach_clause(Constraint,NId,L2,T).
5997 %===============================================================================
5998 %% Generate prelude predicate for a constraint.
5999 %% f(...) :- f/a_0(...,Susp).
6000 constraint_prelude(F/A, Clause) :-
6001 vars_susp(A,Vars,Susp,VarsSusp),
6002 Head =.. [ F | Vars],
6003 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6004 build_head(F,A,[0],VarsSusp,Delegate),
6005 ( chr_pp_flag(debugable,on) ->
6006 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6007 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6008 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6009 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6011 ( get_constraint_type(F/A,ArgTypeList) ->
6012 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6013 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6014 ;
6015 DynamicTypeChecks = true
6016 ),
6018 Clause =
6019 ( Head :-
6020 DynamicTypeChecks,
6021 InsertGoal,
6022 InsertCall,
6023 AttachCall,
6024 Inactive,
6025 'chr debug_event'(insert(Head#Susp)),
6026 (
6027 'chr debug_event'(call(Susp)),
6028 Delegate
6029 ;
6030 'chr debug_event'(fail(Susp)), !,
6031 fail
6032 ),
6033 (
6034 'chr debug_event'(exit(Susp))
6035 ;
6036 'chr debug_event'(redo(Susp)),
6037 fail
6038 )
6039 )
6040 ; get_allocation_occurrence(F/A,0) ->
6041 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6042 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6043 Clause = ( Head :- Goal, Inactive, Delegate )
6044 ;
6045 Clause = ( Head :- Delegate )
6046 ).
6048 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6049 ( may_trigger(F/A) ->
6050 build_head(F,A,[0],VarsSusp,Delegate),
6051 ( chr_pp_flag(debugable,off) ->
6052 Goal = Delegate
6053 ;
6054 get_target_module(Mod),
6055 Goal = Mod:Delegate
6056 )
6057 ;
6058 Goal = true
6059 ).
6061 %===============================================================================
6062 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6063 :- chr_option(mode,has_active_occurrence(+)).
6064 :- chr_option(mode,has_active_occurrence(+,+)).
6066 :- chr_constraint memo_has_active_occurrence/1.
6067 :- chr_option(mode,memo_has_active_occurrence(+)).
6068 %-------------------------------------------------------------------------------
6069 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6070 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6072 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6073 O > MO | fail.
6074 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6075 has_active_occurrence(C,O) <=>
6076 NO is O + 1,
6077 has_active_occurrence(C,NO).
6078 has_active_occurrence(C,O) <=> true.
6079 %===============================================================================
6081 gen_cond_attach_clause(F/A,Id,L,T) :-
6082 ( is_finally_stored(F/A) ->
6083 get_allocation_occurrence(F/A,AllocationOccurrence),
6084 get_max_occurrence(F/A,MaxOccurrence),
6085 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6086 ( only_ground_indexed_arguments(F/A) ->
6087 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6088 ;
6089 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6090 )
6091 ; vars_susp(A,Args,Susp,AllArgs),
6092 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6093 ),
6094 build_head(F,A,Id,AllArgs,Head),
6095 Clause = ( Head :- Body ),
6096 add_dummy_location(Clause,LocatedClause),
6097 L = [LocatedClause | T]
6098 ;
6099 L = T
6100 ).
6102 :- chr_constraint use_auxiliary_predicate/1.
6103 :- chr_option(mode,use_auxiliary_predicate(+)).
6105 :- chr_constraint use_auxiliary_predicate/2.
6106 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6108 :- chr_constraint is_used_auxiliary_predicate/1.
6109 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6111 :- chr_constraint is_used_auxiliary_predicate/2.
6112 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6115 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6117 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6119 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6121 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6123 is_used_auxiliary_predicate(P) <=> fail.
6125 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6126 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6128 is_used_auxiliary_predicate(P,C) <=> fail.
6130 %------------------------------------------------------------------------------%
6131 % Only generate import statements for actually used modules.
6132 %------------------------------------------------------------------------------%
6134 :- chr_constraint use_auxiliary_module/1.
6135 :- chr_option(mode,use_auxiliary_module(+)).
6137 :- chr_constraint is_used_auxiliary_module/1.
6138 :- chr_option(mode,is_used_auxiliary_module(+)).
6141 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6143 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6145 is_used_auxiliary_module(P) <=> fail.
6147 % only called for constraints with
6148 % at least one
6149 % non-ground indexed argument
6150 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6151 vars_susp(A,Args,Susp,AllArgs),
6152 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6153 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6154 Attach = true
6155 ;
6156 attach_constraint_atom(F/A,Vars,Susp,Attach)
6157 ),
6158 FTerm =.. [F|Args],
6159 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6160 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6161 ( may_trigger(F/A) ->
6162 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6163 Goal =
6164 (
6165 ( var(Susp) ->
6166 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6167 InsertCall,
6168 Attach
6169 ;
6170 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6171 )
6172 )
6173 ;
6174 Goal =
6175 (
6176 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6177 InsertCall,
6178 Attach
6179 )
6180 ).
6182 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6183 vars_susp(A,Args,Susp,AllArgs),
6184 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6185 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6186 attach_constraint_atom(F/A,Vars,Susp,Attach)
6187 ;
6188 Attach = true
6189 ),
6190 FTerm =.. [F|Args],
6191 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6192 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6193 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6194 Goal =
6195 (
6196 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6197 InsertCall
6198 )
6199 ;
6200 Goal =
6201 (
6202 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6203 InsertCall,
6204 Attach
6205 )
6206 ).
6208 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6209 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6210 attach_constraint_atom(FA,Vars,Susp,Attach)
6211 ;
6212 Attach = true
6213 ),
6214 insert_constraint_goal(FA,Susp,Args,InsertCall),
6215 ( chr_pp_flag(late_allocation,on) ->
6216 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6217 ;
6218 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6219 ).
6221 %-------------------------------------------------------------------------------
6222 :- chr_constraint occurrences_code/6.
6223 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6224 %-------------------------------------------------------------------------------
6225 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6226 <=> O > MO
6227 | NId = Id, L = T.
6228 occurrences_code(C,O,Id,NId,L,T)
6229 <=>
6230 occurrence_code(C,O,Id,Id1,L,L1),
6231 NO is O + 1,
6232 occurrences_code(C,NO,Id1,NId,L1,T).
6233 %-------------------------------------------------------------------------------
6234 :- chr_constraint occurrence_code/6.
6235 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6236 %-------------------------------------------------------------------------------
6237 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6238 <=>
6239 ( named_history(RuleNb,_,_) ->
6240 does_use_history(C,O)
6241 ;
6242 true
6243 ),
6244 NId = Id,
6245 L = T.
6246 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6247 <=> true |
6248 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6249 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6250 NId = Id,
6251 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6252 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6254 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6255 ( should_skip_to_next_id(C,O) ->
6256 inc_id(Id,NId),
6257 ( unconditional_occurrence(C,O) ->
6258 L1 = T
6259 ;
6260 gen_alloc_inc_clause(C,O,Id,L1,T)
6261 )
6262 ;
6263 NId = Id,
6264 L1 = T
6265 )
6266 ).
6268 occurrence_code(C,O,_,_,_,_)
6269 <=>
6270 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6271 %-------------------------------------------------------------------------------
6273 %% Generate code based on one removed head of a CHR rule
6274 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6275 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6276 Rule = rule(_,Head2,_,_),
6277 ( Head2 == [] ->
6278 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6279 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6280 ;
6281 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6282 ).
6284 %% Generate code based on one persistent head of a CHR rule
6285 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6286 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6287 Rule = rule(Head1,_,_,_),
6288 ( Head1 == [] ->
6289 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6290 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6291 ;
6292 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6293 ).
6295 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6296 vars_susp(A,Vars,Susp,VarsSusp),
6297 build_head(F,A,Id,VarsSusp,Head),
6298 inc_id(Id,IncId),
6299 build_head(F,A,IncId,VarsSusp,CallHead),
6300 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6301 Clause =
6302 (
6303 Head :-
6304 ConditionalAlloc,
6305 CallHead
6306 ),
6307 add_dummy_location(Clause,LocatedClause),
6308 L = [LocatedClause|T].
6310 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6311 get_allocation_occurrence(FA,AO),
6312 get_occurrence_code_id(FA,AO,AId),
6313 get_occurrence_code_id(FA,O,Id),
6314 ( chr_pp_flag(debugable,off), Id == AId ->
6315 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6316 ( may_trigger(FA) ->
6317 Goal = (var(Susp) -> Goal0 ; true)
6318 ;
6319 Goal = Goal0
6320 )
6321 ;
6322 Goal = true
6323 ).
6325 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6326 get_allocation_occurrence(FA,AO),
6327 ( chr_pp_flag(debugable,off), O < AO ->
6328 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6329 ( may_trigger(FA) ->
6330 Goal = (var(Susp) -> Goal0 ; true)
6331 ;
6332 Goal = Goal0
6333 )
6334 ;
6335 Goal = true
6336 ).
6338 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6340 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6341 %
6342 % Reorders guard goals with respect to partner constraint retrieval goals and
6343 % active constraint. Returns combined partner retrieval + guard goal.
6345 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6346 ( chr_pp_flag(guard_via_reschedule,on) ->
6347 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6348 list2conj(ScheduleSkeleton,GoalSkeleton)
6349 ;
6350 length(Retrievals,RL), length(LookupSkeleton,RL),
6351 length(GuardList,GL), length(GuardListSkeleton,GL),
6352 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6353 list2conj(GoalListSkeleton,GoalSkeleton)
6354 ).
6355 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6356 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6357 initialize_unit_dictionary(ActiveHead,Dict),
6358 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6359 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6360 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6361 dependency_reorder(Units,NUnits),
6362 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6363 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6364 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6366 wrappedunits2lists([],[],[],[]).
6367 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6368 Ss = [GoalCopy|TSs],
6369 ( WrappedGoal = lookup(Goal) ->
6370 Ls = [GoalCopy|TLs],
6371 Gs = TGs
6372 ; WrappedGoal = guard(Goal) ->
6373 Gs = [N-GoalCopy|TGs],
6374 Ls = TLs
6375 ),
6376 wrappedunits2lists(Units,TGs,TLs,TSs).
6378 guard_splitting(Rule,SplitGuardList) :-
6379 Rule = rule(H1,H2,Guard,_),
6380 append(H1,H2,Heads),
6381 conj2list(Guard,GuardList),
6382 term_variables(Heads,HeadVars),
6383 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6384 append(GuardPrefix,[RestGuard],SplitGuardList),
6385 term_variables(RestGuardList,GuardVars1),
6386 % variables that are declared to be ground don't need to be locked
6387 ground_vars(Heads,GroundVars),
6388 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6389 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6390 ( chr_pp_flag(guard_locks,on),
6391 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6392 once(pairup(Locks,Unlocks,LocksUnlocks))
6393 ;
6394 Locks = [],
6395 Unlocks = []
6396 ),
6397 list2conj(Locks,LockPhase),
6398 list2conj(Unlocks,UnlockPhase),
6399 list2conj(RestGuardList,RestGuard1),
6400 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6402 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6403 Rule = rule(_,_,_,Body),
6404 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6405 my_term_copy(Body,VarDict2,BodyCopy).
6408 split_off_simple_guard_new([],_,[],[]).
6409 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6410 ( simple_guard_new(G,VarDict) ->
6411 S = [G|Ss],
6412 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6413 ;
6414 S = [],
6415 C = [G|Gs]
6416 ).
6418 % simple guard: cheap and benign (does not bind variables)
6419 simple_guard_new(G,Vars) :-
6420 builtin_binds_b(G,BoundVars),
6421 not(( member(V,BoundVars),
6422 memberchk_eq(V,Vars)
6423 )).
6425 dependency_reorder(Units,NUnits) :-
6426 dependency_reorder(Units,[],NUnits).
6428 dependency_reorder([],Acc,Result) :-
6429 reverse(Acc,Result).
6431 dependency_reorder([Unit|Units],Acc,Result) :-
6432 Unit = unit(_GID,_Goal,Type,GIDs),
6433 ( Type == fixed ->
6434 NAcc = [Unit|Acc]
6435 ;
6436 dependency_insert(Acc,Unit,GIDs,NAcc)
6437 ),
6438 dependency_reorder(Units,NAcc,Result).
6440 dependency_insert([],Unit,_,[Unit]).
6441 dependency_insert([X|Xs],Unit,GIDs,L) :-
6442 X = unit(GID,_,_,_),
6443 ( memberchk(GID,GIDs) ->
6444 L = [Unit,X|Xs]
6445 ;
6446 L = [X | T],
6447 dependency_insert(Xs,Unit,GIDs,T)
6448 ).
6450 build_units(Retrievals,Guard,InitialDict,Units) :-
6451 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6452 build_guard_units(Guard,N,Dict,Tail).
6454 build_retrieval_units([],N,N,Dict,Dict,L,L).
6455 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6456 term_variables(U,Vs),
6457 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6458 L = [unit(N,U,fixed,GIDs)|L1],
6459 N1 is N + 1,
6460 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6462 initialize_unit_dictionary(Term,Dict) :-
6463 term_variables(Term,Vars),
6464 pair_all_with(Vars,0,Dict).
6466 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6467 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6468 ( lookup_eq(Dict,V,GID) ->
6469 ( (GID == This ; memberchk(GID,GIDs) ) ->
6470 GIDs1 = GIDs
6471 ;
6472 GIDs1 = [GID|GIDs]
6473 ),
6474 Dict1 = Dict
6475 ;
6476 Dict1 = [V - This|Dict],
6477 GIDs1 = GIDs
6478 ),
6479 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6481 build_guard_units(Guard,N,Dict,Units) :-
6482 ( Guard = [Goal] ->
6483 Units = [unit(N,Goal,fixed,[])]
6484 ; Guard = [Goal|Goals] ->
6485 term_variables(Goal,Vs),
6486 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6487 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6488 N1 is N + 1,
6489 build_guard_units(Goals,N1,NDict,RUnits)
6490 ).
6492 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6493 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6494 ( lookup_eq(Dict,V,GID) ->
6495 ( (GID == This ; memberchk(GID,GIDs) ) ->
6496 GIDs1 = GIDs
6497 ;
6498 GIDs1 = [GID|GIDs]
6499 ),
6500 Dict1 = [V - This|Dict]
6501 ;
6502 Dict1 = [V - This|Dict],
6503 GIDs1 = GIDs
6504 ),
6505 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6509 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6510 %% ____ _ ____ _ _
6511 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6512 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6513 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6514 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6515 %%
6516 %% _ _ _ ___ __
6517 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6518 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6519 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6520 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6521 %% |_|
6522 :- chr_constraint
6523 functional_dependency/4,
6524 get_functional_dependency/4.
6526 :- chr_option(mode,functional_dependency(+,+,?,?)).
6527 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6529 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6530 <=>
6531 RuleNb > 1, AO > O
6532 |
6533 functional_dependency(C,1,Pattern,Key).
6535 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6536 <=>
6537 RuleNb2 >= RuleNb1
6538 |
6539 QPattern = Pattern, QKey = Key.
6540 get_functional_dependency(_,_,_,_)
6541 <=>
6542 fail.
6544 functional_dependency_analysis(Rules) :-
6545 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6546 functional_dependency_analysis_main(Rules)
6547 ;
6548 true
6549 ).
6551 functional_dependency_analysis_main([]).
6552 functional_dependency_analysis_main([PRule|PRules]) :-
6553 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6554 functional_dependency(C,RuleNb,Pattern,Key)
6555 ;
6556 true
6557 ),
6558 functional_dependency_analysis_main(PRules).
6560 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6561 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6562 Rule = rule(H1,H2,Guard,_),
6563 ( H1 = [C1],
6564 H2 = [C2] ->
6565 true
6566 ; H1 = [C1,C2],
6567 H2 == [] ->
6568 true
6569 ),
6570 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6571 term_variables(C1,Vs),
6572 \+ (
6573 member(V1,Vs),
6574 lookup_eq(List,V1,V2),
6575 memberchk_eq(V2,Vs)
6576 ),
6577 select_pragma_unique_variables(Vs,List,Key1),
6578 copy_term_nat(C1-Key1,Pattern-Key),
6579 functor(C1,F,A).
6581 select_pragma_unique_variables([],_,[]).
6582 select_pragma_unique_variables([V|Vs],List,L) :-
6583 ( lookup_eq(List,V,_) ->
6584 L = T
6585 ;
6586 L = [V|T]
6587 ),
6588 select_pragma_unique_variables(Vs,List,T).
6590 % depends on functional dependency analysis
6591 % and shape of rule: C1 \ C2 <=> true.
6592 set_semantics_rules(Rules) :-
6593 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6594 set_semantics_rules_main(Rules)
6595 ;
6596 true
6597 ).
6599 set_semantics_rules_main([]).
6600 set_semantics_rules_main([R|Rs]) :-
6601 set_semantics_rule_main(R),
6602 set_semantics_rules_main(Rs).
6604 set_semantics_rule_main(PragmaRule) :-
6605 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6606 ( Rule = rule([C1],[C2],true,_),
6607 IDs = ids([ID1],[ID2]),
6608 \+ is_passive(RuleNb,ID1),
6609 functor(C1,F,A),
6610 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6611 copy_term_nat(Pattern-Key,C1-Key1),
6612 copy_term_nat(Pattern-Key,C2-Key2),
6613 Key1 == Key2 ->
6614 passive(RuleNb,ID2)
6615 ;
6616 true
6617 ).
6619 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6620 \+ any_passive_head(RuleNb),
6621 variable_replacement(C1-C2,C2-C1,List),
6622 copy_with_variable_replacement(G,OtherG,List),
6623 negate_b(G,NotG),
6624 once(entails_b(NotG,OtherG)).
6626 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6627 % where C1 and C2 are symmteric constraints
6628 symmetry_analysis(Rules) :-
6629 ( chr_pp_flag(check_unnecessary_active,off) ->
6630 true
6631 ;
6632 symmetry_analysis_main(Rules)
6633 ).
6635 symmetry_analysis_main([]).
6636 symmetry_analysis_main([R|Rs]) :-
6637 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6638 Rule = rule(H1,H2,_,_),
6639 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6640 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6641 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6642 ;
6643 true
6644 ),
6645 symmetry_analysis_main(Rs).
6647 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6648 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6649 ( \+ is_passive(RuleNb,ID),
6650 member2(PreHs,PreIDs,PreH-PreID),
6651 \+ is_passive(RuleNb,PreID),
6652 variable_replacement(PreH,H,List),
6653 copy_with_variable_replacement(Rule,Rule2,List),
6654 identical_guarded_rules(Rule,Rule2) ->
6655 passive(RuleNb,ID)
6656 ;
6657 true
6658 ),
6659 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6661 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6662 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6663 ( \+ is_passive(RuleNb,ID),
6664 member2(PreHs,PreIDs,PreH-PreID),
6665 \+ is_passive(RuleNb,PreID),
6666 variable_replacement(PreH,H,List),
6667 copy_with_variable_replacement(Rule,Rule2,List),
6668 identical_rules(Rule,Rule2) ->
6669 passive(RuleNb,ID)
6670 ;
6671 true
6672 ),
6673 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6675 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6678 %% ____ _ _ _ __ _ _ _
6679 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6680 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6681 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6682 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6683 %% |_|
6684 %% {{{
6686 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6687 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6688 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6689 build_head(F,A,Id,HeadVars,ClauseHead),
6690 get_constraint_mode(F/A,Mode),
6691 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6694 guard_splitting(Rule,GuardList0),
6695 ( is_stored_in_guard(F/A, RuleNb) ->
6696 GuardList = [Hole1|GuardList0]
6697 ;
6698 GuardList = GuardList0
6699 ),
6700 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6702 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6704 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6706 ( is_stored_in_guard(F/A, RuleNb) ->
6707 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6708 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6709 GuardCopyList = [Hole1Copy|_],
6710 Hole1Copy = (Allocation, Attachment)
6711 ;
6712 true
6713 ),
6716 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6717 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6719 ( chr_pp_flag(debugable,on) ->
6720 Rule = rule(_,_,Guard,Body),
6721 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6722 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6723 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6724 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6725 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6726 ;
6727 Cut = ActualCut
6728 ),
6729 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6730 Clause = ( ClauseHead :-
6731 FirstMatching,
6732 RescheduledTest,
6733 Cut,
6734 SuspsDetachments,
6735 SuspDetachment,
6736 BodyCopy
6737 ),
6738 add_location(Clause,RuleNb,LocatedClause),
6739 L = [LocatedClause | T].
6741 % }}}
6743 add_location(Clause,RuleNb,NClause) :-
6744 ( chr_pp_flag(line_numbers,on) ->
6745 get_chr_source_file(File),
6746 get_line_number(RuleNb,LineNb),
6747 NClause = '$source_location'(File,LineNb):Clause
6748 ;
6749 NClause = Clause
6750 ).
6752 add_dummy_location(Clause,NClause) :-
6753 ( chr_pp_flag(line_numbers,on) ->
6754 get_chr_source_file(File),
6755 NClause = '$source_location'(File,1):Clause
6756 ;
6757 NClause = Clause
6758 ).
6759 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6760 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6761 %
6762 % Return goal matching newly introduced variables with variables in
6763 % previously looked-up heads.
6764 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6765 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6766 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6768 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6769 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6771 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6772 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6773 list2conj(GoalList,Goal).
6775 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6776 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6777 ( Mode == (+) ->
6778 term_variables(Arg,GroundVars0,GroundVars),
6779 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6780 ;
6781 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6782 ).
6783 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6784 ( var(Arg) ->
6785 ( lookup_eq(VarDict,Arg,OtherVar) ->
6786 ( Mode = (+) ->
6787 ( memberchk_eq(Arg,GroundVars) ->
6788 GoalList = [Var = OtherVar | RestGoalList],
6789 GroundVars1 = GroundVars
6790 ;
6791 GoalList = [Var == OtherVar | RestGoalList],
6792 GroundVars1 = [Arg|GroundVars]
6793 )
6794 ;
6795 GoalList = [Var == OtherVar | RestGoalList],
6796 GroundVars1 = GroundVars
6797 ),
6798 VarDict1 = VarDict
6799 ;
6800 VarDict1 = [Arg-Var | VarDict],
6801 GoalList = RestGoalList,
6802 ( Mode = (+) ->
6803 GroundVars1 = [Arg|GroundVars]
6804 ;
6805 GroundVars1 = GroundVars
6806 )
6807 ),
6808 Pairs = Rest,
6809 RestModes = Modes
6810 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6811 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6812 GoalList = [Goal|RestGoalList],
6813 VarDict = VarDict1,
6814 GroundVars1 = GroundVars,
6815 Pairs = Rest,
6816 RestModes = Modes
6817 ; atomic(Arg) ->
6818 ( Mode = (+) ->
6819 GoalList = [ Var = Arg | RestGoalList]
6820 ;
6821 GoalList = [ Var == Arg | RestGoalList]
6822 ),
6823 VarDict = VarDict1,
6824 GroundVars1 = GroundVars,
6825 Pairs = Rest,
6826 RestModes = Modes
6827 ; Mode == (+), is_ground(GroundVars,Arg) ->
6828 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6829 GoalList = [ Var = ArgCopy | RestGoalList],
6830 VarDict = VarDict1,
6831 GroundVars1 = GroundVars,
6832 Pairs = Rest,
6833 RestModes = Modes
6834 ; Mode == (?), is_ground(GroundVars,Arg) ->
6835 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6836 GoalList = [ Var == ArgCopy | RestGoalList],
6837 VarDict = VarDict1,
6838 GroundVars1 = GroundVars,
6839 Pairs = Rest,
6840 RestModes = Modes
6841 ; Arg =.. [_|Args],
6842 functor(Arg,Fct,N),
6843 functor(Term,Fct,N),
6844 Term =.. [_|Vars],
6845 ( Mode = (+) ->
6846 GoalList = [ Var = Term | RestGoalList ]
6847 ;
6848 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6849 ),
6850 pairup(Args,Vars,NewPairs),
6851 append(NewPairs,Rest,Pairs),
6852 replicate(N,Mode,NewModes),
6853 append(NewModes,Modes,RestModes),
6854 VarDict1 = VarDict,
6855 GroundVars1 = GroundVars
6856 ),
6857 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6859 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6860 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6861 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6862 add_heads_types([],VarTypes,VarTypes).
6863 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6864 add_head_types(Head,VarTypes,VarTypes1),
6865 add_heads_types(Heads,VarTypes1,NVarTypes).
6867 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6868 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6869 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6870 add_head_types(Head,VarTypes,NVarTypes) :-
6871 functor(Head,F,A),
6872 get_constraint_type_det(F/A,ArgTypes),
6873 Head =.. [_|Args],
6874 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6876 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6877 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6878 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6879 add_args_types([],[],VarTypes,VarTypes).
6880 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6881 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6882 add_args_types(Args,Types,VarTypes1,NVarTypes).
6884 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6885 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6886 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6887 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6888 ( var(Term) ->
6889 ( lookup_eq(VarTypes,Term,_) ->
6890 NVarTypes = VarTypes
6891 ;
6892 NVarTypes = [Term-Type|VarTypes]
6893 )
6894 ; ground(Term) ->
6895 NVarTypes = VarTypes
6896 ; % TODO improve approximation!
6897 term_variables(Term,Vars),
6898 length(Vars,VarNb),
6899 replicate(VarNb,any,Types),
6900 add_args_types(Vars,Types,VarTypes,NVarTypes)
6901 ).
6905 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6906 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6907 %
6908 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6909 add_heads_ground_variables([],GroundVars,GroundVars).
6910 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6911 add_head_ground_variables(Head,GroundVars,GroundVars1),
6912 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6914 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6915 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6916 %
6917 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6918 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6919 functor(Head,F,A),
6920 get_constraint_mode(F/A,ArgModes),
6921 Head =.. [_|Args],
6922 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6925 add_arg_ground_variables([],[],GroundVars,GroundVars).
6926 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6927 ( Mode == (+) ->
6928 term_variables(Arg,Vars),
6929 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6930 ;
6931 GroundVars = GroundVars1
6932 ),
6933 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6935 add_var_ground_variables([],GroundVars,GroundVars).
6936 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6937 ( memberchk_eq(Var,GroundVars) ->
6938 GroundVars1 = GroundVars
6939 ;
6940 GroundVars1 = [Var|GroundVars]
6941 ),
6942 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6943 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6944 %% is_ground(+GroundVars,+Term) is semidet.
6945 %
6946 % Determine whether =Term= is always ground.
6947 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6948 is_ground(GroundVars,Term) :-
6949 ( ground(Term) ->
6950 true
6951 ; compound(Term) ->
6952 Term =.. [_|Args],
6953 maplist(is_ground(GroundVars),Args)
6954 ;
6955 memberchk_eq(Term,GroundVars)
6956 ).
6958 %% check_ground(+GroundVars,+Term,-Goal) is det.
6959 %
6960 % Return runtime check to see whether =Term= is ground.
6961 check_ground(GroundVars,Term,Goal) :-
6962 term_variables(Term,Variables),
6963 check_ground_variables(Variables,GroundVars,Goal).
6965 check_ground_variables([],_,true).
6966 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6967 ( memberchk_eq(Var,GroundVars) ->
6968 check_ground_variables(Vars,GroundVars,Goal)
6969 ;
6970 Goal = (ground(Var), RGoal),
6971 check_ground_variables(Vars,GroundVars,RGoal)
6972 ).
6974 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6975 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6977 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6978 ( Heads = [_|_] ->
6979 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6980 ;
6981 GoalList = [],
6982 Susps = [],
6983 VarDict = NVarDict,
6984 GroundVars = NGroundVars
6985 ).
6987 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6988 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6989 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6990 functor(H,F,A),
6991 head_info(H,A,Vars,_,_,Pairs),
6992 get_store_type(F/A,StoreType),
6993 ( StoreType == default ->
6994 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6995 delay_phase_end(validate_store_type_assumptions,
6996 ( static_suspension_term(F/A,Suspension),
6997 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6998 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6999 )
7000 ),
7001 % create_get_mutable_ref(active,State,GetMutable),
7002 get_constraint_mode(F/A,Mode),
7003 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7004 NPairs = Pairs,
7005 sbag_member_call(Susp,VarSusps,Sbag),
7006 ExistentialLookup = (
7007 ViaGoal,
7008 Sbag,
7009 Susp = Suspension, % not inlined
7010 GetState
7011 )
7012 ;
7013 delay_phase_end(validate_store_type_assumptions,
7014 ( static_suspension_term(F/A,Suspension),
7015 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7016 )
7017 ),
7018 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7019 get_constraint_mode(F/A,Mode),
7020 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7021 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
7022 ),
7023 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7024 filter_append(NPairs,VarDict1,DA_), % order important here
7025 translate(GroundVars1,DA_,GroundVarsA),
7026 translate(GroundVars1,VarDict1,GroundVarsB),
7027 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
7028 Goal =
7029 (
7030 ExistentialLookup,
7031 DiffSuspGoals,
7032 MatchingGoal2
7033 ),
7034 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7036 inline_matching_goal(A==B,true,GVA,GVB) :-
7037 memberchk_eq(A,GVA),
7038 memberchk_eq(B,GVB),
7039 A=B, !.
7041 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7042 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7043 inline_matching_goal(A,A2,GVA,GVB),
7044 inline_matching_goal(B,B2,GVA,GVB).
7045 inline_matching_goal(X,X,_,_).
7048 filter_mode([],_,_,[]).
7049 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7050 ( Var == V ->
7051 Modes = [M|MT],
7052 filter_mode(Rest,R,Ms,MT)
7053 ;
7054 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7055 ).
7057 filter_append([],VarDict,VarDict).
7058 filter_append([X|Xs],VarDict,NVarDict) :-
7059 ( X = silent(_) ->
7060 filter_append(Xs,VarDict,NVarDict)
7061 ;
7062 NVarDict = [X|NVarDict0],
7063 filter_append(Xs,VarDict,NVarDict0)
7064 ).
7066 check_unique_keys([],_).
7067 check_unique_keys([V|Vs],Dict) :-
7068 lookup_eq(Dict,V,_),
7069 check_unique_keys(Vs,Dict).
7071 % Generates tests to ensure the found constraint differs from previously found constraints
7072 % TODO: detect more cases where constraints need be different
7073 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7074 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7075 list2conj(DiffSuspGoalList,DiffSuspGoals).
7077 different_from_other_susps_(_,[],_,_,[]) :- !.
7078 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7079 ( functor(Head,F,A), functor(PreHead,F,A),
7080 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7081 \+ \+ PreHeadCopy = HeadCopy ->
7083 List = [Susp \== PreSusp | Tail]
7084 ;
7085 List = Tail
7086 ),
7087 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7089 % passive_head_via(in,in,in,in,out,out,out) :-
7090 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7091 functor(Head,F,A),
7092 get_constraint_index(F/A,Pos),
7093 /* which static variables may contain runtime variables */
7094 common_variables(Head,PrevHeads,CommonVars0),
7095 ground_vars([Head],GroundVars),
7096 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7097 /********************************************************/
7098 global_list_store_name(F/A,Name),
7099 GlobalGoal = nb_getval(Name,AllSusps),
7100 get_constraint_mode(F/A,ArgModes),
7101 ( Vars == [] ->
7102 Goal = GlobalGoal
7103 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7104 translate([CommonVar],VarDict,[Var]),
7105 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7106 Goal = AttrGoal
7107 ;
7108 translate(CommonVars,VarDict,Vars),
7109 add_heads_types(PrevHeads,[],TypeDict),
7110 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7111 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7112 Goal =
7113 ( ViaGoal ->
7114 AttrGoal
7115 ;
7116 GlobalGoal
7117 )
7118 ).
7120 common_variables(T,Ts,Vs) :-
7121 term_variables(T,V1),
7122 term_variables(Ts,V2),
7123 intersect_eq(V1,V2,Vs).
7125 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7126 via_goal(Vars,TypeDict,ViaGoal,Var),
7127 get_target_module(Mod),
7128 AttrGoal =
7129 ( get_attr(Var,Mod,TSusps),
7130 TSuspsEqSusps % TSusps = Susps
7131 ),
7132 get_max_constraint_index(N),
7133 ( N == 1 ->
7134 TSuspsEqSusps = true, % TSusps = Susps
7135 AllSusps = TSusps
7136 ;
7137 get_constraint_index(FA,Pos),
7138 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7139 ).
7140 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7141 ( Vars = [] ->
7142 ViaGoal = fail
7143 ; Vars = [A] ->
7144 lookup_eq(TypeDict,A,Type),
7145 ( atomic_type(Type) ->
7146 ViaGoal = var(A),
7147 A = Var
7148 ;
7149 ViaGoal = 'chr newvia_1'(A,Var)
7150 )
7151 ; Vars = [A,B] ->
7152 ViaGoal = 'chr newvia_2'(A,B,Var)
7153 ;
7154 ViaGoal = 'chr newvia'(Vars,Var)
7155 ).
7156 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7157 get_target_module(Mod),
7158 AttrGoal =
7159 ( get_attr(Var,Mod,TSusps),
7160 TSuspsEqSusps % TSusps = Susps
7161 ),
7162 get_max_constraint_index(N),
7163 ( N == 1 ->
7164 TSuspsEqSusps = true, % TSusps = Susps
7165 AllSusps = TSusps
7166 ;
7167 get_constraint_index(FA,Pos),
7168 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7169 ).
7171 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7172 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7173 list2conj(GuardCopyList,GuardCopy).
7175 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7176 Rule = rule(_,H,Guard,Body),
7177 conj2list(Guard,GuardList),
7178 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7179 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7181 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7182 term_variables(RestGuardList,GuardVars),
7183 term_variables(RestGuardListCopyCore,GuardCopyVars),
7184 % variables that are declared to be ground don't need to be locked
7185 ground_vars(H,GroundVars),
7186 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7187 ( chr_pp_flag(guard_locks,on),
7188 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7189 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7190 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7191 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7192 ),
7193 LocksUnlocks) ->
7194 once(pairup(Locks,Unlocks,LocksUnlocks))
7195 ;
7196 Locks = [],
7197 Unlocks = []
7198 ),
7199 list2conj(Locks,LockPhase),
7200 list2conj(Unlocks,UnlockPhase),
7201 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7202 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7203 my_term_copy(Body,VarDict2,BodyCopy).
7206 split_off_simple_guard([],_,[],[]).
7207 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7208 ( simple_guard(G,VarDict) ->
7209 S = [G|Ss],
7210 split_off_simple_guard(Gs,VarDict,Ss,C)
7211 ;
7212 S = [],
7213 C = [G|Gs]
7214 ).
7216 % simple guard: cheap and benign (does not bind variables)
7217 simple_guard(G,VarDict) :-
7218 binds_b(G,Vars),
7219 \+ (( member(V,Vars),
7220 lookup_eq(VarDict,V,_)
7221 )).
7223 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7224 functor(Head,F,A),
7225 C = F/A,
7226 ( is_stored(C) ->
7227 (
7228 (
7229 Id == [0], chr_pp_flag(store_in_guards, off)
7230 ;
7231 ( get_allocation_occurrence(C,AO),
7232 get_max_occurrence(C,MO),
7233 MO < AO )
7234 ),
7235 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7236 SuspDetachment = true
7237 ;
7238 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7239 ( chr_pp_flag(late_allocation,on) ->
7240 SuspDetachment =
7241 ( var(Susp) ->
7242 true
7243 ;
7244 UnCondSuspDetachment
7245 )
7246 ;
7247 SuspDetachment = UnCondSuspDetachment
7248 )
7249 )
7250 ;
7251 SuspDetachment = true
7252 ).
7254 partner_constraint_detachments([],[],_,true).
7255 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7256 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7257 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7259 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7260 functor(Head,F,A),
7261 C = F/A,
7262 ( is_stored(C) ->
7263 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7264 ( chr_pp_flag(debugable,on) ->
7265 DebugEvent = 'chr debug_event'(remove(Susp))
7266 ;
7267 DebugEvent = true
7268 ),
7269 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7270 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7271 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7272 detach_constraint_atom(C,Vars,Susp,Detach)
7273 ;
7274 Detach = true
7275 )
7276 ;
7277 SuspDetachment = true
7278 ).
7280 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7282 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7283 %% ____ _ _ _ _
7284 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7285 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7286 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7287 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7288 %% |_| |___/
7289 %% {{{
7291 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7292 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7293 Rule = rule(_Heads,Heads2,Guard,Body),
7295 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7296 get_constraint_mode(F/A,Mode),
7297 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7299 build_head(F,A,Id,HeadVars,ClauseHead),
7301 append(RestHeads,Heads2,Heads),
7302 append(OtherIDs,Heads2IDs,IDs),
7303 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7305 guard_splitting(Rule,GuardList0),
7306 ( is_stored_in_guard(F/A, RuleNb) ->
7307 GuardList = [Hole1|GuardList0]
7308 ;
7309 GuardList = GuardList0
7310 ),
7311 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7313 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7314 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7316 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7318 ( is_stored_in_guard(F/A, RuleNb) ->
7319 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7320 GuardCopyList = [Hole1Copy|_],
7321 Hole1Copy = Attachment
7322 ;
7323 true
7324 ),
7326 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7327 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7328 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7330 ( chr_pp_flag(debugable,on) ->
7331 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7332 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7333 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7334 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7335 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7336 instrument_goal((!),DebugTry,DebugApply,Cut)
7337 ;
7338 Cut = (!)
7339 ),
7341 Clause = ( ClauseHead :-
7342 FirstMatching,
7343 RescheduledTest,
7344 Cut,
7345 SuspsDetachments,
7346 SuspDetachment,
7347 BodyCopy
7348 ),
7349 add_location(Clause,RuleNb,LocatedClause),
7350 L = [LocatedClause | T].
7352 % }}}
7354 split_by_ids([],[],_,[],[]).
7355 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7356 ( memberchk_eq(I,I1s) ->
7357 S1s = [S | R1s],
7358 S2s = R2s
7359 ;
7360 S1s = R1s,
7361 S2s = [S | R2s]
7362 ),
7363 split_by_ids(Is,Ss,I1s,R1s,R2s).
7365 split_by_ids([],[],_,[],[],[],[]).
7366 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7367 ( memberchk_eq(I,I1s) ->
7368 S1s = [S | R1s],
7369 SI1s = [I|RSI1s],
7370 S2s = R2s,
7371 SI2s = RSI2s
7372 ;
7373 S1s = R1s,
7374 SI1s = RSI1s,
7375 S2s = [S | R2s],
7376 SI2s = [I|RSI2s]
7377 ),
7378 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7379 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7382 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7383 %% ____ _ _ _ ____
7384 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7385 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7386 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7387 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7388 %% |_| |___/
7390 %% Genereate prelude + worker predicate
7391 %% prelude calls worker
7392 %% worker iterates over one type of removed constraints
7393 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7394 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7395 Rule = rule(Heads1,_,Guard,Body),
7396 append(Heads1,RestHeads2,Heads),
7397 append(IDs1,RestIDs,IDs),
7398 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7399 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7400 extend_id(Id,Id1),
7401 ( memberchk_eq(NID,IDs2) ->
7402 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7403 ;
7404 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7405 ),
7406 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7407 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7409 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7410 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7411 Heads = [Head|RHeads],
7412 inc_id(Id,Id1),
7413 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7414 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7415 ( memberchk_eq(ID,IDs2) ->
7416 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7417 ;
7418 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7419 ).
7421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7422 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7423 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7424 build_head(F,A,Id1,VarsSusp,ClauseHead),
7425 get_constraint_mode(F/A,Mode),
7426 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7428 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7430 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7432 extend_id(Id1,DelegateId),
7433 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7434 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7435 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7437 PreludeClause =
7438 ( ClauseHead :-
7439 FirstMatching,
7440 ModConstraintsGoal,
7441 !,
7442 ConstraintAllocationGoal,
7443 Delegate
7444 ),
7445 add_dummy_location(PreludeClause,LocatedPreludeClause),
7446 L = [LocatedPreludeClause|T].
7448 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7449 Term =.. [_|Args],
7450 delegate_variables(Term,Terms,VarDict,Args,Vars).
7452 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7453 term_variables(PrevTerms,PrevVars),
7454 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7456 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7457 term_variables(Term,V1),
7458 term_variables(Terms,V2),
7459 intersect_eq(V1,V2,V3),
7460 list_difference_eq(V3,PrevVars,V4),
7461 translate(V4,VarDict,Vars).
7464 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7465 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7466 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7467 Rule = rule(_,_,Guard,Body),
7468 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7470 gen_var(OtherSusp),
7471 gen_var(OtherSusps),
7473 functor(CurrentHead,OtherF,OtherA),
7474 gen_vars(OtherA,OtherVars),
7475 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7476 get_constraint_mode(OtherF/OtherA,Mode),
7477 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7479 delay_phase_end(validate_store_type_assumptions,
7480 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7481 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7482 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7483 )
7484 ),
7485 % create_get_mutable_ref(active,State,GetMutable),
7486 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7487 CurrentSuspTest = (
7488 OtherSusp = OtherSuspension,
7489 GetState,
7490 DiffSuspGoals,
7491 FirstMatching
7492 ),
7494 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7495 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7497 guard_splitting(Rule,GuardList0),
7498 ( is_stored_in_guard(F/A, RuleNb) ->
7499 GuardList = [Hole1|GuardList0]
7500 ;
7501 GuardList = GuardList0
7502 ),
7503 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7505 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7506 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7507 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7509 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7511 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7512 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7513 RecursiveVars2 = [[]|PreVarsAndSusps],
7514 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7516 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7517 ( is_stored_in_guard(F/A, RuleNb) ->
7518 GuardCopyList = [GuardAttachment|_] % once( ) ??
7519 ;
7520 true
7521 ),
7523 ( is_observed(F/A,O) ->
7524 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7525 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7526 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7527 ;
7528 Attachment = true,
7529 ConditionalRecursiveCall = RecursiveCall,
7530 ConditionalRecursiveCall2 = RecursiveCall2
7531 ),
7533 ( chr_pp_flag(debugable,on) ->
7534 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7535 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7536 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7537 ;
7538 DebugTry = true,
7539 DebugApply = true
7540 ),
7542 ( is_stored_in_guard(F/A, RuleNb) ->
7543 GuardAttachment = Attachment,
7544 BodyAttachment = true
7545 ;
7546 GuardAttachment = true,
7547 BodyAttachment = Attachment % will be true if not observed at all
7548 ),
7550 ( member(unique(ID1,UniqueKeys), Pragmas),
7551 check_unique_keys(UniqueKeys,VarDict) ->
7552 Clause =
7553 ( ClauseHead :-
7554 ( CurrentSuspTest ->
7555 ( RescheduledTest,
7556 DebugTry ->
7557 DebugApply,
7558 Susps1Detachments,
7559 BodyAttachment,
7560 BodyCopy,
7561 ConditionalRecursiveCall2
7562 ;
7563 RecursiveCall2
7564 )
7565 ;
7566 RecursiveCall
7567 )
7568 )
7569 ;
7570 Clause =
7571 ( ClauseHead :-
7572 ( CurrentSuspTest,
7573 RescheduledTest,
7574 DebugTry ->
7575 DebugApply,
7576 Susps1Detachments,
7577 BodyAttachment,
7578 BodyCopy,
7579 ConditionalRecursiveCall
7580 ;
7581 RecursiveCall
7582 )
7583 )
7584 ),
7585 add_location(Clause,RuleNb,LocatedClause),
7586 L = [LocatedClause | T].
7588 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7589 ( may_trigger(FA) ->
7590 does_use_field(FA,generation),
7591 delay_phase_end(validate_store_type_assumptions,
7592 ( static_suspension_term(FA,Suspension),
7593 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7594 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7595 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7596 )
7597 )
7598 ;
7599 delay_phase_end(validate_store_type_assumptions,
7600 ( static_suspension_term(FA,Suspension),
7601 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7602 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7603 )
7604 ),
7605 GetGeneration = true
7606 ),
7607 ConditionalCall =
7608 ( Susp = Suspension,
7609 GetState,
7610 GetGeneration ->
7611 UpdateState,
7612 Call
7613 ;
7614 true
7615 ).
7617 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7620 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7621 %% ____ _ _
7622 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7623 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7624 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7625 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7626 %% |_| |___/
7628 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7629 ( RestHeads == [] ->
7630 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7631 ;
7632 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7633 ).
7634 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7635 %% Single headed propagation
7636 %% everything in a single clause
7637 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7638 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7639 build_head(F,A,Id,VarsSusp,ClauseHead),
7641 inc_id(Id,NextId),
7642 build_head(F,A,NextId,VarsSusp,NextHead),
7644 get_constraint_mode(F/A,Mode),
7645 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7646 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7648 % - recursive call -
7649 RecursiveCall = NextHead,
7651 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7652 ActualCut = true
7653 ;
7654 ActualCut = !
7655 ),
7657 Rule = rule(_,_,Guard,Body),
7658 ( chr_pp_flag(debugable,on) ->
7659 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7660 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7661 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7662 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7663 ;
7664 Cut = ActualCut
7665 ),
7666 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7667 use_auxiliary_predicate(novel_production),
7668 use_auxiliary_predicate(extend_history),
7669 does_use_history(F/A,O),
7670 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7672 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7673 ( HistoryIDs == [] ->
7674 empty_named_history_novel_production(HistoryName,NovelProduction),
7675 empty_named_history_extend_history(HistoryName,ExtendHistory)
7676 ;
7677 Tuple = HistoryName
7678 )
7679 ;
7680 Tuple = RuleNb
7681 ),
7683 ( var(NovelProduction) ->
7684 NovelProduction = '$novel_production'(Susp,Tuple),
7685 ExtendHistory = '$extend_history'(Susp,Tuple)
7686 ;
7687 true
7688 ),
7690 ( is_observed(F/A,O) ->
7691 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7692 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7693 ;
7694 Attachment = true,
7695 ConditionalRecursiveCall = RecursiveCall
7696 )
7697 ;
7698 Allocation = true,
7699 NovelProduction = true,
7700 ExtendHistory = true,
7702 ( is_observed(F/A,O) ->
7703 get_allocation_occurrence(F/A,AllocO),
7704 ( O == AllocO ->
7705 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7706 Generation = 0
7707 ; % more room for improvement?
7708 Attachment = (Attachment1, Attachment2),
7709 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7710 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7711 ),
7712 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7713 ;
7714 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7715 ConditionalRecursiveCall = RecursiveCall
7716 )
7717 ),
7719 ( is_stored_in_guard(F/A, RuleNb) ->
7720 GuardAttachment = Attachment,
7721 BodyAttachment = true
7722 ;
7723 GuardAttachment = true,
7724 BodyAttachment = Attachment % will be true if not observed at all
7725 ),
7727 Clause = (
7728 ClauseHead :-
7729 HeadMatching,
7730 Allocation,
7731 NovelProduction,
7732 GuardAttachment,
7733 GuardCopy,
7734 Cut,
7735 ExtendHistory,
7736 BodyAttachment,
7737 BodyCopy,
7738 ConditionalRecursiveCall
7739 ),
7740 add_location(Clause,RuleNb,LocatedClause),
7741 ProgramList = [LocatedClause | ProgramTail].
7743 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7744 %% multi headed propagation
7745 %% prelude + predicates to accumulate the necessary combinations of suspended
7746 %% constraints + predicate to execute the body
7747 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7748 RestHeads = [First|Rest],
7749 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7750 extend_id(Id,ExtendedId),
7751 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7753 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7754 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7755 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7756 build_head(F,A,Id,VarsSusp,PreludeHead),
7757 get_constraint_mode(F/A,Mode),
7758 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7759 Rule = rule(_,_,Guard,Body),
7760 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7762 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7764 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7766 extend_id(Id,NestedId),
7767 append([Susps|VarsSusp],ExtraVars,NestedVars),
7768 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7769 NestedCall = NestedHead,
7771 Prelude = (
7772 PreludeHead :-
7773 FirstMatching,
7774 FirstSuspGoal,
7775 !,
7776 CondAllocation,
7777 NestedCall
7778 ),
7779 add_dummy_location(Prelude,LocatedPrelude),
7780 L = [LocatedPrelude|T].
7782 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7783 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7784 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7785 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7787 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7788 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7789 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7790 inc_id(Id,IncId),
7791 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7793 %check_fd_lookup_condition(_,_,_,_) :- fail.
7794 check_fd_lookup_condition(F,A,_,_) :-
7795 get_store_type(F/A,global_singleton), !.
7796 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7797 \+ may_trigger(F/A),
7798 get_functional_dependency(F/A,1,P,K),
7799 copy_term(P-K,CurrentHead-Key),
7800 term_variables(PreHeads,PreVars),
7801 intersect_eq(Key,PreVars,Key),!.
7803 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7804 Rule = rule(_,H2,Guard,Body),
7805 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7806 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7807 init(AllSusps,RestSusps),
7808 last(AllSusps,Susp),
7809 gen_var(OtherSusp),
7810 gen_var(OtherSusps),
7811 functor(CurrentHead,OtherF,OtherA),
7812 gen_vars(OtherA,OtherVars),
7813 delay_phase_end(validate_store_type_assumptions,
7814 ( static_suspension_term(OtherF/OtherA,Suspension),
7815 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7816 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7817 )
7818 ),
7819 % create_get_mutable_ref(active,State,GetMutable),
7820 CurrentSuspTest = (
7821 OtherSusp = Suspension,
7822 GetState
7823 ),
7824 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7825 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7826 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7827 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7828 RecursiveVars = PreVarsAndSusps1
7829 ;
7830 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7831 PrevId0 = Id
7832 ),
7833 ( PrevId0 = [_] ->
7834 PrevId = PrevId0
7835 ;
7836 PrevId = [O|PrevId0]
7837 ),
7838 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7839 RecursiveCall = RecursiveHead,
7840 CurrentHead =.. [_|OtherArgs],
7841 pairup(OtherArgs,OtherVars,OtherPairs),
7842 get_constraint_mode(OtherF/OtherA,Mode),
7843 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7845 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7846 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7847 get_occurrence(F/A,O,_,ID),
7849 ( is_observed(F/A,O) ->
7850 init(FirstVarsSusp,FirstVars),
7851 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7852 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7853 ;
7854 Attachment = true,
7855 ConditionalRecursiveCall = RecursiveCall
7856 ),
7857 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7858 NovelProduction = true,
7859 ExtendHistory = true
7860 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7861 NovelProduction = true,
7862 ExtendHistory = true
7863 ;
7864 get_occurrence(F/A,O,_,ID),
7865 use_auxiliary_predicate(novel_production),
7866 use_auxiliary_predicate(extend_history),
7867 does_use_history(F/A,O),
7868 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7869 ( HistoryIDs == [] ->
7870 empty_named_history_novel_production(HistoryName,NovelProduction),
7871 empty_named_history_extend_history(HistoryName,ExtendHistory)
7872 ;
7873 reverse([OtherSusp|RestSusps],NamedSusps),
7874 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7875 HistorySusps = [HistorySusp|_],
7877 ( length(HistoryIDs, 1) ->
7878 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7879 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7880 ;
7881 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7882 Tuple =.. [t,HistoryName|HistorySusps]
7883 )
7884 )
7885 ;
7886 HistorySusp = Susp,
7887 maplist(extract_symbol,H2,ConstraintSymbols),
7888 sort([ID|RestIDs],HistoryIDs),
7889 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7890 Tuple =.. [t,RuleNb|HistorySusps]
7891 ),
7893 ( var(NovelProduction) ->
7894 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7895 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7896 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7897 ;
7898 true
7899 )
7900 ),
7903 ( chr_pp_flag(debugable,on) ->
7904 Rule = rule(_,_,Guard,Body),
7905 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7906 get_occurrence(F/A,O,_,ID),
7907 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7908 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7909 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7910 ;
7911 DebugTry = true,
7912 DebugApply = true
7913 ),
7915 ( is_stored_in_guard(F/A, RuleNb) ->
7916 GuardAttachment = Attachment,
7917 BodyAttachment = true
7918 ;
7919 GuardAttachment = true,
7920 BodyAttachment = Attachment % will be true if not observed at all
7921 ),
7923 Clause = (
7924 ClauseHead :-
7925 ( CurrentSuspTest,
7926 DiffSuspGoals,
7927 Matching,
7928 NovelProduction,
7929 GuardAttachment,
7930 GuardCopy,
7931 DebugTry ->
7932 DebugApply,
7933 ExtendHistory,
7934 BodyAttachment,
7935 BodyCopy,
7936 ConditionalRecursiveCall
7937 ; RecursiveCall
7938 )
7939 ),
7940 add_location(Clause,RuleNb,LocatedClause),
7941 L = [LocatedClause|T].
7943 extract_symbol(Head,F/A) :-
7944 functor(Head,F,A).
7946 novel_production_calls([],[],[],_,_,true).
7947 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7948 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7949 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7950 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7952 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7953 reverse(ReversedRestSusps,RestSusps),
7954 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7956 named_history_susps([],_,_,[]).
7957 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7958 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7959 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7963 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7964 !,
7965 functor(Head,F,A),
7966 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7967 get_constraint_mode(F/A,Mode),
7968 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7969 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7970 append(VarsSusp,ExtraVars,HeadVars).
7971 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7972 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7973 functor(Head,F,A),
7974 gen_var(Susps),
7975 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7976 get_constraint_mode(F/A,Mode),
7977 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7978 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7979 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7981 % returns
7982 % VarDict for the copies of variables in the original heads
7983 % VarsSuspsList list of lists of arguments for the successive heads
7984 % FirstVarsSusp top level arguments
7985 % SuspList list of all suspensions
7986 % Iterators list of all iterators
7987 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7988 !,
7989 functor(Head,F,A),
7990 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7991 get_constraint_mode(F/A,Mode),
7992 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7993 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7994 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7995 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7996 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7997 functor(Head,F,A),
7998 gen_var(Susps),
7999 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8000 get_constraint_mode(F/A,Mode),
8001 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8002 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8003 append(HeadVars,[Susp,Susps],Vars).
8005 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8006 !,
8007 functor(Head,F,A),
8008 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8009 get_constraint_mode(F/A,Mode),
8010 head_arg_matches(Pairs,Mode,[],_,VarDict),
8011 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8012 append(VarsSusp,ExtraVars,HeadVars).
8013 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8014 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8015 functor(Head,F,A),
8016 gen_var(Susps),
8017 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8018 get_constraint_mode(F/A,Mode),
8019 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8020 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8021 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8023 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8025 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8026 %% ____ _ _ _ _
8027 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8028 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8029 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8030 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8031 %%
8032 %% ____ _ _ _
8033 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8034 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8035 %% | _ < __/ |_| | | | __/\ V / (_| | |
8036 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8037 %%
8038 %% ____ _ _
8039 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8040 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8041 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8042 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8043 %% |___/
8045 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8046 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8047 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8048 ;
8049 NRestHeads = RestHeads,
8050 NRestIDs = RestIDs
8051 ).
8053 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8054 term_variables(Head,Vars),
8055 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8056 copy_term_nat(InitialData,InitialDataCopy),
8057 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8058 InitialDataCopy = InitialData,
8059 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8060 reverse(RNRestHeads,NRestHeads),
8061 reverse(RNRestIDs,NRestIDs).
8063 final_data(Entry) :-
8064 Entry = entry(_,_,_,_,[],_).
8066 expand_data(Entry,NEntry,Cost) :-
8067 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8068 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8069 term_variables([Head1|Vars],Vars1),
8070 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8071 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8073 % Assigns score to head based on known variables and heads to lookup
8074 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8075 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8076 functor(Head,F,A),
8077 get_store_type(F/A,StoreType),
8078 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8079 % }}}
8081 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8082 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8083 term_variables(Head,HeadVars0),
8084 term_variables(RestHeads,RestVars),
8085 ground_vars([Head],GroundVars),
8086 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8087 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8088 NScore is min(CScore,Score).
8089 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8090 ( CScore =< 100 ->
8091 Score = CScore
8092 ;
8093 order_score_indexes(Indexes,Head,KnownVars,Score)
8094 ).
8095 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8096 ( CScore =< 100 ->
8097 Score = CScore
8098 ;
8099 order_score_indexes(Indexes,Head,KnownVars,Score)
8100 ).
8101 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8102 term_variables(Head,HeadVars),
8103 term_variables(RestHeads,RestVars),
8104 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8105 Score is Score_ * 200,
8106 NScore is min(CScore,Score).
8107 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8108 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8109 Score = 1. % guaranteed O(1)
8110 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8111 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8112 multi_order_score([],_,_,_,_,_,Score,Score).
8113 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8114 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8115 ; Score1 = Score0
8116 ),
8117 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8119 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8120 Score is min(CScore,10).
8121 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8122 Score is min(CScore,10).
8123 % }}}
8126 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8127 order_score_indexes(Indexes,Head,Vars,Score) :-
8128 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8129 numbervars(VarsCopy,0,_),
8130 order_score_indexes(Indexes,HeadCopy,Score).
8132 order_score_indexes([I|Is],Head,Score) :-
8133 args(I,Head,Args),
8134 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8135 Score = 100
8136 ;
8137 order_score_indexes(Is,Head,Score)
8138 ).
8139 % }}}
8141 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8143 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8144 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8145 ( K-R-O == 0-0-0 ->
8146 Score = 0
8147 ; K > 0 ->
8148 Score is max(10 - K,0)
8149 ; R > 0 ->
8150 Score is max(10 - R,1) * 100
8151 ;
8152 Score is max(10-O,1) * 1000
8153 ).
8154 order_score_count_vars([],_,_,0-0-0).
8155 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8156 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8157 ( memberchk_eq(V,KnownVars) ->
8158 NK is K + 1,
8159 NR = R, NO = O
8160 ; memberchk_eq(V,RestVars) ->
8161 NR is R + 1,
8162 NK = K, NO = O
8163 ;
8164 NO is O + 1,
8165 NK = K, NR = R
8166 ).
8168 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8169 %% ___ _ _ _
8170 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8171 %% | || '_ \| | | '_ \| | '_ \ / _` |
8172 %% | || | | | | | | | | | | | | (_| |
8173 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8174 %% |___/
8176 %% SWI begin
8177 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8178 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8179 %% SWI end
8181 %% SICStus begin
8182 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8183 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8184 %% SICStus end
8186 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8188 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8189 %% _ _ _ _ _ _ _
8190 %% | | | | |_(_) (_) |_ _ _
8191 %% | | | | __| | | | __| | | |
8192 %% | |_| | |_| | | | |_| |_| |
8193 %% \___/ \__|_|_|_|\__|\__, |
8194 %% |___/
8196 % Create a fresh variable.
8197 gen_var(_).
8199 % Create =N= fresh variables.
8200 gen_vars(N,Xs) :-
8201 length(Xs,N).
8203 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8204 vars_susp(A,Vars,Susp,VarsSusp),
8205 Head =.. [_|Args],
8206 pairup(Args,Vars,HeadPairs).
8208 inc_id([N|Ns],[O|Ns]) :-
8209 O is N + 1.
8210 dec_id([N|Ns],[M|Ns]) :-
8211 M is N - 1.
8213 extend_id(Id,[0|Id]).
8215 next_id([_,N|Ns],[O|Ns]) :-
8216 O is N + 1.
8218 % return clause Head
8219 % for F/A constraint symbol, predicate identifier Id and arguments Head
8220 build_head(F,A,Id,Args,Head) :-
8221 buildName(F,A,Id,Name),
8222 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8223 ( may_trigger(F/A) ;
8224 get_allocation_occurrence(F/A,AO),
8225 get_max_occurrence(F/A,MO),
8226 MO >= AO ) ) ->
8227 Head =.. [Name|Args]
8228 ;
8229 init(Args,ArgsWOSusp), % XXX not entirely correct!
8230 Head =.. [Name|ArgsWOSusp]
8231 ).
8233 % return predicate name Result
8234 % for Fct/Aty constraint symbol and predicate identifier List
8235 buildName(Fct,Aty,List,Result) :-
8236 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8237 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8238 MO >= AO ) ; List \= [0])) ) ) ->
8239 atom_concat(Fct, '___' ,FctSlash),
8240 atomic_concat(FctSlash,Aty,FctSlashAty),
8241 buildName_(List,FctSlashAty,Result)
8242 ;
8243 Result = Fct
8244 ).
8246 buildName_([],Name,Name).
8247 buildName_([N|Ns],Name,Result) :-
8248 buildName_(Ns,Name,Name1),
8249 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8250 atomic_concat(NameDash,N,Result).
8252 vars_susp(A,Vars,Susp,VarsSusp) :-
8253 length(Vars,A),
8254 append(Vars,[Susp],VarsSusp).
8256 or_pattern(Pos,Pat) :-
8257 Pow is Pos - 1,
8258 Pat is 1 << Pow. % was 2 ** X
8260 and_pattern(Pos,Pat) :-
8261 X is Pos - 1,
8262 Y is 1 << X, % was 2 ** X
8263 Pat is (-1)*(Y + 1).
8265 make_name(Prefix,F/A,Name) :-
8266 atom_concat_list([Prefix,F,'___',A],Name).
8268 %===============================================================================
8269 % Attribute for attributed variables
8271 make_attr(N,Mask,SuspsList,Attr) :-
8272 length(SuspsList,N),
8273 Attr =.. [v,Mask|SuspsList].
8275 get_all_suspensions2(N,Attr,SuspensionsList) :-
8276 chr_pp_flag(dynattr,off), !,
8277 make_attr(N,_,SuspensionsList,Attr).
8279 % NEW
8280 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8281 % writeln(get_all_suspensions2),
8282 length(SuspensionsList,N),
8283 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8286 % NEW
8287 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8288 % writeln(normalize_attr),
8289 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8291 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8292 chr_pp_flag(dynattr,off), !,
8293 make_attr(N,_,SuspsList,Attr),
8294 nth1(Position,SuspsList,Suspensions).
8296 % NEW
8297 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8298 % writeln(get_suspensions),
8299 Goal =
8300 ( memberchk(Position-Suspensions,TAttr) ->
8301 true
8302 ;
8303 Suspensions = []
8304 ).
8306 %-------------------------------------------------------------------------------
8307 % +N: number of constraint symbols
8308 % +Suspension: source-level variable, for suspension
8309 % +Position: constraint symbol number
8310 % -Attr: source-level term, for new attribute
8311 singleton_attr(N,Suspension,Position,Attr) :-
8312 chr_pp_flag(dynattr,off), !,
8313 or_pattern(Position,Pattern),
8314 make_attr(N,Pattern,SuspsList,Attr),
8315 nth1(Position,SuspsList,[Suspension]),
8316 chr_delete(SuspsList,[Suspension],RestSuspsList),
8317 set_elems(RestSuspsList,[]).
8319 % NEW
8320 singleton_attr(N,Suspension,Position,Attr) :-
8321 % writeln(singleton_attr),
8322 Attr = [Position-[Suspension]].
8324 %-------------------------------------------------------------------------------
8325 % +N: number of constraint symbols
8326 % +Suspension: source-level variable, for suspension
8327 % +Position: constraint symbol number
8328 % +TAttr: source-level variable, for old attribute
8329 % -Goal: goal for creating new attribute
8330 % -NTAttr: source-level variable, for new attribute
8331 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8332 chr_pp_flag(dynattr,off), !,
8333 make_attr(N,Mask,SuspsList,Attr),
8334 or_pattern(Position,Pattern),
8335 nth1(Position,SuspsList,Susps),
8336 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8337 make_attr(N,Mask,SuspsList1,NewAttr1),
8338 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8339 make_attr(N,NewMask,SuspsList2,NewAttr2),
8340 Goal = (
8341 TAttr = Attr,
8342 ( Mask /\ Pattern =:= Pattern ->
8343 NTAttr = NewAttr1
8344 ;
8345 NewMask is Mask \/ Pattern,
8346 NTAttr = NewAttr2
8347 )
8348 ), !.
8350 % NEW
8351 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8352 % writeln(add_attr),
8353 Goal =
8354 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8355 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8356 ;
8357 NTAttr = [Position-[Suspension]|TAttr]
8358 ).
8360 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8361 chr_pp_flag(dynattr,off), !,
8362 or_pattern(Position,Pattern),
8363 and_pattern(Position,DelPattern),
8364 make_attr(N,Mask,SuspsList,Attr),
8365 nth1(Position,SuspsList,Susps),
8366 substitute_eq(Susps,SuspsList,[],SuspsList1),
8367 make_attr(N,NewMask,SuspsList1,Attr1),
8368 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8369 make_attr(N,Mask,SuspsList2,Attr2),
8370 get_target_module(Mod),
8371 Goal = (
8372 TAttr = Attr,
8373 ( Mask /\ Pattern =:= Pattern ->
8374 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8375 ( NewSusps == [] ->
8376 NewMask is Mask /\ DelPattern,
8377 ( NewMask == 0 ->
8378 del_attr(Var,Mod)
8379 ;
8380 put_attr(Var,Mod,Attr1)
8381 )
8382 ;
8383 put_attr(Var,Mod,Attr2)
8384 )
8385 ;
8386 true
8387 )
8388 ), !.
8390 % NEW
8391 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8392 % writeln(rem_attr),
8393 get_target_module(Mod),
8394 Goal =
8395 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8396 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8397 ( NSuspensions == [] ->
8398 ( RAttr == [] ->
8399 del_attr(Var,Mod)
8400 ;
8401 put_attr(Var,Mod,RAttr)
8402 )
8403 ;
8404 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8405 )
8406 ;
8407 true
8408 ).
8410 %-------------------------------------------------------------------------------
8411 % +N: number of constraint symbols
8412 % +TAttr1: source-level variable, for attribute
8413 % +TAttr2: source-level variable, for other attribute
8414 % -Goal: goal for merging the two attributes
8415 % -Attr: source-level term, for merged attribute
8416 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8417 chr_pp_flag(dynattr,off), !,
8418 make_attr(N,Mask1,SuspsList1,Attr1),
8419 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8420 Goal = (
8421 TAttr1 = Attr1,
8422 Goal2
8423 ).
8425 % NEW
8426 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8427 % writeln(merge_attributes),
8428 Goal = (
8429 sort(TAttr1,Sorted1),
8430 sort(TAttr2,Sorted2),
8431 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8432 ).
8435 %-------------------------------------------------------------------------------
8436 % +N: number of constraint symbols
8437 % +Mask1: ...
8438 % +SuspsList1: static term, for suspensions list
8439 % +TAttr2: source-level variable, for other attribute
8440 % -Goal: goal for merging the two attributes
8441 % -Attr: source-level term, for merged attribute
8442 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8443 make_attr(N,Mask2,SuspsList2,Attr2),
8444 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8445 list2conj(Gs,SortGoals),
8446 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8447 make_attr(N,Mask,SuspsList,Attr),
8448 Goal = (
8449 TAttr2 = Attr2,
8450 SortGoals,
8451 Mask is Mask1 \/ Mask2
8452 ).
8455 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8456 % Storetype dependent lookup
8458 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8459 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8460 %% -Goal,-SuspensionList) is det.
8461 %
8462 % Create a universal lookup goal for given head.
8463 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8464 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8465 functor(Head,F,A),
8466 get_store_type(F/A,StoreType),
8467 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8469 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8470 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8471 %% -Goal,-SuspensionList) is det.
8472 %
8473 % Create a universal lookup goal for given head.
8474 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8475 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8476 functor(Head,F,A),
8477 get_store_type(F/A,StoreType),
8478 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8480 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8481 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8482 %% +GroundVars,-Goal,-SuspensionList) is det.
8483 %
8484 % Create a universal lookup goal for given head.
8485 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8486 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8487 functor(Head,F,A),
8488 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8489 update_store_type(F/A,default).
8490 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8491 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8492 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8493 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8494 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8495 functor(Head,F,A),
8496 global_ground_store_name(F/A,StoreName),
8497 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8498 update_store_type(F/A,global_ground).
8499 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8500 arg(VarIndex,Head,OVar),
8501 arg(KeyIndex,Head,OKey),
8502 translate([OVar,OKey],VarDict,[Var,Key]),
8503 get_target_module(Module),
8504 Goal = (
8505 get_attr(Var,Module,AssocStore),
8506 lookup_assoc_store(AssocStore,Key,AllSusps)
8507 ).
8508 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8509 functor(Head,F,A),
8510 global_singleton_store_name(F/A,StoreName),
8511 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8512 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8513 update_store_type(F/A,global_singleton).
8514 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8515 once((
8516 member(ST,StoreTypes),
8517 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8518 )).
8519 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8520 functor(Head,F,A),
8521 arg(Index,Head,Var),
8522 translate([Var],VarDict,[KeyVar]),
8523 delay_phase_end(validate_store_type_assumptions,
8524 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8525 ),
8526 update_store_type(F/A,identifier_store(Index)),
8527 get_identifier_index(F/A,Index,_).
8528 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8529 functor(Head,F,A),
8530 arg(Index,Head,Var),
8531 ( var(Var) ->
8532 translate([Var],VarDict,[KeyVar]),
8533 Goal = StructGoal
8534 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8535 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8536 Goal = (LookupGoal,StructGoal)
8537 ),
8538 delay_phase_end(validate_store_type_assumptions,
8539 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8540 ),
8541 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8542 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8544 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8545 get_identifier_size(ISize),
8546 functor(Struct,struct,ISize),
8547 get_identifier_index(C,Index,IIndex),
8548 arg(IIndex,Struct,AllSusps),
8549 Goal = (KeyVar = Struct).
8551 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8552 type_indexed_identifier_structure(IndexType,Struct),
8553 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8554 arg(IIndex,Struct,AllSusps),
8555 Goal = (KeyVar = Struct).
8557 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8558 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8559 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8560 %
8561 % Create a universal hash lookup goal for given head.
8562 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8563 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8564 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8565 ( KeyArgCopies = [KeyCopy] ->
8566 true
8567 ;
8568 KeyCopy =.. [k|KeyArgCopies]
8569 ),
8570 functor(Head,F,A),
8571 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8573 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8574 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8576 Goal = (GroundCheck,LookupGoal),
8578 ( HashType == inthash ->
8579 update_store_type(F/A,multi_inthash([Index]))
8580 ;
8581 update_store_type(F/A,multi_hash([Index]))
8582 ).
8584 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8585 member(Index,Indexes),
8586 args(Index,Head,KeyArgs),
8587 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8588 !.
8590 % check whether we can copy the given terms
8591 % with the given dictionary, and, if so, do so
8592 key_in_scope([],VarDict,[]).
8593 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8594 term_variables(Arg,Vars),
8595 translate(Vars,VarDict,VarCopies),
8596 copy_term(Arg/Vars,ArgCopy/VarCopies),
8597 key_in_scope(Args,VarDict,ArgCopies).
8599 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8600 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8601 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8602 %% +VarArgDict,-NewVarArgDict) is det.
8603 %
8604 % Create existential lookup goal for given head.
8605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8606 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8607 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8608 sbag_member_call(Susp,AllSusps,Sbag),
8609 functor(Head,F,A),
8610 delay_phase_end(validate_store_type_assumptions,
8611 ( static_suspension_term(F/A,SuspTerm),
8612 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8613 )
8614 ),
8615 Goal = (
8616 UniversalGoal,
8617 Sbag,
8618 Susp = SuspTerm,
8619 GetState
8620 ).
8621 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8622 functor(Head,F,A),
8623 global_singleton_store_name(F/A,StoreName),
8624 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8625 Goal = (
8626 GetStoreGoal, % nb_getval(StoreName,Susp),
8627 Susp \== [],
8628 Susp = SuspTerm
8629 ),
8630 update_store_type(F/A,global_singleton).
8631 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8632 once((
8633 member(ST,StoreTypes),
8634 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8635 )).
8636 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8637 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8638 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8639 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8640 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8641 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8642 hash_index_filter(Pairs,Index,NPairs),
8644 functor(Head,F,A),
8645 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8646 Sbag = (AllSusps = [Susp])
8647 ;
8648 sbag_member_call(Susp,AllSusps,Sbag)
8649 ),
8650 delay_phase_end(validate_store_type_assumptions,
8651 ( static_suspension_term(F/A,SuspTerm),
8652 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8653 )
8654 ),
8655 Goal = (
8656 LookupGoal,
8657 Sbag,
8658 Susp = SuspTerm, % not inlined
8659 GetState
8660 ).
8661 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8662 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8663 hash_index_filter(Pairs,Index,NPairs),
8665 functor(Head,F,A),
8666 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8667 Sbag = (AllSusps = [Susp])
8668 ;
8669 sbag_member_call(Susp,AllSusps,Sbag)
8670 ),
8671 delay_phase_end(validate_store_type_assumptions,
8672 ( static_suspension_term(F/A,SuspTerm),
8673 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8674 )
8675 ),
8676 Goal = (
8677 LookupGoal,
8678 Sbag,
8679 Susp = SuspTerm, % not inlined
8680 GetState
8681 ).
8682 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8683 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8684 sbag_member_call(Susp,Susps,Sbag),
8685 functor(Head,F,A),
8686 delay_phase_end(validate_store_type_assumptions,
8687 ( static_suspension_term(F/A,SuspTerm),
8688 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8689 )
8690 ),
8691 Goal = (
8692 UGoal,
8693 Sbag,
8694 Susp = SuspTerm, % not inlined
8695 GetState
8696 ).
8698 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8699 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8700 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8701 %% +VarArgDict,-NewVarArgDict) is det.
8702 %
8703 % Create existential hash lookup goal for given head.
8704 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8705 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8706 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8708 hash_index_filter(Pairs,Index,NPairs),
8710 functor(Head,F,A),
8711 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8712 Sbag = (AllSusps = [Susp])
8713 ;
8714 sbag_member_call(Susp,AllSusps,Sbag)
8715 ),
8716 delay_phase_end(validate_store_type_assumptions,
8717 ( static_suspension_term(F/A,SuspTerm),
8718 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8719 )
8720 ),
8721 Goal = (
8722 LookupGoal,
8723 Sbag,
8724 Susp = SuspTerm, % not inlined
8725 GetState
8726 ).
8728 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8729 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8730 %
8731 % Filter out pairs already covered by given hash index.
8732 % makes them 'silent'
8733 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8734 hash_index_filter(Pairs,Index,NPairs) :-
8735 hash_index_filter(Pairs,Index,1,NPairs).
8737 hash_index_filter([],_,_,[]).
8738 hash_index_filter([P|Ps],Index,N,NPairs) :-
8739 ( Index = [I|Is] ->
8740 NN is N + 1,
8741 ( I > N ->
8742 NPairs = [P|NPs],
8743 hash_index_filter(Ps,[I|Is],NN,NPs)
8744 ; I == N ->
8745 NPairs = [silent(P)|NPs],
8746 hash_index_filter(Ps,Is,NN,NPs)
8747 )
8748 ;
8749 NPairs = [P|Ps]
8750 ).
8752 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8753 %------------------------------------------------------------------------------%
8754 %% assume_constraint_stores(+ConstraintSymbols) is det.
8755 %
8756 % Compute all constraint store types that are possible for the given
8757 % =ConstraintSymbols=.
8758 %------------------------------------------------------------------------------%
8759 assume_constraint_stores([]).
8760 assume_constraint_stores([C|Cs]) :-
8761 ( chr_pp_flag(debugable,off),
8762 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8763 is_stored(C),
8764 get_store_type(C,default) ->
8765 get_indexed_arguments(C,AllIndexedArgs),
8766 get_constraint_mode(C,Modes),
8767 aggregate_all(bag(Index)-count,
8768 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8769 IndexedArgs-NbIndexedArgs),
8770 % Construct Index Combinations
8771 ( NbIndexedArgs > 10 ->
8772 findall([Index],member(Index,IndexedArgs),Indexes)
8773 ;
8774 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8775 predsort(longer_list,UnsortedIndexes,Indexes)
8776 ),
8777 % EXPERIMENTAL HEURISTIC
8778 % findall(Index, (
8779 % member(Arg1,IndexedArgs),
8780 % member(Arg2,IndexedArgs),
8781 % Arg1 =< Arg2,
8782 % sort([Arg1,Arg2], Index)
8783 % ), UnsortedIndexes),
8784 % predsort(longer_list,UnsortedIndexes,Indexes),
8785 % Choose Index Type
8786 ( get_functional_dependency(C,1,Pattern,Key),
8787 all_distinct_var_args(Pattern), Key == [] ->
8788 assumed_store_type(C,global_singleton)
8789 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8790 get_constraint_type_det(C,ArgTypes),
8791 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8793 ( IntHashIndexes = [] ->
8794 Stores = Stores1
8795 ;
8796 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8797 ),
8798 ( HashIndexes = [] ->
8799 Stores1 = Stores2
8800 ;
8801 Stores1 = [multi_hash(HashIndexes)|Stores2]
8802 ),
8803 ( IdentifierIndexes = [] ->
8804 Stores2 = Stores3
8805 ;
8806 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8807 append(WrappedIdentifierIndexes,Stores3,Stores2)
8808 ),
8809 append(CompoundIdentifierIndexes,Stores4,Stores3),
8810 ( only_ground_indexed_arguments(C)
8811 -> Stores4 = [global_ground]
8812 ; Stores4 = [default]
8813 ),
8814 assumed_store_type(C,multi_store(Stores))
8815 ; true
8816 )
8817 ;
8818 true
8819 ),
8820 assume_constraint_stores(Cs).
8822 %------------------------------------------------------------------------------%
8823 %% partition_indexes(+Indexes,+Types,
8824 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8825 %------------------------------------------------------------------------------%
8826 partition_indexes([],_,[],[],[],[]).
8827 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8828 ( Index = [I],
8829 nth1(I,Types,Type),
8830 unalias_type(Type,UnAliasedType),
8831 UnAliasedType == chr_identifier ->
8832 IdentifierIndexes = [I|RIdentifierIndexes],
8833 IntHashIndexes = RIntHashIndexes,
8834 HashIndexes = RHashIndexes,
8835 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8836 ; Index = [I],
8837 nth1(I,Types,Type),
8838 unalias_type(Type,UnAliasedType),
8839 nonvar(UnAliasedType),
8840 UnAliasedType = chr_identifier(IndexType) ->
8841 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8842 IdentifierIndexes = RIdentifierIndexes,
8843 IntHashIndexes = RIntHashIndexes,
8844 HashIndexes = RHashIndexes
8845 ; Index = [I],
8846 nth1(I,Types,Type),
8847 unalias_type(Type,UnAliasedType),
8848 UnAliasedType == dense_int ->
8849 IntHashIndexes = [Index|RIntHashIndexes],
8850 HashIndexes = RHashIndexes,
8851 IdentifierIndexes = RIdentifierIndexes,
8852 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8853 ; member(I,Index),
8854 nth1(I,Types,Type),
8855 unalias_type(Type,UnAliasedType),
8856 nonvar(UnAliasedType),
8857 UnAliasedType = chr_identifier(_) ->
8858 % don't use chr_identifiers in hash indexes
8859 IntHashIndexes = RIntHashIndexes,
8860 HashIndexes = RHashIndexes,
8861 IdentifierIndexes = RIdentifierIndexes,
8862 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8863 ;
8864 IntHashIndexes = RIntHashIndexes,
8865 HashIndexes = [Index|RHashIndexes],
8866 IdentifierIndexes = RIdentifierIndexes,
8867 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8868 ),
8869 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8871 longer_list(R,L1,L2) :-
8872 length(L1,N1),
8873 length(L2,N2),
8874 compare(Rt,N2,N1),
8875 ( Rt == (=) ->
8876 compare(R,L1,L2)
8877 ;
8878 R = Rt
8879 ).
8881 all_distinct_var_args(Term) :-
8882 copy_term_nat(Term,TermCopy),
8883 functor(Term,F,A),
8884 functor(Pattern,F,A),
8885 Pattern =@= TermCopy.
8887 get_indexed_arguments(C,IndexedArgs) :-
8888 C = F/A,
8889 get_indexed_arguments(1,A,C,IndexedArgs).
8891 get_indexed_arguments(I,N,C,L) :-
8892 ( I > N ->
8893 L = []
8894 ; ( is_indexed_argument(C,I) ->
8895 L = [I|T]
8896 ;
8897 L = T
8898 ),
8899 J is I + 1,
8900 get_indexed_arguments(J,N,C,T)
8901 ).
8903 validate_store_type_assumptions([]).
8904 validate_store_type_assumptions([C|Cs]) :-
8905 validate_store_type_assumption(C),
8906 validate_store_type_assumptions(Cs).
8908 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8909 % new code generation
8910 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8911 Rule = rule(H1,_,Guard,Body),
8912 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8913 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8914 flatten(VarsAndSuspsList,VarsAndSusps),
8915 Vars = [ [] | VarsAndSusps],
8916 build_head(F,A,[O|Id],Vars,Head),
8917 ( PrevId0 = [_] ->
8918 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8919 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8920 PrevId = [PredictedPrevId] % PrevId = PrevId0
8921 ;
8922 PrevId = [O|PrevId0]
8923 ),
8924 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8925 Clause = ( Head :- PredecessorCall),
8926 add_dummy_location(Clause,LocatedClause),
8927 L = [LocatedClause | T].
8928 % ( H1 == [],
8929 % functor(CurrentHead,CF,CA),
8930 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8931 % L = T
8932 % ;
8933 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8934 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8935 % flatten(VarsAndSuspsList,VarsAndSusps),
8936 % Vars = [ [] | VarsAndSusps],
8937 % build_head(F,A,Id,Vars,Head),
8938 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8939 % Clause = ( Head :- PredecessorCall),
8940 % L = [Clause | T]
8941 % ).
8943 % skips back intelligently over global_singleton lookups
8944 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8945 ( Id = [0|_] ->
8946 % TOM: add partial success continuation optimization here!
8947 next_id(Id,PrevId),
8948 PrevVarsAndSusps = BaseCallArgs
8949 ;
8950 VarsAndSuspsList = [_|AllButFirstList],
8951 dec_id(Id,PrevId1),
8952 ( PrevHeads = [PrevHead|PrevHeads1],
8953 functor(PrevHead,F,A),
8954 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8955 PrevIterators = [_|PrevIterators1],
8956 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8957 ;
8958 PrevId = PrevId1,
8959 flatten(AllButFirstList,AllButFirst),
8960 PrevIterators = [PrevIterator|_],
8961 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8962 )
8963 ).
8965 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8966 Rule = rule(_,_,Guard,Body),
8967 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8968 init(AllSusps,PreSusps),
8969 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8970 gen_var(OtherSusps),
8971 functor(CurrentHead,OtherF,OtherA),
8972 gen_vars(OtherA,OtherVars),
8973 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8974 get_constraint_mode(OtherF/OtherA,Mode),
8975 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8977 delay_phase_end(validate_store_type_assumptions,
8978 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8979 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8980 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8981 )
8982 ),
8984 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8985 % create_get_mutable_ref(active,State,GetMutable),
8986 CurrentSuspTest = (
8987 OtherSusp = OtherSuspension,
8988 GetState,
8989 DiffSuspGoals,
8990 FirstMatching
8991 ),
8992 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8993 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8994 inc_id(Id,NestedId),
8995 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8996 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8997 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8998 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8999 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9001 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9002 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9003 RecursiveVars = PreVarsAndSusps1
9004 ;
9005 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9006 PrevId0 = Id
9007 ),
9008 ( PrevId0 = [_] ->
9009 PrevId = PrevId0
9010 ;
9011 PrevId = [O|PrevId0]
9012 ),
9013 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9015 Clause = (
9016 ClauseHead :-
9017 ( CurrentSuspTest,
9018 NextSuspGoal
9019 ->
9020 NestedHead
9021 ; RecursiveHead
9022 )
9023 ),
9024 add_dummy_location(Clause,LocatedClause),
9025 L = [LocatedClause|T].
9027 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9029 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9030 % Observation Analysis
9031 %
9032 % CLASSIFICATION
9033 % Enabled
9034 %
9035 % Analysis based on Abstract Interpretation paper.
9036 %
9037 % TODO:
9038 % stronger analysis domain [research]
9040 :- chr_constraint
9041 initial_call_pattern/1,
9042 call_pattern/1,
9043 call_pattern_worker/1,
9044 final_answer_pattern/2,
9045 abstract_constraints/1,
9046 depends_on/2,
9047 depends_on_ap/4,
9048 depends_on_goal/2,
9049 ai_observed_internal/2,
9050 % ai_observed/2,
9051 ai_not_observed_internal/2,
9052 ai_not_observed/2,
9053 ai_is_observed/2,
9054 depends_on_as/3,
9055 ai_observation_gather_results/0.
9057 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9058 :- chr_type program_point == any.
9060 :- chr_option(mode,initial_call_pattern(+)).
9061 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9063 :- chr_option(mode,call_pattern(+)).
9064 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9066 :- chr_option(mode,call_pattern_worker(+)).
9067 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9069 :- chr_option(mode,final_answer_pattern(+,+)).
9070 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9072 :- chr_option(mode,abstract_constraints(+)).
9073 :- chr_option(type_declaration,abstract_constraints(list)).
9075 :- chr_option(mode,depends_on(+,+)).
9076 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9078 :- chr_option(mode,depends_on_as(+,+,+)).
9079 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9080 :- chr_option(mode,depends_on_goal(+,+)).
9081 :- chr_option(mode,ai_is_observed(+,+)).
9082 :- chr_option(mode,ai_not_observed(+,+)).
9083 % :- chr_option(mode,ai_observed(+,+)).
9084 :- chr_option(mode,ai_not_observed_internal(+,+)).
9085 :- chr_option(mode,ai_observed_internal(+,+)).
9088 abstract_constraints_fd @
9089 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9091 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9092 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9093 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9095 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9096 ai_is_observed(_,_) <=> true.
9098 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9099 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9100 ai_observation_gather_results <=> true.
9102 %------------------------------------------------------------------------------%
9103 % Main Analysis Entry
9104 %------------------------------------------------------------------------------%
9105 ai_observation_analysis(ACs) :-
9106 ( chr_pp_flag(ai_observation_analysis,on),
9107 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9108 list_to_ord_set(ACs,ACSet),
9109 abstract_constraints(ACSet),
9110 ai_observation_schedule_initial_calls(ACSet,ACSet),
9111 ai_observation_gather_results
9112 ;
9113 true
9114 ).
9116 ai_observation_schedule_initial_calls([],_).
9117 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9118 ai_observation_schedule_initial_call(AC,ACs),
9119 ai_observation_schedule_initial_calls(RACs,ACs).
9121 ai_observation_schedule_initial_call(AC,ACs) :-
9122 ai_observation_top(AC,CallPattern),
9123 % ai_observation_bot(AC,ACs,CallPattern),
9124 initial_call_pattern(CallPattern).
9126 ai_observation_schedule_new_calls([],AP).
9127 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9128 AP = odom(_,Set),
9129 initial_call_pattern(odom(AC,Set)),
9130 ai_observation_schedule_new_calls(ACs,AP).
9132 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9133 <=>
9134 ai_observation_leq(AP2,AP1)
9135 |
9136 true.
9138 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9140 initial_call_pattern(CP) ==> call_pattern(CP).
9142 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9143 ==>
9144 ai_observation_schedule_new_calls(ACs,AP)
9145 pragma
9146 passive(ID3).
9148 call_pattern(CP) \ call_pattern(CP) <=> true.
9150 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9151 final_answer_pattern(CP1,AP).
9153 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9155 call_pattern(CP) ==> call_pattern_worker(CP).
9157 %------------------------------------------------------------------------------%
9158 % Abstract Goal
9159 %------------------------------------------------------------------------------%
9161 % AbstractGoala
9162 %call_pattern(odom([],Set)) ==>
9163 % final_answer_pattern(odom([],Set),odom([],Set)).
9165 call_pattern_worker(odom([],Set)) <=>
9166 % writeln(' - AbstractGoal'(odom([],Set))),
9167 final_answer_pattern(odom([],Set),odom([],Set)).
9169 % AbstractGoalb
9170 call_pattern_worker(odom([G|Gs],Set)) <=>
9171 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9172 CP1 = odom(G,Set),
9173 depends_on_goal(odom([G|Gs],Set),CP1),
9174 call_pattern(CP1).
9176 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9177 <=> true pragma passive(ID).
9178 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9179 ==>
9180 CP1 = odom([_|Gs],_),
9181 AP2 = odom([],Set),
9182 CCP = odom(Gs,Set),
9183 call_pattern(CCP),
9184 depends_on(CP1,CCP).
9186 %------------------------------------------------------------------------------%
9187 % Abstract Disjunction
9188 %------------------------------------------------------------------------------%
9190 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9191 CP = odom((AG1;AG2),Set),
9192 InitialAnswerApproximation = odom([],Set),
9193 final_answer_pattern(CP,InitialAnswerApproximation),
9194 CP1 = odom(AG1,Set),
9195 CP2 = odom(AG2,Set),
9196 call_pattern(CP1),
9197 call_pattern(CP2),
9198 depends_on_as(CP,CP1,CP2).
9200 %------------------------------------------------------------------------------%
9201 % Abstract Solve
9202 %------------------------------------------------------------------------------%
9203 call_pattern_worker(odom(builtin,Set)) <=>
9204 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9205 ord_empty(EmptySet),
9206 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9208 %------------------------------------------------------------------------------%
9209 % Abstract Drop
9210 %------------------------------------------------------------------------------%
9211 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9212 <=>
9213 O > MO
9214 |
9215 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9216 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9217 pragma
9218 passive(ID2).
9220 %------------------------------------------------------------------------------%
9221 % Abstract Activate
9222 %------------------------------------------------------------------------------%
9223 call_pattern_worker(odom(AC,Set))
9224 <=>
9225 AC = _ / _
9226 |
9227 % writeln(' - AbstractActivate'(odom(AC,Set))),
9228 CP = odom(occ(AC,1),Set),
9229 call_pattern(CP),
9230 depends_on(odom(AC,Set),CP).
9232 %------------------------------------------------------------------------------%
9233 % Abstract Passive
9234 %------------------------------------------------------------------------------%
9235 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9236 <=>
9237 is_passive(RuleNb,ID)
9238 |
9239 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9240 % DEFAULT
9241 NO is O + 1,
9242 DCP = odom(occ(C,NO),Set),
9243 call_pattern(DCP),
9244 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9245 depends_on(odom(occ(C,O),Set),DCP)
9246 pragma
9247 passive(ID2).
9248 %------------------------------------------------------------------------------%
9249 % Abstract Simplify
9250 %------------------------------------------------------------------------------%
9252 % AbstractSimplify
9253 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9254 <=>
9255 \+ is_passive(RuleNb,ID)
9256 |
9257 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9258 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9259 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9260 ai_observation_memo_abstract_goal(RuleNb,AG),
9261 call_pattern(odom(AG,Set2)),
9262 % DEFAULT
9263 NO is O + 1,
9264 DCP = odom(occ(C,NO),Set),
9265 call_pattern(DCP),
9266 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9267 % DEADLOCK AVOIDANCE
9268 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9269 pragma
9270 passive(ID2).
9272 depends_on_as(CP,CPS,CPD),
9273 final_answer_pattern(CPS,APS),
9274 final_answer_pattern(CPD,APD) ==>
9275 ai_observation_lub(APS,APD,AP),
9276 final_answer_pattern(CP,AP).
9279 :- chr_constraint
9280 ai_observation_memo_simplification_rest_heads/3,
9281 ai_observation_memoed_simplification_rest_heads/3.
9283 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9284 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9286 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9287 <=>
9288 QRH = RH.
9289 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9290 <=>
9291 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9292 once(select2(ID,_,IDs1,H1,_,RestH1)),
9293 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9294 ai_observation_abstract_constraints(H2,ACs,AH2),
9295 append(ARestHeads,AH2,AbstractHeads),
9296 sort(AbstractHeads,QRH),
9297 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9298 pragma
9299 passive(ID1),
9300 passive(ID2),
9301 passive(ID3).
9303 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9305 %------------------------------------------------------------------------------%
9306 % Abstract Propagate
9307 %------------------------------------------------------------------------------%
9310 % AbstractPropagate
9311 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9312 <=>
9313 \+ is_passive(RuleNb,ID)
9314 |
9315 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9316 % observe partners
9317 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9318 ai_observation_observe_set(Set,AHs,Set2),
9319 ord_add_element(Set2,C,Set3),
9320 ai_observation_memo_abstract_goal(RuleNb,AG),
9321 call_pattern(odom(AG,Set3)),
9322 ( ord_memberchk(C,Set2) ->
9323 Delete = no
9324 ;
9325 Delete = yes
9326 ),
9327 % DEFAULT
9328 NO is O + 1,
9329 DCP = odom(occ(C,NO),Set),
9330 call_pattern(DCP),
9331 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9332 pragma
9333 passive(ID2).
9335 :- chr_constraint
9336 ai_observation_memo_propagation_rest_heads/3,
9337 ai_observation_memoed_propagation_rest_heads/3.
9339 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9340 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9342 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9343 <=>
9344 QRH = RH.
9345 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9346 <=>
9347 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9348 once(select2(ID,_,IDs2,H2,_,RestH2)),
9349 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9350 ai_observation_abstract_constraints(H1,ACs,AH1),
9351 append(ARestHeads,AH1,AbstractHeads),
9352 sort(AbstractHeads,QRH),
9353 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9354 pragma
9355 passive(ID1),
9356 passive(ID2),
9357 passive(ID3).
9359 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9361 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9362 final_answer_pattern(CP,APD).
9363 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9364 final_answer_pattern(CPD,APD) ==>
9365 true |
9366 CP = odom(occ(C,O),_),
9367 ( ai_observation_is_observed(APP,C) ->
9368 ai_observed_internal(C,O)
9369 ;
9370 ai_not_observed_internal(C,O)
9371 ),
9372 ( Delete == yes ->
9373 APP = odom([],Set0),
9374 ord_del_element(Set0,C,Set),
9375 NAPP = odom([],Set)
9376 ;
9377 NAPP = APP
9378 ),
9379 ai_observation_lub(NAPP,APD,AP),
9380 final_answer_pattern(CP,AP).
9382 %------------------------------------------------------------------------------%
9383 % Catch All
9384 %------------------------------------------------------------------------------%
9386 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9388 %------------------------------------------------------------------------------%
9389 % Auxiliary Predicates
9390 %------------------------------------------------------------------------------%
9392 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9393 ord_intersection(S1,S2,S3).
9395 ai_observation_bot(AG,AS,odom(AG,AS)).
9397 ai_observation_top(AG,odom(AG,EmptyS)) :-
9398 ord_empty(EmptyS).
9400 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9401 ord_subset(S2,S1).
9403 ai_observation_observe_set(S,ACSet,NS) :-
9404 ord_subtract(S,ACSet,NS).
9406 ai_observation_abstract_constraint(C,ACs,AC) :-
9407 functor(C,F,A),
9408 AC = F/A,
9409 memberchk(AC,ACs).
9411 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9412 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9414 %------------------------------------------------------------------------------%
9415 % Abstraction of Rule Bodies
9416 %------------------------------------------------------------------------------%
9418 :- chr_constraint
9419 ai_observation_memoed_abstract_goal/2,
9420 ai_observation_memo_abstract_goal/2.
9422 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9423 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9425 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9426 <=>
9427 QAG = AG
9428 pragma
9429 passive(ID1).
9431 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9432 <=>
9433 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9434 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9435 QAG = AG,
9436 ai_observation_memoed_abstract_goal(RuleNb,AG)
9437 pragma
9438 passive(ID1),
9439 passive(ID2).
9441 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9442 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9443 term_variables((H1,H2,Guard),HVars),
9444 append(H1,H2,Heads),
9445 % variables that are declared to be ground are safe,
9446 ground_vars(Heads,GroundVars),
9447 % so we remove them from the list of 'dangerous' head variables
9448 list_difference_eq(HVars,GroundVars,HV),
9449 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9450 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9451 % HV are 'dangerous' variables, all others are fresh and safe
9453 ground_vars([],[]).
9454 ground_vars([H|Hs],GroundVars) :-
9455 functor(H,F,A),
9456 get_constraint_mode(F/A,Mode),
9457 % TOM: fix this code!
9458 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9459 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9460 ground_vars(Hs,GroundVars2),
9461 append(GroundVars1,GroundVars2,GroundVars).
9463 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9464 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9465 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9466 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9467 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9468 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9469 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9470 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9471 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9472 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9473 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9474 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9475 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9476 % non-CHR constraint is safe if it only binds fresh variables
9477 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9478 builtin_binds_b(G,Vars),
9479 intersect_eq(Vars,HV,[]),
9480 !.
9481 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9482 AG = builtin. % default case if goal is not recognized/safe
9484 ai_observation_is_observed(odom(_,ACSet),AC) :-
9485 \+ ord_memberchk(AC,ACSet).
9487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9488 unconditional_occurrence(C,O) :-
9489 get_occurrence(C,O,RuleNb,ID),
9490 get_rule(RuleNb,PRule),
9491 PRule = pragma(ORule,_,_,_,_),
9492 copy_term_nat(ORule,Rule),
9493 Rule = rule(H1,H2,Guard,_),
9494 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9495 once((
9496 H1 = [Head], H2 == []
9497 ;
9498 H2 = [Head], H1 == [], \+ may_trigger(C)
9499 )),
9500 all_distinct_var_args(Head).
9502 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9504 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9505 % Partial wake analysis
9506 %
9507 % In a Var = Var unification do not wake up constraints of both variables,
9508 % but rather only those of one variable.
9509 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9511 :- chr_constraint partial_wake_analysis/0.
9512 :- chr_constraint no_partial_wake/1.
9513 :- chr_option(mode,no_partial_wake(+)).
9514 :- chr_constraint wakes_partially/1.
9515 :- chr_option(mode,wakes_partially(+)).
9517 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9518 ==>
9519 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9520 ( is_passive(RuleNb,ID) ->
9521 true
9522 ; Type == simplification ->
9523 select(H,H1,RestH1),
9524 H =.. [_|Args],
9525 term_variables(Guard,Vars),
9526 partial_wake_args(Args,ArgModes,Vars,FA)
9527 ; % Type == propagation ->
9528 select(H,H2,RestH2),
9529 H =.. [_|Args],
9530 term_variables(Guard,Vars),
9531 partial_wake_args(Args,ArgModes,Vars,FA)
9532 ).
9534 partial_wake_args([],_,_,_).
9535 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9536 ( Mode \== (+) ->
9537 ( nonvar(Arg) ->
9538 no_partial_wake(C)
9539 ; memberchk_eq(Arg,Vars) ->
9540 no_partial_wake(C)
9541 ;
9542 true
9543 )
9544 ;
9545 true
9546 ),
9547 partial_wake_args(Args,Modes,Vars,C).
9549 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9551 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9553 wakes_partially(C) <=> true.
9556 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9557 % Generate rules that implement chr_show_store/1 functionality.
9558 %
9559 % CLASSIFICATION
9560 % Experimental
9561 % Unused
9562 %
9563 % Generates additional rules:
9564 %
9565 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9566 % ...
9567 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9568 % $show <=> true.
9570 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9571 ( chr_pp_flag(show,on) ->
9572 Constraints = ['$show'/0|Constraints0],
9573 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9574 inc_rule_count(RuleNb),
9575 Rule = pragma(
9576 rule(['$show'],[],true,true),
9577 ids([0],[]),
9578 [],
9579 no,
9580 RuleNb
9581 )
9582 ;
9583 Constraints = Constraints0,
9584 Rules = Rules0
9585 ).
9587 generate_show_rules([],Rules,Rules).
9588 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9589 functor(C,F,A),
9590 inc_rule_count(RuleNb),
9591 Rule = pragma(
9592 rule([],['$show',C],true,writeln(C)),
9593 ids([],[0,1]),
9594 [passive(1)],
9595 no,
9596 RuleNb
9597 ),
9598 generate_show_rules(Rest,Tail,Rules).
9600 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9601 % Custom supension term layout
9603 static_suspension_term(F/A,Suspension) :-
9604 suspension_term_base(F/A,Base),
9605 Arity is Base + A,
9606 functor(Suspension,suspension,Arity).
9608 has_suspension_field(FA,Field) :-
9609 suspension_term_base_fields(FA,Fields),
9610 memberchk(Field,Fields).
9612 suspension_term_base(FA,Base) :-
9613 suspension_term_base_fields(FA,Fields),
9614 length(Fields,Base).
9616 suspension_term_base_fields(FA,Fields) :-
9617 ( chr_pp_flag(debugable,on) ->
9618 % 1. ID
9619 % 2. State
9620 % 3. Propagation History
9621 % 4. Generation Number
9622 % 5. Continuation Goal
9623 % 6. Functor
9624 Fields = [id,state,history,generation,continuation,functor]
9625 ;
9626 ( uses_history(FA) ->
9627 Fields = [id,state,history|Fields2]
9628 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9629 Fields = [state|Fields2]
9630 ;
9631 Fields = [id,state|Fields2]
9632 ),
9633 ( only_ground_indexed_arguments(FA) ->
9634 get_store_type(FA,StoreType),
9635 basic_store_types(StoreType,BasicStoreTypes),
9636 ( memberchk(global_ground,BasicStoreTypes) ->
9637 % 1. ID
9638 % 2. State
9639 % 3. Propagation History
9640 % 4. Global List Prev
9641 Fields2 = [global_list_prev|Fields3]
9642 ;
9643 % 1. ID
9644 % 2. State
9645 % 3. Propagation History
9646 Fields2 = Fields3
9647 ),
9648 ( chr_pp_flag(ht_removal,on)
9649 -> ht_prev_fields(BasicStoreTypes,Fields3)
9650 ; Fields3 = []
9651 )
9652 ; may_trigger(FA) ->
9653 % 1. ID
9654 % 2. State
9655 % 3. Propagation History
9656 ( uses_field(FA,generation) ->
9657 % 4. Generation Number
9658 % 5. Global List Prev
9659 Fields2 = [generation,global_list_prev|Fields3]
9660 ;
9661 Fields2 = [global_list_prev|Fields3]
9662 ),
9663 ( chr_pp_flag(mixed_stores,on),
9664 chr_pp_flag(ht_removal,on)
9665 -> get_store_type(FA,StoreType),
9666 basic_store_types(StoreType,BasicStoreTypes),
9667 ht_prev_fields(BasicStoreTypes,Fields3)
9668 ; Fields3 = []
9669 )
9670 ;
9671 % 1. ID
9672 % 2. State
9673 % 3. Propagation History
9674 % 4. Global List Prev
9675 Fields2 = [global_list_prev|Fields3],
9676 ( chr_pp_flag(mixed_stores,on),
9677 chr_pp_flag(ht_removal,on)
9678 -> get_store_type(FA,StoreType),
9679 basic_store_types(StoreType,BasicStoreTypes),
9680 ht_prev_fields(BasicStoreTypes,Fields3)
9681 ; Fields3 = []
9682 )
9683 )
9684 ).
9686 ht_prev_fields(Stores,Prevs) :-
9687 ht_prev_fields_int(Stores,PrevsList),
9688 append(PrevsList,Prevs).
9689 ht_prev_fields_int([],[]).
9690 ht_prev_fields_int([H|T],Fields) :-
9691 ( H = multi_hash(Indexes)
9692 -> maplist(ht_prev_field,Indexes,FH),
9693 Fields = [FH|FT]
9694 ; Fields = FT
9695 ),
9696 ht_prev_fields_int(T,FT).
9698 ht_prev_field(Index,Field) :-
9699 concat_atom(['multi_hash_prev-'|Index],Field).
9701 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9702 suspension_term_base_fields(FA,Fields),
9703 nth1(Index,Fields,FieldName), !,
9704 arg(Index,StaticSuspension,Field).
9705 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9706 suspension_term_base(FA,Base),
9707 StaticSuspension =.. [_|Args],
9708 drop(Base,Args,Field).
9709 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9710 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9713 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9714 suspension_term_base_fields(FA,Fields),
9715 nth1(Index,Fields,FieldName), !,
9716 Goal = arg(Index,DynamicSuspension,Field).
9717 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9718 static_suspension_term(FA,StaticSuspension),
9719 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9720 Goal = (DynamicSuspension = StaticSuspension).
9721 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9722 suspension_term_base(FA,Base),
9723 Index is I + Base,
9724 Goal = arg(Index,DynamicSuspension,Field).
9725 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9726 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9729 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9730 suspension_term_base_fields(FA,Fields),
9731 nth1(Index,Fields,FieldName), !,
9732 Goal = setarg(Index,DynamicSuspension,Field).
9733 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9734 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9736 basic_store_types(multi_store(Types),Types) :- !.
9737 basic_store_types(Type,[Type]).
9739 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9740 %
9742 :- chr_constraint
9743 phase_end/1,
9744 delay_phase_end/2.
9746 :- chr_option(mode,phase_end(+)).
9747 :- chr_option(mode,delay_phase_end(+,?)).
9749 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9750 % phase_end(Phase) <=> true.
9753 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9754 :- chr_constraint
9755 does_use_history/2,
9756 uses_history/1,
9757 novel_production_call/4.
9759 :- chr_option(mode,uses_history(+)).
9760 :- chr_option(mode,does_use_history(+,+)).
9761 :- chr_option(mode,novel_production_call(+,+,?,?)).
9763 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9764 does_use_history(FA,_) \ uses_history(FA) <=> true.
9765 uses_history(_FA) <=> fail.
9767 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9768 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9770 :- chr_constraint
9771 does_use_field/2,
9772 uses_field/2.
9774 :- chr_option(mode,uses_field(+,+)).
9775 :- chr_option(mode,does_use_field(+,+)).
9777 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9778 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9779 uses_field(_FA,_Field) <=> fail.
9781 :- chr_constraint
9782 uses_state/2,
9783 if_used_state/5,
9784 used_states_known/0.
9786 :- chr_option(mode,uses_state(+,+)).
9787 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9790 % states ::= not_stored_yet | passive | active | triggered | removed
9791 %
9792 % allocate CREATES not_stored_yet
9793 % remove CHECKS not_stored_yet
9794 % activate CHECKS not_stored_yet
9795 %
9796 % ==> no allocate THEN no not_stored_yet
9798 % recurs CREATES inactive
9799 % lookup CHECKS inactive
9801 % insert CREATES active
9802 % activate CREATES active
9803 % lookup CHECKS active
9804 % recurs CHECKS active
9806 % runsusp CREATES triggered
9807 % lookup CHECKS triggered
9808 %
9809 % ==> no runsusp THEN no triggered
9811 % remove CREATES removed
9812 % runsusp CHECKS removed
9813 % lookup CHECKS removed
9814 % recurs CHECKS removed
9815 %
9816 % ==> no remove THEN no removed
9818 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9820 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9822 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9823 <=> ResultGoal = Used.
9824 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9825 <=> ResultGoal = NotUsed.
9827 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9828 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9829 % (Feature for SSS)
9830 %
9831 % 1. Checking
9832 % ~~~~~~~~~~~
9833 %
9834 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9835 %
9836 % :- chr_option(declare_stored_constraints,on).
9837 %
9838 % the compiler will check for the storedness of constraints.
9839 %
9840 % By default, the compiler assumes that the programmer wants his constraints to
9841 % be never-stored. Hence, a warning will be issues when a constraint is actually
9842 % stored.
9843 %
9844 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9845 % to a constraint declaration, i.e. writes
9846 %
9847 % :- chr_constraint c(...) # stored.
9848 %
9849 % In that case a warning is issued when the constraint is never-stored.
9850 %
9851 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9852 % constraints are stored anyway.
9853 %
9854 %
9855 % 2. Rule Generation
9856 % ~~~~~~~~~~~~~~~~~~
9857 %
9858 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9859 %
9860 % :- chr_option(declare_stored_constraints,on).
9861 %
9862 % the compiler will generate default simplification rules for constraints.
9863 %
9864 % By default, no default rule is generated for a constraint. However, if the
9865 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9866 %
9867 % :- chr_constraint c(...) # default(Goal).
9868 %
9869 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9870 % the compiler generates a rule:
9871 %
9872 % c(_,...,_) <=> Goal.
9873 %
9874 % at the end of the program. If multiple default rules are generated, for several constraints,
9875 % then the order of the default rules is not specified.
9878 :- chr_constraint stored_assertion/1.
9879 :- chr_option(mode,stored_assertion(+)).
9880 :- chr_option(type_declaration,stored_assertion(constraint)).
9882 :- chr_constraint never_stored_default/2.
9883 :- chr_option(mode,never_stored_default(+,?)).
9884 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9886 % Rule Generation
9887 % ~~~~~~~~~~~~~~~
9889 generate_never_stored_rules(Constraints,Rules) :-
9890 ( chr_pp_flag(declare_stored_constraints,on) ->
9891 never_stored_rules(Constraints,Rules)
9892 ;
9893 Rules = []
9894 ).
9896 :- chr_constraint never_stored_rules/2.
9897 :- chr_option(mode,never_stored_rules(+,?)).
9898 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9900 never_stored_rules([],Rules) <=> Rules = [].
9901 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9902 Constraint = F/A,
9903 functor(Head,F,A),
9904 inc_rule_count(RuleNb),
9905 Rule = pragma(
9906 rule([Head],[],true,Goal),
9907 ids([0],[]),
9908 [],
9909 no,
9910 RuleNb
9911 ),
9912 Rules = [Rule|Tail],
9913 never_stored_rules(Constraints,Tail).
9914 never_stored_rules([_|Constraints],Rules) <=>
9915 never_stored_rules(Constraints,Rules).
9917 % Checking
9918 % ~~~~~~~~
9920 check_storedness_assertions(Constraints) :-
9921 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9922 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9923 ;
9924 true
9925 ).
9928 :- chr_constraint check_storedness_assertion/1.
9929 :- chr_option(mode,check_storedness_assertion(+)).
9930 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9932 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9933 <=> ( is_stored(Constraint) ->
9934 true
9935 ;
9936 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9937 ).
9938 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9939 <=> ( is_finally_stored(Constraint) ->
9940 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9941 ; is_stored(Constraint) ->
9942 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9943 ;
9944 true
9945 ).
9946 % never-stored, no default goal
9947 check_storedness_assertion(Constraint)
9948 <=> ( is_finally_stored(Constraint) ->
9949 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9950 ; is_stored(Constraint) ->
9951 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9952 ;
9953 true
9954 ).
9956 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9957 % success continuation analysis
9959 % TODO
9960 % also use for forward jumping improvement!
9961 % use Prolog indexing for generated code
9962 %
9963 % EXPORTED
9964 %
9965 % should_skip_to_next_id(C,O)
9966 %
9967 % get_occurrence_code_id(C,O,Id)
9968 %
9969 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9971 continuation_analysis(ConstraintSymbols) :-
9972 maplist(analyse_continuations,ConstraintSymbols).
9974 analyse_continuations(C) :-
9975 % 1. compute success continuations of the
9976 % occurrences of constraint C
9977 continuation_analysis(C,1),
9978 % 2. determine for which occurrences
9979 % to skip to next code id
9980 get_max_occurrence(C,MO),
9981 LO is MO + 1,
9982 bulk_propagation(C,1,LO),
9983 % 3. determine code id for each occurrence
9984 set_occurrence_code_id(C,1,0).
9986 % 1. Compute the success continuations of constrait C
9987 %-------------------------------------------------------------------------------
9989 continuation_analysis(C,O) :-
9990 get_max_occurrence(C,MO),
9991 ( O > MO ->
9992 true
9993 ; O == MO ->
9994 NextO is O + 1,
9995 continuation_occurrence(C,O,NextO)
9996 ;
9997 constraint_continuation(C,O,MO,NextO),
9998 continuation_occurrence(C,O,NextO),
9999 NO is O + 1,
10000 continuation_analysis(C,NO)
10001 ).
10003 constraint_continuation(C,O,MO,NextO) :-
10004 ( get_occurrence_head(C,O,Head) ->
10005 NO is O + 1,
10006 ( between(NO,MO,NextO),
10007 get_occurrence_head(C,NextO,NextHead),
10008 unifiable(Head,NextHead,_) ->
10009 true
10010 ;
10011 NextO is MO + 1
10012 )
10013 ; % current occurrence is passive
10014 NextO = MO
10015 ).
10017 get_occurrence_head(C,O,Head) :-
10018 get_occurrence(C,O,RuleNb,Id),
10019 \+ is_passive(RuleNb,Id),
10020 get_rule(RuleNb,Rule),
10021 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10022 ( select2(Id,Head,Ids1,H1,_,_) -> true
10023 ; select2(Id,Head,Ids2,H2,_,_)
10024 ).
10026 :- chr_constraint continuation_occurrence/3.
10027 :- chr_option(mode,continuation_occurrence(+,+,+)).
10029 :- chr_constraint get_success_continuation_occurrence/3.
10030 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10032 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10033 <=>
10034 X = NO.
10036 get_success_continuation_occurrence(C,O,X)
10037 <=>
10038 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10040 % 2. figure out when to skip to next code id
10041 %-------------------------------------------------------------------------------
10042 % don't go beyond the last occurrence
10043 % we have to go to next id for storage here
10045 :- chr_constraint skip_to_next_id/2.
10046 :- chr_option(mode,skip_to_next_id(+,+)).
10048 :- chr_constraint should_skip_to_next_id/2.
10049 :- chr_option(mode,should_skip_to_next_id(+,+)).
10051 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10052 <=>
10053 true.
10055 should_skip_to_next_id(_,_)
10056 <=>
10057 fail.
10059 :- chr_constraint bulk_propagation/3.
10060 :- chr_option(mode,bulk_propagation(+,+,+)).
10062 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10063 <=>
10064 O >= MO
10065 |
10066 skip_to_next_id(C,O).
10067 % we have to go to the next id here because
10068 % a predecessor needs it
10069 bulk_propagation(C,O,LO)
10070 <=>
10071 LO =:= O + 1
10072 |
10073 skip_to_next_id(C,O),
10074 get_max_occurrence(C,MO),
10075 NLO is MO + 1,
10076 bulk_propagation(C,LO,NLO).
10077 % we have to go to the next id here because
10078 % we're running into a simplification rule
10079 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10080 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10081 <=>
10082 NO =:= O + 1
10083 |
10084 skip_to_next_id(C,O),
10085 get_max_occurrence(C,MO),
10086 NLO is MO + 1,
10087 bulk_propagation(C,NO,NLO).
10088 % we skip the next id here
10089 % and go to the next occurrence
10090 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10091 <=>
10092 NextO > O + 1
10093 |
10094 NLO is min(LO,NextO),
10095 NO is O + 1,
10096 bulk_propagation(C,NO,NLO).
10097 % default case
10098 % err on the safe side
10099 bulk_propagation(C,O,LO)
10100 <=>
10101 skip_to_next_id(C,O),
10102 get_max_occurrence(C,MO),
10103 NLO is MO + 1,
10104 NO is O + 1,
10105 bulk_propagation(C,NO,NLO).
10107 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10109 % if this occurrence is passive, but has to skip,
10110 % then the previous one must skip instead...
10111 % IMPROVE reasoning is conservative
10112 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10113 ==>
10114 O > 1
10115 |
10116 PO is O - 1,
10117 skip_to_next_id(C,PO).
10119 % 3. determine code id of each occurrence
10120 %-------------------------------------------------------------------------------
10122 :- chr_constraint set_occurrence_code_id/3.
10123 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10125 :- chr_constraint occurrence_code_id/3.
10126 :- chr_option(mode,occurrence_code_id(+,+,+)).
10128 % stop at the end
10129 set_occurrence_code_id(C,O,IdNb)
10130 <=>
10131 get_max_occurrence(C,MO),
10132 O > MO
10133 |
10134 occurrence_code_id(C,O,IdNb).
10136 % passive occurrences don't change the code id
10137 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10138 <=>
10139 occurrence_code_id(C,O,IdNb),
10140 NO is O + 1,
10141 set_occurrence_code_id(C,NO,IdNb).
10143 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10144 <=>
10145 occurrence_code_id(C,O,IdNb),
10146 NO is O + 1,
10147 set_occurrence_code_id(C,NO,IdNb).
10149 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10150 <=>
10151 occurrence_code_id(C,O,IdNb),
10152 NO is O + 1,
10153 NIdNb is IdNb + 1,
10154 set_occurrence_code_id(C,NO,NIdNb).
10156 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10157 <=>
10158 occurrence_code_id(C,O,IdNb),
10159 NO is O + 1,
10160 set_occurrence_code_id(C,NO,IdNb).
10162 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10164 :- chr_constraint get_occurrence_code_id/3.
10165 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10167 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10168 <=>
10169 X = IdNb.
10171 get_occurrence_code_id(C,O,X)
10172 <=>
10173 ( O == 0 ->
10174 true % X = 0
10175 ;
10176 format('no occurrence code for ~w!\n',[C:O])
10177 ).
10179 get_success_continuation_code_id(C,O,NextId) :-
10180 get_success_continuation_occurrence(C,O,NextO),
10181 get_occurrence_code_id(C,NextO,NextId).
10183 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10184 % COLLECT CONSTANTS FOR INLINING
10185 %
10186 % for SSS
10188 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10190 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10191 collect_constants(Rules,Constraints,Clauses0) :-
10192 ( not_restarted, chr_pp_flag(experiment,on) ->
10193 ( chr_pp_flag(sss,on) ->
10194 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10195 copy_term_nat(Clauses0,Clauses),
10196 flatten_clauses(Clauses,Dictionary,FlatClauses),
10197 install_new_declarations_and_restart(FlatClauses)
10198 ;
10199 maplist(collect_rule_constants(Constraints),Rules),
10200 ( chr_pp_flag(verbose,on) ->
10201 print_chr_constants
10202 ;
10203 true
10204 ),
10205 ( chr_pp_flag(experiment,on) ->
10206 flattening_dictionary(Constraints,Dictionary),
10207 copy_term_nat(Clauses0,Clauses),
10208 flatten_clauses(Clauses,Dictionary,FlatClauses),
10209 install_new_declarations_and_restart(FlatClauses)
10210 ;
10211 true
10212 )
10213 )
10214 ;
10215 true
10216 ).
10218 :- chr_constraint chr_constants/1.
10219 :- chr_option(mode,chr_constants(+)).
10221 :- chr_constraint get_chr_constants/1.
10223 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10225 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10227 % collect_rule_constants(+constraint_symbols,+rule) {{{
10228 collect_rule_constants(Constraints,Rule) :-
10229 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10230 maplist(collect_head_constants,H1),
10231 maplist(collect_head_constants,H2),
10232 collect_body_constants(B,Constraints).
10234 collect_body_constants(Body,Constraints) :-
10235 conj2list(Body,Goals),
10236 maplist(collect_goal_constants(Constraints),Goals).
10238 collect_goal_constants(Constraints,Goal) :-
10239 ( nonvar(Goal),
10240 functor(Goal,C,N),
10241 memberchk(C/N,Constraints) ->
10242 collect_head_constants(Goal)
10243 ; nonvar(Goal),
10244 Goal = Mod : TheGoal,
10245 get_target_module(Module),
10246 Mod == Module,
10247 nonvar(TheGoal),
10248 functor(TheGoal,C,N),
10249 memberchk(C/N,Constraints) ->
10250 collect_head_constants(TheGoal)
10251 ;
10252 true
10253 ).
10255 collect_head_constants(Head) :-
10256 functor(Head,C,N),
10257 get_constraint_type_det(C/N,Types),
10258 Head =.. [_|Args],
10259 collect_all_arg_constants(Args,Types,[]).
10261 collect_all_arg_constants([],[],Constants) :-
10262 ( Constants \== [] ->
10263 add_chr_constants(Constants)
10264 ;
10265 true
10266 ).
10267 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10268 unalias_type(Type,NormalizedType),
10269 ( is_chr_constants_type(NormalizedType,Key,_) ->
10270 ( ground(Arg) ->
10271 collect_all_arg_constants(Args,Types,[Key-Arg|Constants0])
10272 ; % no useful information here
10273 true
10274 )
10275 ;
10276 collect_all_arg_constants(Args,Types,Constants0)
10277 ).
10279 add_chr_constants(Pairs) :-
10280 keysort(Pairs,SortedPairs),
10281 add_chr_constants_(SortedPairs).
10283 :- chr_constraint add_chr_constants_/1.
10284 :- chr_option(mode,add_chr_constants_(+)).
10286 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10287 sort([Constants|MoreConstants],NConstants),
10288 chr_constants(NConstants).
10290 add_chr_constants_(Constants) <=>
10291 chr_constants([Constants]).
10293 % }}}
10295 :- chr_constraint print_chr_constants/0. % {{{
10297 print_chr_constants, chr_constants(Constants) # Id ==>
10298 format('\t* chr_constants : ~w.\n',[Constants])
10299 pragma passive(Id).
10301 print_chr_constants <=>
10302 true.
10304 % }}}
10306 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10307 flattening_dictionary([],[]).
10308 flattening_dictionary([CS|CSs],Dictionary) :-
10309 ( flattening_dictionary_entry(CS,Entry) ->
10310 Dictionary = [Entry|Rest]
10311 ;
10312 Dictionary = Rest
10313 ),
10314 flattening_dictionary(CSs,Rest).
10316 flattening_dictionary_entry(CS,Entry) :-
10317 get_constraint_type_det(CS,Types),
10318 constant_positions(Types,1,Positions,Keys,Handler),
10319 Positions \== [], % there are chr_constant arguments
10320 pairup(Keys,Constants,Pairs0),
10321 keysort(Pairs0,Pairs),
10322 Entry = CS-Positions-Specs-Handler,
10323 get_chr_constants(ConstantsList),
10324 findall(Spec,
10325 ( member(Pairs,ConstantsList)
10326 , flat_spec(CS,Positions,Constants,Spec)
10327 ),
10328 Specs).
10330 constant_positions([],_,[],[],no).
10331 constant_positions([Type|Types],I,Positions,Keys,Handler) :-
10332 unalias_type(Type,NormalizedType),
10333 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10334 compose_error_handlers(ErrorHandler,NHandler,Handler),
10335 Positions = [I|NPositions],
10336 Keys = [Key|NKeys]
10337 ;
10338 NPositions = Positions,
10339 NKeys = Keys,
10340 NHandler = Handler
10341 ),
10342 J is I + 1,
10343 constant_positions(Types,J,NPositions,NKeys,NHandler).
10345 compose_error_handlers(no,Handler,Handler).
10346 compose_error_handlers(yes(Handler),_,yes(Handler)).
10348 flat_spec(C/N,Positions,Terms,Spec) :-
10349 Spec = Terms - Functor,
10350 term_to_atom(Terms,TermsAtom),
10351 term_to_atom(Positions,PositionsAtom),
10352 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10354 % }}}
10356 % }}}
10357 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10358 % RESTART AFTER FLATTENING {{{
10360 restart_after_flattening(Declarations,Declarations) :-
10361 nb_setval('$chr_restart_after_flattening',started).
10362 restart_after_flattening(_,Declarations) :-
10363 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10364 nb_setval('$chr_restart_after_flattening',restarted).
10366 not_restarted :-
10367 nb_getval('$chr_restart_after_flattening',started).
10369 install_new_declarations_and_restart(Declarations) :-
10370 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10371 fail. /* fails to choicepoint of restart_after_flattening */
10372 % }}}
10373 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10374 % FLATTENING {{{
10376 % DONE
10377 % -) generate dictionary from collected chr_constants
10378 % enable with :- chr_option(experiment,on).
10379 % -) issue constraint declarations for constraints not present in
10380 % dictionary
10381 % -) integrate with CHR compiler
10382 % -) pass Mike's test code (full syntactic support for current CHR code)
10383 % -) rewrite the body using the inliner
10384 %
10385 % TODO:
10386 % -) refined semantics correctness issue
10387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10389 flatten_clauses(Clauses,Dict,NClauses) :-
10390 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10391 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10393 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10394 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10395 dispatching_rules(Dict,NClauses1),
10396 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10397 flatten_rules(Clauses,Dict,NClauses3),
10398 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10400 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10401 % Declarations for non-flattened constraints
10403 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10404 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10405 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10406 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10407 flatten(DeclarationsList,Declarations).
10409 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10410 [(:- chr_constraint ConstraintSymbol),
10411 (:- chr_option(mode,ModeDeclPattern)),
10412 (:- chr_option(type_declaration,TypeDeclPattern))
10413 ]) :-
10414 ConstraintSymbol = Functor / Arity,
10415 % print optional mode declaration
10416 functor(ModeDeclPattern,Functor,Arity),
10417 ( memberchk(ModeDeclPattern,ModeDecls) ->
10418 true
10419 ;
10420 replicate(Arity,(?),Modes),
10421 ModeDeclPattern =.. [_|Modes]
10422 ),
10423 % print optional type declaration
10424 functor(TypeDeclPattern,Functor,Arity),
10425 ( memberchk(TypeDeclPattern,TypeDecls) ->
10426 true
10427 ;
10428 replicate(Arity,any,Types),
10429 TypeDeclPattern =.. [_|Types]
10430 ).
10431 % }}}
10432 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10433 % read clauses from file
10434 % CHR are returned
10435 % declared constaints are returned
10436 % type definitions are returned and printed
10437 % mode declarations are returned
10438 % other clauses are returned
10440 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10441 flatten_readcontent([],[],[],[],[],[],[]).
10442 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10443 % read(Clause),
10444 ( Clause == end_of_file ->
10445 Rules = [],
10446 ConstraintSymbols = [],
10447 ModeDecls = [],
10448 TypeDecls = [],
10449 TypeDefs = [],
10450 RestClauses = []
10451 ; crude_is_rule(Clause) ->
10452 Rules = [Clause|RestRules],
10453 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10454 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10455 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10456 append(SomeModeDecls,RestModeDecls,ModeDecls),
10457 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10458 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10459 ; is_mode_declaration(Clause,ModeDecl) ->
10460 ModeDecls = [ModeDecl|RestModeDecls],
10461 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10462 ; is_type_declaration(Clause,TypeDecl) ->
10463 TypeDecls = [TypeDecl|RestTypeDecls],
10464 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10465 ; is_type_definition(Clause,TypeDef) ->
10466 RestClauses = [Clause|NRestClauses],
10467 TypeDefs = [TypeDef|RestTypeDefs],
10468 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10469 ; ( Clause = (:- op(A,B,C)) ->
10470 % assert operators in order to read and print them out properly
10471 op(A,B,C)
10472 ;
10473 true
10474 ),
10475 RestClauses = [Clause|NRestClauses],
10476 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10477 ).
10479 crude_is_rule(_ @ _).
10480 crude_is_rule(_ pragma _).
10481 crude_is_rule(_ ==> _).
10482 crude_is_rule(_ <=> _).
10484 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10485 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10486 conj2list(Cs,Constraints0),
10487 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10489 pure_extract_type_mode([],[],[],[]).
10490 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10491 pure_extract_type_mode(R,R2,Modes,Types).
10492 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10493 functor(C,F,A),
10494 ConstraintSymbol = F/A,
10495 C =.. [_|Args],
10496 extract_types_and_modes(Args,ArgTypes,ArgModes),
10497 Mode =.. [F|ArgModes],
10498 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10499 Types = RTypes
10500 ;
10501 Types = [Type|RTypes],
10502 Type =.. [F|ArgTypes]
10503 ),
10504 pure_extract_type_mode(R,R2,Modes,RTypes).
10506 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10508 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10509 % }}}
10510 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10511 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10512 % including mode and type declarations
10514 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10515 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10516 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10517 flatten(ConstraintSpecs0,ConstraintSpecs).
10519 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10520 [(:- chr_constraint ConstraintSpec),
10521 (:- chr_option(mode,NewModeDecl)),
10522 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10523 member(C/N-I-SFs-_,Dict),
10524 arg_modes(C,N,ModeDecls,Modes),
10525 specialize_modes(Modes,I,SpecializedModes),
10526 arg_types(C,N,TypeDecls,Types),
10527 specialize_types(Types,I,SpecializedTypes),
10528 length(I,IndexSize),
10529 AN is N - IndexSize,
10530 member(_Term-F,SFs),
10531 ConstraintSpec = F/AN,
10532 NewModeDecl =.. [F|SpecializedModes],
10533 NewTypeDecl =.. [F|SpecializedTypes].
10535 arg_modes(C,N,ModeDecls,ArgModes) :-
10536 functor(ConstraintPattern,C,N),
10537 ( memberchk(ConstraintPattern,ModeDecls) ->
10538 ConstraintPattern =.. [_|ArgModes]
10539 ;
10540 replicate(N,?,ArgModes)
10541 ).
10543 specialize_modes(Modes,I,SpecializedModes) :-
10544 split_args(I,Modes,_,SpecializedModes).
10546 arg_types(C,N,TypeDecls,ArgTypes) :-
10547 functor(ConstraintPattern,C,N),
10548 ( memberchk(ConstraintPattern,TypeDecls) ->
10549 ConstraintPattern =.. [_|ArgTypes]
10550 ;
10551 replicate(N,any,ArgTypes)
10552 ).
10554 specialize_types(Types,I,SpecializedTypes) :-
10555 split_args(I,Types,_,SpecializedTypes).
10556 % }}}
10557 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10558 % DISPATCHING RULES
10559 %
10560 % dispatching_rules(+dict,-newrules)
10563 % {{{
10565 % This code generates a decision tree for calling the appropriate specialized
10566 % constraint based on the particular value of the argument the constraint
10567 % is being specialized on.
10568 %
10569 % In case an error handler is provided, the handler is called with the
10570 % unexpected constraint.
10572 dispatching_rules([],[]).
10573 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10574 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10575 dispatching_rules(Dict,RestDispatchingRules).
10577 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10578 ( increasing_numbers(I,1) ->
10579 /* index on first arguments */
10580 Rules0 = Rules,
10581 NCN = C/N
10582 ;
10583 /* reorder arguments for 1st argument indexing */
10584 functor(Head,C,N),
10585 Head =.. [_|Args],
10586 split_args(I,Args,GroundArgs,OtherArgs),
10587 append(GroundArgs,OtherArgs,ShuffledArgs),
10588 atom_concat(C,'_$shuffled',NC),
10589 Body =.. [NC|ShuffledArgs],
10590 [(Head :- Body)|Rules0] = Rules,
10591 NCN = NC / N
10592 ),
10593 Context = swap(C,I),
10594 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10596 increasing_numbers([],_).
10597 increasing_numbers([X|Ys],X) :-
10598 Y is X + 1,
10599 increasing_numbers(Ys,Y).
10601 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10602 length(I,IndexLength),
10603 once(pairup(TermLists,Functors,SFs)),
10604 maplist(head_tail,TermLists,Heads,Tails),
10605 Payload is N - IndexLength,
10606 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10607 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10609 dispatching_action(Functor,PayloadArgs,Goal) :-
10610 Goal =.. [Functor|PayloadArgs].
10612 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10613 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10615 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10616 % length MorePatterns == length Patterns == length Results
10617 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10618 MorePatterns = [List|_],
10619 length(List,N),
10620 aggregate_all(set(F/A),
10621 ( member(Pattern,Patterns),
10622 functor(Pattern,F,A)
10623 ),
10624 FAs),
10625 N1 is N + 1,
10626 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10628 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10629 ( MaybeErrorHandler = yes(ErrorHandler) ->
10630 Clauses0 = [ErrorClause|Clauses],
10631 ErrorClause = (Head :- Body),
10632 Arity is N + Payload,
10633 functor(Head,Symbol,Arity),
10634 reconstruct_original_term(Context,Head,Term),
10635 Body =.. [ErrorHandler,Term]
10636 ;
10637 Clauses0 = Clauses
10638 ).
10639 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10640 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10641 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10643 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10644 Clause = (Head :- Cut, Body),
10645 ( MaybeErrorHandler = yes(_) ->
10646 Cut = (!)
10647 ;
10648 Cut = true
10649 ),
10650 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10651 N1 is N + Payload,
10652 functor(Head,Symbol,N1),
10653 arg(1,Head,IndexPattern),
10654 Head =.. [_,_|RestArgs],
10655 length(PayloadArgs,Payload),
10656 once(append(Vs,PayloadArgs,RestArgs)),
10657 /* IndexPattern = F(...) */
10658 functor(IndexPattern,F,A),
10659 Context1 = index_functor(F,A,Context0),
10660 IndexPattern =.. [_|Args],
10661 append(Args,RestArgs,RecArgs),
10662 ( RecArgs == PayloadArgs ->
10663 /* nothing more to match on */
10664 List = Tail,
10665 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10666 MoreActions = [Action],
10667 call(Action,PayloadArgs,Body)
10668 ; /* more things to match on */
10669 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10670 ( MoreActions = [OneMoreAction] ->
10671 /* only one more thing to match on */
10672 MoreCases = [OneMoreCase],
10673 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10674 List = Tail,
10675 call(OneMoreAction,PayloadArgs,Body)
10676 ;
10677 /* more than one thing to match on */
10678 /* [ x1,..., xn]
10679 [xs1,...,xsn]
10680 */
10681 pairup(Cases,MoreCases,CasePairs),
10682 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10683 append(Args,Vs,[First|Rest]),
10684 First-Rest = CommonPatternPair,
10685 Context2 = gct([First|Rest],Context1),
10686 gensym(Prefix,RSymbol),
10687 append(DiffVars,PayloadArgs,RecCallVars),
10688 Body =.. [RSymbol|RecCallVars],
10689 findall(CH-CT,member([CH|CT],Differences),CPairs),
10690 once(pairup(CHs,CTs,CPairs)),
10691 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10692 )
10693 ).
10696 % split(list,int,before,at,after).
10698 split([X|Xs],I,Before,At,After) :-
10699 ( I == 1 ->
10700 Before = [],
10701 At = X,
10702 After = Xs
10703 ;
10704 J is I - 1,
10705 Before = [X|RBefore],
10706 split(Xs,J,RBefore,At,After)
10707 ).
10709 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10710 %
10711 % context ::= swap(functor,positions)
10712 % | index_functor(functor,arity,context)
10713 % | gct(Pattern,Context)
10715 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10716 functor(Term,_,Arity),
10717 functor(OriginalTerm,Functor,Arity),
10718 OriginalTerm =.. [_|OriginalArgs],
10719 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10720 Term =.. [_|Args],
10721 append(IndexArgs,OtherArgs,Args).
10722 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10723 Term0 =.. [Predicate|Args],
10724 split_at(Arity,Args,IndexArgs,RestArgs),
10725 Index =.. [Functor|IndexArgs],
10726 Term1 =.. [Predicate,Index|RestArgs],
10727 reconstruct_original_term(Context,Term1,OriginalTerm).
10728 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10729 copy_term_nat(PatternList,IndexTerms),
10730 term_variables(IndexTerms,Variables),
10731 Term0 =.. [Predicate|Args0],
10732 append(Variables,RestArgs,Args0),
10733 append(IndexTerms,RestArgs,Args1),
10734 Term1 =.. [Predicate|Args1],
10735 reconstruct_original_term(Context,Term1,OriginalTerm).
10736 % }}}
10738 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10739 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10740 %
10741 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10742 %
10743 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
10745 % {{{
10746 flatten_rules(Rules,Dict,FlatRules) :-
10747 flatten_rules1(Rules,Dict,FlatRulesList),
10748 flatten(FlatRulesList,FlatRules).
10750 flatten_rules1([],_,[]).
10751 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10752 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10753 flatten_rules1(Rules,Dict,FlatRulesList).
10755 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10756 flatten_rule(Rule,Dict,NRule).
10757 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10758 flatten_rule(Rule,Dict,NRule).
10759 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10760 flatten_heads(H,Dict,NH),
10761 flatten_body(B,Dict,NB).
10762 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10763 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10764 flatten_body(B,Dict,NB).
10765 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10766 flatten_heads(H,Dict,NH),
10767 flatten_body(B,Dict,NB).
10769 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10770 flatten_heads(H1,Dict,NH1),
10771 flatten_heads(H2,Dict,NH2).
10772 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10773 flatten_heads(H,Dict,NH).
10774 flatten_heads(H,Dict,NH) :-
10775 ( functor(H,C,N),
10776 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
10777 H =.. [_|AllArgs],
10778 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
10779 member(GroundArgs-Name,SFs),
10780 NH =.. [Name|OtherArgs]
10781 ;
10782 NH = H
10783 ).
10785 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
10786 conj2list(Guard,Guards),
10787 maplist(flatten_goal(Dict),Guards,NGuards),
10788 list2conj(NGuards,NGuard),
10789 conj2list(Body,Goals),
10790 maplist(flatten_goal(Dict),Goals,NGoals),
10791 list2conj(NGoals,NBody).
10792 flatten_body(Body,Dict,NBody) :-
10793 conj2list(Body,Goals),
10794 maplist(flatten_goal(Dict),Goals,NGoals),
10795 list2conj(NGoals,NBody).
10797 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
10798 flatten_goal(Dict,Goal,NGoal) :-
10799 ( is_specializable_goal(Goal,Dict,ArgPositions)
10800 ->
10801 specialize_goal(Goal,ArgPositions,NGoal)
10802 ; Goal = Mod : TheGoal,
10803 get_target_module(Module),
10804 Mod == Module,
10805 nonvar(TheGoal),
10806 is_specializable_goal(TheGoal,Dict,ArgPositions)
10807 ->
10808 specialize_goal(TheGoal,ArgPositions,NTheGoal),
10809 NGoal = Mod : NTheGoal
10810 ; partial_eval(Goal,NGoal)
10811 ->
10812 true
10813 ;
10814 NGoal = Goal
10815 ).
10817 %-------------------------------------------------------------------------------%
10818 % Specialize body/guard goal
10819 %-------------------------------------------------------------------------------%
10820 is_specializable_goal(Goal,Dict,ArgPositions) :-
10821 functor(Goal,C,N),
10822 memberchk(C/N-ArgPositions-_-_,Dict),
10823 args(ArgPositions,Goal,Args),
10824 ground(Args).
10826 specialize_goal(Goal,ArgPositions,NGoal) :-
10827 functor(Goal,C,N),
10828 Goal =.. [_|Args],
10829 split_args(ArgPositions,Args,GroundTerms,Others),
10830 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
10831 NGoal =.. [Functor|Others].
10833 %-------------------------------------------------------------------------------%
10834 % Partially evaluate predicates
10835 %-------------------------------------------------------------------------------%
10837 % append([],Y,Z) >--> Y = Z
10838 % append(X,[],Z) >--> X = Z
10839 partial_eval(append(L1,L2,L3),NGoal) :-
10840 ( L1 == [] ->
10841 NGoal = (L3 = L2)
10842 ; L2 == [] ->
10843 NGoal = (L3 = L1)
10845 ).
10846 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
10847 % where flatten(L1,L1')
10848 partial_eval(flatten_path(L1,L2),NGoal) :-
10849 nonvar(L1),
10850 flatten(L1,FlatterL1),
10851 FlatterL1 \== L1 ->
10852 NGoal = flatten_path(FlatterL1,L2).
10855 % }}}
10857 % }}}
10858 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10859 dump_code(Clauses) :-
10860 ( chr_pp_flag(dump,on) ->
10861 maplist(portray_clause,Clauses)
10862 ;
10863 true
10864 ).
10866 chr_banner :-
10867 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',[]).