| blob | 520b5b8a96ee0187f5a17514b83f791bebbfca09 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% TODO {{{
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * analyze history usage to determine whether/when
64 %% cheaper suspension is possible:
65 %% don't use history when all partners are passive and self never triggers
66 %% * store constraint unconditionally for unconditional propagation rule,
67 %% if first, i.e. without checking history and set trigger cont to next occ
68 %% * get rid of suspension passing for never triggered constraints,
69 %% up to allocation occurrence
70 %% * get rid of call indirection for never triggered constraints
71 %% up to first allocation occurrence.
72 %% * get rid of unnecessary indirection if last active occurrence
73 %% before unconditional removal is head2, e.g.
74 %% a \ b <=> true.
75 %% a <=> true.
76 %% * Eliminate last clause of never stored constraint, if its body
77 %% is fail, e.g.
78 %% a ...
79 %% a <=> fail.
80 %% * Specialize lookup operations and indexes for functional dependencies.
81 %%
82 %% MORE TODO
83 %%
84 %% * map A \ B <=> true | true rules
85 %% onto efficient code that empties the constraint stores of B
86 %% in O(1) time for ground constraints where A and B do not share
87 %% any variables
88 %% * ground matching seems to be not optimized for compound terms
89 %% in case of simpagation_head2 and propagation occurrences
90 %% * analysis for storage delaying (see primes for case)
91 %% * internal constraints declaration + analyses?
92 %% * Do not store in global variable store if not necessary
93 %% NOTE: affects show_store/1
94 %% * var_assoc multi-level store: variable - ground
95 %% * Do not maintain/check unnecessary propagation history
96 %% for reasons of anti-monotony
97 %% * Strengthen storage analysis for propagation rules
98 %% reason about bodies of rules only containing constraints
99 %% -> fixpoint with observation analysis
100 %% * instantiation declarations
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
103 %%
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * fd -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
112 %% ...
113 %% if( (
114 %% generator_n(Y),
115 %% test(X,Y)
116 %% ),
117 %% true,
118 %% ('_$cutto'(CP_1), fail)
119 %% ),
120 %% ...
121 %%
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
129 %% }}}
130 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :- module(chr_translate,
132 [ chr_translate/2 % +Decls, -TranslatedDecls
133 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
134 ]).
135 %% SWI begin {{{
136 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
137 :- use_module(library(ordsets)).
138 :- use_module(library(aggregate)).
139 :- use_module(library(apply_macros)).
140 :- use_module(library(occurs)).
141 :- use_module(library(assoc)).
142 %% SWI end }}}
144 % imports and operators {{{
145 :- use_module(hprolog).
146 :- use_module(pairlist).
147 :- use_module(a_star).
148 :- use_module(listmap).
149 :- use_module(clean_code).
150 :- use_module(builtins).
151 :- use_module(find).
152 :- use_module(binomialheap).
153 :- use_module(guard_entailment).
154 :- use_module(chr_compiler_options).
155 :- use_module(chr_compiler_utility).
156 :- use_module(chr_compiler_errors).
157 :- include(chr_op).
158 :- op(1150, fx, chr_type).
159 :- op(1150, fx, chr_declaration).
160 :- op(1130, xfx, --->).
161 :- op(980, fx, (+)).
162 :- op(980, fx, (-)).
163 :- op(980, fx, (?)).
164 :- op(1150, fx, constraints).
165 :- op(1150, fx, chr_constraint).
166 % }}}
168 :- chr_option(debug,off).
169 :- chr_option(optimize,full).
170 :- chr_option(check_guard_bindings,off).
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 % Type Declarations {{{
174 :- chr_type list(T) ---> [] ; [T|list(T)].
176 :- chr_type list == list(any).
178 :- chr_type mode ---> (+) ; (-) ; (?).
180 :- chr_type maybe(T) ---> yes(T) ; no.
182 :- chr_type constraint ---> any / any.
184 :- chr_type module_name == any.
186 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
187 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
188 :- chr_type idspair ---> ids(list(id),list(id)).
190 :- chr_type pragma_type ---> passive(id)
191 ; mpassive(list(id))
192 ; already_in_heads
193 ; already_in_heads(id)
194 ; no_history
195 ; history(history_name,list(id)).
196 :- chr_type history_name== any.
198 :- chr_type rule_name == any.
199 :- chr_type rule_nb == natural.
200 :- chr_type id == natural.
201 :- chr_type occurrence == int.
203 :- chr_type goal == any.
205 :- chr_type store_type ---> default
206 ; multi_store(list(store_type))
207 ; multi_hash(list(list(int)))
208 ; multi_inthash(list(list(int)))
209 ; global_singleton
210 ; global_ground
211 % EXPERIMENTAL STORES
212 ; atomic_constants(list(int),list(any),coverage)
213 ; ground_constants(list(int),list(any),coverage)
214 ; var_assoc_store(int,list(int))
215 ; identifier_store(int)
216 ; type_indexed_identifier_store(int,any).
217 :- chr_type coverage ---> complete ; incomplete.
218 % }}}
219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
221 %------------------------------------------------------------------------------%
222 :- chr_constraint chr_source_file/1.
223 :- chr_option(mode,chr_source_file(+)).
224 :- chr_option(type_declaration,chr_source_file(module_name)).
225 %------------------------------------------------------------------------------%
226 chr_source_file(_) \ chr_source_file(_) <=> true.
228 %------------------------------------------------------------------------------%
229 :- chr_constraint get_chr_source_file/1.
230 :- chr_option(mode,get_chr_source_file(-)).
231 :- chr_option(type_declaration,get_chr_source_file(module_name)).
232 %------------------------------------------------------------------------------%
233 chr_source_file(Mod) \ get_chr_source_file(Query)
234 <=> Query = Mod .
235 get_chr_source_file(Query)
236 <=> Query = user.
239 %------------------------------------------------------------------------------%
240 :- chr_constraint target_module/1.
241 :- chr_option(mode,target_module(+)).
242 :- chr_option(type_declaration,target_module(module_name)).
243 %------------------------------------------------------------------------------%
244 target_module(_) \ target_module(_) <=> true.
246 %------------------------------------------------------------------------------%
247 :- chr_constraint get_target_module/1.
248 :- chr_option(mode,get_target_module(-)).
249 :- chr_option(type_declaration,get_target_module(module_name)).
250 %------------------------------------------------------------------------------%
251 target_module(Mod) \ get_target_module(Query)
252 <=> Query = Mod .
253 get_target_module(Query)
254 <=> Query = user.
256 %------------------------------------------------------------------------------%
257 :- chr_constraint line_number/2.
258 :- chr_option(mode,line_number(+,+)).
259 :- chr_option(type_declaration,line_number(rule_nb,int)).
260 %------------------------------------------------------------------------------%
261 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
263 %------------------------------------------------------------------------------%
264 :- chr_constraint get_line_number/2.
265 :- chr_option(mode,get_line_number(+,-)).
266 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
267 %------------------------------------------------------------------------------%
268 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
269 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
271 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
272 :- chr_option(mode,indexed_argument(+,+)).
273 :- chr_option(type_declaration,indexed_argument(constraint,int)).
275 :- chr_constraint is_indexed_argument/2.
276 :- chr_option(mode,is_indexed_argument(+,+)).
277 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
279 :- chr_constraint constraint_mode/2.
280 :- chr_option(mode,constraint_mode(+,+)).
281 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
283 :- chr_constraint get_constraint_mode/2.
284 :- chr_option(mode,get_constraint_mode(+,-)).
285 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
287 :- chr_constraint may_trigger/1.
288 :- chr_option(mode,may_trigger(+)).
289 :- chr_option(type_declaration,may_trigger(constraint)).
291 :- chr_constraint only_ground_indexed_arguments/1.
292 :- chr_option(mode,only_ground_indexed_arguments(+)).
293 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
295 :- chr_constraint none_suspended_on_variables/0.
297 :- chr_constraint are_none_suspended_on_variables/0.
299 :- chr_constraint store_type/2.
300 :- chr_option(mode,store_type(+,+)).
301 :- chr_option(type_declaration,store_type(constraint,store_type)).
303 :- chr_constraint get_store_type/2.
304 :- chr_option(mode,get_store_type(+,?)).
305 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
307 :- chr_constraint update_store_type/2.
308 :- chr_option(mode,update_store_type(+,+)).
309 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
311 :- chr_constraint actual_store_types/2.
312 :- chr_option(mode,actual_store_types(+,+)).
313 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
315 :- chr_constraint assumed_store_type/2.
316 :- chr_option(mode,assumed_store_type(+,+)).
317 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
319 :- chr_constraint validate_store_type_assumption/1.
320 :- chr_option(mode,validate_store_type_assumption(+)).
321 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
323 :- chr_constraint rule_count/1.
324 :- chr_option(mode,rule_count(+)).
325 :- chr_option(type_declaration,rule_count(natural)).
327 :- chr_constraint inc_rule_count/1.
328 :- chr_option(mode,inc_rule_count(-)).
329 :- chr_option(type_declaration,inc_rule_count(natural)).
331 rule_count(_) \ rule_count(_)
332 <=> true.
333 rule_count(C), inc_rule_count(NC)
334 <=> NC is C + 1, rule_count(NC).
335 inc_rule_count(NC)
336 <=> NC = 1, rule_count(NC).
338 :- chr_constraint passive/2.
339 :- chr_option(mode,passive(+,+)).
340 :- chr_option(type_declaration,passive(rule_nb,id)).
342 :- chr_constraint is_passive/2.
343 :- chr_option(mode,is_passive(+,+)).
344 :- chr_option(type_declaration,is_passive(rule_nb,id)).
346 :- chr_constraint any_passive_head/1.
347 :- chr_option(mode,any_passive_head(+)).
349 :- chr_constraint new_occurrence/4.
350 :- chr_option(mode,new_occurrence(+,+,+,+)).
352 :- chr_constraint occurrence/5.
353 :- chr_option(mode,occurrence(+,+,+,+,+)).
355 :- chr_type occurrence_type ---> simplification ; propagation.
356 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
358 :- chr_constraint get_occurrence/4.
359 :- chr_option(mode,get_occurrence(+,+,-,-)).
361 :- chr_constraint get_occurrence/5.
362 :- chr_option(mode,get_occurrence(+,+,-,-,-)).
364 :- chr_constraint get_occurrence_from_id/4.
365 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
367 :- chr_constraint max_occurrence/2.
368 :- chr_option(mode,max_occurrence(+,+)).
370 :- chr_constraint get_max_occurrence/2.
371 :- chr_option(mode,get_max_occurrence(+,-)).
373 :- chr_constraint allocation_occurrence/2.
374 :- chr_option(mode,allocation_occurrence(+,+)).
376 :- chr_constraint get_allocation_occurrence/2.
377 :- chr_option(mode,get_allocation_occurrence(+,-)).
379 :- chr_constraint rule/2.
380 :- chr_option(mode,rule(+,+)).
381 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
383 :- chr_constraint get_rule/2.
384 :- chr_option(mode,get_rule(+,-)).
385 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
387 :- chr_constraint least_occurrence/2.
388 :- chr_option(mode,least_occurrence(+,+)).
389 :- chr_option(type_declaration,least_occurrence(any,list)).
391 :- chr_constraint is_least_occurrence/1.
392 :- chr_option(mode,is_least_occurrence(+)).
395 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
396 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
397 is_indexed_argument(_,_) <=> fail.
399 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
402 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
403 Q = Mode.
404 get_constraint_mode(FA,Q) <=>
405 FA = _ / N,
406 replicate(N,(?),Q).
408 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
410 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
411 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
412 nth1(I,Mode,M),
413 M \== (+) |
414 is_stored(FA).
415 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
417 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
418 <=>
419 nth1(I,Mode,M),
420 M \== (+)
421 |
422 fail.
423 only_ground_indexed_arguments(_) <=>
424 true.
426 none_suspended_on_variables \ none_suspended_on_variables <=> true.
427 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
428 are_none_suspended_on_variables <=> fail.
429 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
430 % STORE TYPES
431 %
432 % The functionality for inspecting and deciding on the different types of constraint
433 % store / indexes for constraints.
435 store_type(FA,StoreType)
436 ==> chr_pp_flag(verbose,on)
437 |
438 format('The indexes for ~w are:\n',[FA]),
439 format_storetype(StoreType).
440 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
442 format_storetype(multi_store(StoreTypes)) :- !,
443 maplist(format_storetype,StoreTypes).
444 format_storetype(atomic_constants(Index,Constants,_)) :-
445 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
446 format_storetype(ground_constants(Index,Constants,_)) :-
447 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
448 format_storetype(StoreType) :-
449 format('\t* ~w\n',[StoreType]).
452 % 1. Inspection
453 % ~~~~~~~~~~~~~
454 %
455 %
457 get_store_type_normal @
458 store_type(FA,Store) \ get_store_type(FA,Query)
459 <=> Query = Store.
461 get_store_type_assumed @
462 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
463 <=> Query = Store.
465 get_store_type_default @
466 get_store_type(_,Query)
467 <=> Query = default.
469 % 2. Store type registration
470 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
472 actual_store_types(C,STs) \ update_store_type(C,ST)
473 <=> memberchk(ST,STs) | true.
474 update_store_type(C,ST), actual_store_types(C,STs)
475 <=>
476 actual_store_types(C,[ST|STs]).
477 update_store_type(C,ST)
478 <=>
479 actual_store_types(C,[ST]).
481 % 3. Final decision on store types
482 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
485 <=>
486 true % chr_pp_flag(experiment,on)
487 |
488 delete(STs,multi_hash([Index]),STs0),
489 Index = [IndexPos],
490 ( get_constraint_arg_type(C,IndexPos,Type),
491 enumerated_atomic_type(Type,Atoms) ->
492 /* use the type constants rather than the collected keys */
493 Constants = Atoms,
494 Completeness = complete
495 ;
496 Constants = Keys,
497 Completeness = incomplete
498 ),
499 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
500 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
501 <=>
502 true % chr_pp_flag(experiment,on)
503 |
504 ( Index = [IndexPos],
505 get_constraint_arg_type(C,IndexPos,Type),
506 Type = chr_enum(Constants)
507 ->
508 Completeness = complete
509 ;
510 Constants = Constants0,
511 Completeness = incomplete
512 ),
513 delete(STs,multi_hash([Index]),STs0),
514 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
516 get_constraint_arg_type(C,Pos,Type) :-
517 get_constraint_type(C,Types),
518 nth1(Pos,Types,Type0),
519 unalias_type(Type0,Type).
521 validate_store_type_assumption(C) \ actual_store_types(C,STs)
522 <=>
523 % chr_pp_flag(experiment,on),
524 memberchk(multi_hash([[Index]]),STs),
525 get_constraint_type(C,Types),
526 nth1(Index,Types,Type),
527 enumerated_atomic_type(Type,Atoms)
528 |
529 delete(STs,multi_hash([[Index]]),STs0),
530 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
531 validate_store_type_assumption(C) \ actual_store_types(C,STs)
532 <=>
533 memberchk(multi_hash([[Index]]),STs),
534 get_constraint_arg_type(C,Index,Type),
535 Type = chr_enum(Constants)
536 |
537 delete(STs,multi_hash([[Index]]),STs0),
538 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
539 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
540 <=>
541 ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) ->
542 Stores = [global_ground|STs]
543 ;
544 Stores = STs
545 ),
546 store_type(C,multi_store(Stores)).
547 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
548 <=>
549 store_type(C,multi_store(STs)).
550 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
551 <=>
552 chr_pp_flag(debugable,on)
553 |
554 store_type(C,default).
555 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
556 <=> store_type(C,global_ground).
557 validate_store_type_assumption(C)
558 <=> true.
560 partial_store(ground_constants(_,_,incomplete)).
561 partial_store(atomic_constants(_,_,incomplete)).
563 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
564 passive(R,ID) \ passive(R,ID) <=> true.
566 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
567 is_passive(_,_) <=> fail.
569 passive(RuleNb,_) \ any_passive_head(RuleNb)
570 <=> true.
571 any_passive_head(_)
572 <=> fail.
573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
575 max_occurrence(C,N) \ max_occurrence(C,M)
576 <=> N >= M | true.
578 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
579 NO is MO + 1,
580 occurrence(C,NO,RuleNb,ID,Type),
581 max_occurrence(C,NO).
582 new_occurrence(C,RuleNb,ID,_) <=>
583 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
585 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
586 <=> Q = MON.
587 get_max_occurrence(C,Q)
588 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
590 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
591 <=> Rule = QRule, ID = QID.
592 get_occurrence(C,O,_,_)
593 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
595 occurrence(C,ON,Rule,ID,OccType) \ get_occurrence(C,ON,QRule,QID,QOccType)
596 <=> Rule = QRule, ID = QID, OccType = QOccType.
597 get_occurrence(C,O,_,_,_)
598 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
600 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
601 <=> QC = C, QON = ON.
602 get_occurrence_from_id(C,O,_,_)
603 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
605 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
606 % Late allocation
608 late_allocation_analysis(Cs) :-
609 ( chr_pp_flag(late_allocation,on) ->
610 maplist(late_allocation, Cs)
611 ;
612 true
613 ).
615 late_allocation(C) :- late_allocation(C,0).
616 late_allocation(C,O) :- allocation_occurrence(C,O), !.
617 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
619 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
621 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
623 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
624 \+ is_passive(RuleNb,Id),
625 Type == propagation,
626 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
627 true
628 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
629 is_observed(C,O)
630 ; is_least_occurrence(RuleNb) -> % propagation rule
631 is_observed(C,O)
632 ;
633 true
634 ).
636 stored_in_guard_before_next_kept_occurrence(C,O) :-
637 chr_pp_flag(store_in_guards, on),
638 NO is O + 1,
639 stored_in_guard_lookahead(C,NO).
641 :- chr_constraint stored_in_guard_lookahead/2.
642 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
644 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
645 NO is O + 1, stored_in_guard_lookahead(C,NO).
646 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
647 Type == simplification,
648 ( is_stored_in_guard(C,RuleNb) ->
649 true
650 ;
651 NO is O + 1, stored_in_guard_lookahead(C,NO)
652 ).
653 stored_in_guard_lookahead(_,_) <=> fail.
656 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
657 \ least_occurrence(RuleNb,[ID|IDs])
658 <=> AO >= O, \+ may_trigger(C) |
659 least_occurrence(RuleNb,IDs).
660 rule(RuleNb,Rule), passive(RuleNb,ID)
661 \ least_occurrence(RuleNb,[ID|IDs])
662 <=> least_occurrence(RuleNb,IDs).
664 rule(RuleNb,Rule)
665 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
666 least_occurrence(RuleNb,IDs).
668 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
669 <=> true.
670 is_least_occurrence(_)
671 <=> fail.
673 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
674 <=> Q = O.
675 get_allocation_occurrence(_,Q)
676 <=> chr_pp_flag(late_allocation,off), Q=0.
677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
679 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
680 <=> Q = Rule.
681 get_rule(_,_)
682 <=> fail.
684 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
686 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
687 %
688 % Default store constraint index assignment.
690 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
691 :- chr_option(mode,constraint_index(+,+)).
692 :- chr_option(type_declaration,constraint_index(constraint,int)).
694 :- chr_constraint get_constraint_index/2.
695 :- chr_option(mode,get_constraint_index(+,-)).
696 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
698 :- chr_constraint get_indexed_constraint/2.
699 :- chr_option(mode,get_indexed_constraint(+,-)).
700 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
702 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
703 :- chr_option(mode,max_constraint_index(+)).
704 :- chr_option(type_declaration,max_constraint_index(int)).
706 :- chr_constraint get_max_constraint_index/1.
707 :- chr_option(mode,get_max_constraint_index(-)).
708 :- chr_option(type_declaration,get_max_constraint_index(int)).
710 constraint_index(C,Index) \ get_constraint_index(C,Query)
711 <=> Query = Index.
712 get_constraint_index(C,Query)
713 <=> fail.
715 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
716 <=> Q = C.
717 get_indexed_constraint(Index,Q)
718 <=> fail.
720 max_constraint_index(Index) \ get_max_constraint_index(Query)
721 <=> Query = Index.
722 get_max_constraint_index(Query)
723 <=> Query = 0.
725 set_constraint_indices(Constraints) :-
726 set_constraint_indices(Constraints,1).
727 set_constraint_indices([],M) :-
728 N is M - 1,
729 max_constraint_index(N).
730 set_constraint_indices([C|Cs],N) :-
731 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
732 ; get_store_type(C,var_assoc_store(_,_))) ->
733 constraint_index(C,N),
734 M is N + 1,
735 set_constraint_indices(Cs,M)
736 ;
737 set_constraint_indices(Cs,N)
738 ).
740 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
741 % Identifier Indexes
743 :- chr_constraint identifier_size/1.
744 :- chr_option(mode,identifier_size(+)).
745 :- chr_option(type_declaration,identifier_size(natural)).
747 identifier_size(_) \ identifier_size(_)
748 <=>
749 true.
751 :- chr_constraint get_identifier_size/1.
752 :- chr_option(mode,get_identifier_size(-)).
753 :- chr_option(type_declaration,get_identifier_size(natural)).
755 identifier_size(Size) \ get_identifier_size(Q)
756 <=>
757 Q = Size.
759 get_identifier_size(Q)
760 <=>
761 Q = 1.
763 :- chr_constraint identifier_index/3.
764 :- chr_option(mode,identifier_index(+,+,+)).
765 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
767 identifier_index(C,I,_) \ identifier_index(C,I,_)
768 <=>
769 true.
771 :- chr_constraint get_identifier_index/3.
772 :- chr_option(mode,get_identifier_index(+,+,-)).
773 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
775 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
776 <=>
777 Q = II.
778 identifier_size(Size), get_identifier_index(C,I,Q)
779 <=>
780 NSize is Size + 1,
781 identifier_index(C,I,NSize),
782 identifier_size(NSize),
783 Q = NSize.
784 get_identifier_index(C,I,Q)
785 <=>
786 identifier_index(C,I,2),
787 identifier_size(2),
788 Q = 2.
790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
791 % Type Indexed Identifier Indexes
793 :- chr_constraint type_indexed_identifier_size/2.
794 :- chr_option(mode,type_indexed_identifier_size(+,+)).
795 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
797 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
798 <=>
799 true.
801 :- chr_constraint get_type_indexed_identifier_size/2.
802 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
803 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
805 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
806 <=>
807 Q = Size.
809 get_type_indexed_identifier_size(IndexType,Q)
810 <=>
811 Q = 1.
813 :- chr_constraint type_indexed_identifier_index/4.
814 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
815 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
817 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
818 <=>
819 true.
821 :- chr_constraint get_type_indexed_identifier_index/4.
822 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
823 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
825 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
826 <=>
827 Q = II.
828 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
829 <=>
830 NSize is Size + 1,
831 type_indexed_identifier_index(IndexType,C,I,NSize),
832 type_indexed_identifier_size(IndexType,NSize),
833 Q = NSize.
834 get_type_indexed_identifier_index(IndexType,C,I,Q)
835 <=>
836 type_indexed_identifier_index(IndexType,C,I,2),
837 type_indexed_identifier_size(IndexType,2),
838 Q = 2.
840 type_indexed_identifier_structure(IndexType,Structure) :-
841 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
842 get_type_indexed_identifier_size(IndexType,Arity),
843 functor(Structure,Functor,Arity).
844 type_indexed_identifier_name(IndexType,Prefix,Name) :-
845 ( atom(IndexType) ->
846 IndexTypeName = IndexType
847 ;
848 term_to_atom(IndexType,IndexTypeName)
849 ),
850 atom_concat_list([Prefix,'_',IndexTypeName],Name).
852 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
857 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
858 %%
859 %% Translation
861 chr_translate(Declarations,NewDeclarations) :-
862 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
864 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
865 chr_banner,
866 restart_after_flattening(Declarations0,Declarations),
867 init_chr_pp_flags,
868 chr_source_file(File),
869 /* sort out the interesting stuff from the input */
870 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
871 chr_compiler_options:sanity_check,
873 dump_code(Declarations),
875 check_declared_constraints(Constraints0),
876 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
877 add_constraints(Constraints),
878 add_rules(Rules1),
879 generate_never_stored_rules(Constraints,NewRules),
880 add_rules(NewRules),
881 append(Rules1,NewRules,Rules),
882 chr_analysis(Rules,Constraints,Declarations),
883 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
884 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
885 phase_end(validate_store_type_assumptions),
886 used_states_known,
887 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
888 insert_declarations(OtherClauses, Clauses0),
889 chr_module_declaration(CHRModuleDeclaration),
890 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
891 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
892 append([Clauses0,GeneratedClauses], NewDeclarations),
893 dump_code(NewDeclarations),
894 !. /* cut choicepoint of restart_after_flattening */
896 chr_analysis(Rules,Constraints,Declarations) :-
897 maplist(pragma_rule_to_ast_rule,Rules,AstRules),
898 check_rules(Rules,AstRules,Constraints),
899 time('type checking',chr_translate:static_type_check(Rules,AstRules)),
900 /* constants */
901 collect_constants(Rules,AstRules,Constraints,Declarations),
902 add_occurrences(Rules,AstRules),
903 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
904 time('set semantics',chr_translate:set_semantics_rules(Rules)),
905 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
906 time('guard simplification',chr_translate:guard_simplification),
907 time('late storage',chr_translate:storage_analysis(Constraints)),
908 time('observation',chr_translate:observation_analysis(Constraints)),
909 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
910 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
911 partial_wake_analysis,
912 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
913 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
914 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
915 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
917 store_management_preds(Constraints,Clauses) :-
918 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
919 generate_attr_unify_hook(AttrUnifyHookClauses),
920 generate_attach_increment(AttachIncrementClauses),
921 generate_extra_clauses(Constraints,ExtraClauses),
922 generate_insert_delete_constraints(Constraints,DeleteClauses),
923 generate_attach_code(Constraints,StoreClauses),
924 generate_counter_code(CounterClauses),
925 generate_dynamic_type_check_clauses(TypeCheckClauses),
926 append([AttachAConstraintClauses
927 ,AttachIncrementClauses
928 ,AttrUnifyHookClauses
929 ,ExtraClauses
930 ,DeleteClauses
931 ,StoreClauses
932 ,CounterClauses
933 ,TypeCheckClauses
934 ]
935 ,Clauses).
938 insert_declarations(Clauses0, Clauses) :-
939 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
940 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
942 auxiliary_module(chr_hashtable_store).
943 auxiliary_module(chr_integertable_store).
944 auxiliary_module(chr_assoc_store).
946 generate_counter_code(Clauses) :-
947 ( chr_pp_flag(store_counter,on) ->
948 Clauses = [
949 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
950 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
951 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
952 (:- '$counter_init'('$insert_counter')),
953 (:- '$counter_init'('$delete_counter')),
954 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
955 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
956 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
957 ]
958 ;
959 Clauses = []
960 ).
962 % for systems with multifile declaration
963 chr_module_declaration(CHRModuleDeclaration) :-
964 get_target_module(Mod),
965 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
966 CHRModuleDeclaration = [
967 (:- multifile chr:'$chr_module'/1),
968 chr:'$chr_module'(Mod)
969 ]
970 ;
971 CHRModuleDeclaration = []
972 ).
975 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
976 %%
977 %% Partitioning of clauses into constraint declarations, chr rules and other
978 %% clauses
980 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
981 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
982 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
983 partition_clauses([],[],[],[]).
984 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
985 ( parse_rule(Clause,Rule) ->
986 ConstraintDeclarations = RestConstraintDeclarations,
987 Rules = [Rule|RestRules],
988 OtherClauses = RestOtherClauses
989 ; is_declaration(Clause,ConstraintDeclaration) ->
990 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
991 Rules = RestRules,
992 OtherClauses = RestOtherClauses
993 ; is_module_declaration(Clause,Mod) ->
994 target_module(Mod),
995 ConstraintDeclarations = RestConstraintDeclarations,
996 Rules = RestRules,
997 OtherClauses = [Clause|RestOtherClauses]
998 ; is_type_definition(Clause) ->
999 ConstraintDeclarations = RestConstraintDeclarations,
1000 Rules = RestRules,
1001 OtherClauses = RestOtherClauses
1002 ; is_chr_declaration(Clause) ->
1003 ConstraintDeclarations = RestConstraintDeclarations,
1004 Rules = RestRules,
1005 OtherClauses = RestOtherClauses
1006 ; Clause = (handler _) ->
1007 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
1008 ConstraintDeclarations = RestConstraintDeclarations,
1009 Rules = RestRules,
1010 OtherClauses = RestOtherClauses
1011 ; Clause = (rules _) ->
1012 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1013 ConstraintDeclarations = RestConstraintDeclarations,
1014 Rules = RestRules,
1015 OtherClauses = RestOtherClauses
1016 ; Clause = option(OptionName,OptionValue) ->
1017 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1018 handle_option(OptionName,OptionValue),
1019 ConstraintDeclarations = RestConstraintDeclarations,
1020 Rules = RestRules,
1021 OtherClauses = RestOtherClauses
1022 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1023 handle_option(OptionName,OptionValue),
1024 ConstraintDeclarations = RestConstraintDeclarations,
1025 Rules = RestRules,
1026 OtherClauses = RestOtherClauses
1027 ; Clause = ('$chr_compiled_with_version'(_)) ->
1028 ConstraintDeclarations = RestConstraintDeclarations,
1029 Rules = RestRules,
1030 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1031 ; ConstraintDeclarations = RestConstraintDeclarations,
1032 Rules = RestRules,
1033 OtherClauses = [Clause|RestOtherClauses]
1034 ),
1035 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1037 '$chr_compiled_with_version'(2).
1039 is_declaration(D, Constraints) :- %% constraint declaration
1040 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1041 conj2list(Cs,Constraints0)
1042 ;
1043 ( D = (:- Decl) ->
1044 Decl =.. [constraints,Cs]
1045 ;
1046 D =.. [constraints,Cs]
1047 ),
1048 conj2list(Cs,Constraints0),
1049 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1050 ),
1051 extract_type_mode(Constraints0,Constraints).
1053 extract_type_mode([],[]).
1054 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1055 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1056 ( C0 = C # Annotation ->
1057 functor(C,F,A),
1058 extract_annotation(Annotation,F/A)
1059 ;
1060 C0 = C,
1061 functor(C,F,A)
1062 ),
1063 ConstraintSymbol = F/A,
1064 C =.. [_|Args],
1065 extract_types_and_modes(Args,ArgTypes,ArgModes),
1066 assert_constraint_type(ConstraintSymbol,ArgTypes),
1067 constraint_mode(ConstraintSymbol,ArgModes),
1068 extract_type_mode(R,R2).
1070 extract_annotation(stored,Symbol) :-
1071 stored_assertion(Symbol).
1072 extract_annotation(default(Goal),Symbol) :-
1073 never_stored_default(Symbol,Goal).
1075 extract_types_and_modes([],[],[]).
1076 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1077 extract_type_and_mode(X,T,M),
1078 extract_types_and_modes(R,R2,R3).
1080 extract_type_and_mode(+(T),T,(+)) :- !.
1081 extract_type_and_mode(?(T),T,(?)) :- !.
1082 extract_type_and_mode(-(T),T,(-)) :- !.
1083 extract_type_and_mode((+),any,(+)) :- !.
1084 extract_type_and_mode((?),any,(?)) :- !.
1085 extract_type_and_mode((-),any,(-)) :- !.
1086 extract_type_and_mode(Illegal,_,_) :-
1087 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1089 is_chr_declaration(Declaration) :-
1090 Declaration = (:- chr_declaration Decl),
1091 ( Decl = (Pattern ---> Information) ->
1092 background_info(Pattern,Information)
1093 ; Decl = Information ->
1094 background_info([Information])
1095 ).
1096 is_type_definition(Declaration) :-
1097 is_type_definition(Declaration,Result),
1098 assert_type_definition(Result).
1100 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1101 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1103 is_type_definition(Declaration,Result) :-
1104 ( Declaration = (:- TDef) ->
1105 true
1106 ;
1107 Declaration = TDef
1108 ),
1109 TDef =.. [chr_type,TypeDef],
1110 ( TypeDef = (Name ---> Def) ->
1111 tdisj2list(Def,DefList),
1112 Result = typedef(Name,DefList)
1113 ; TypeDef = (Alias == Name) ->
1114 Result = alias(Alias,Name)
1115 ;
1116 Result = typedef(TypeDef,[]),
1117 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1118 ).
1120 %% tdisj2list(+Goal,-ListOfGoals) is det.
1121 %
1122 % no removal of fails, e.g. :- type bool ---> true ; fail.
1123 tdisj2list(Conj,L) :-
1124 tdisj2list(Conj,L,[]).
1126 tdisj2list(Conj,L,T) :-
1127 Conj = (G1;G2), !,
1128 tdisj2list(G1,L,T1),
1129 tdisj2list(G2,T1,T).
1130 tdisj2list(G,[G | T],T).
1133 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1134 %% parse_rule(+term,-pragma_rule) is semidet.
1135 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1136 parse_rule(RI,R) :- %% name @ rule
1137 RI = (Name @ RI2), !,
1138 rule(RI2,yes(Name),R).
1139 parse_rule(RI,R) :-
1140 rule(RI,no,R).
1142 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1143 %% parse_rule(+term,-pragma_rule) is semidet.
1144 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1145 rule(RI,Name,R) :-
1146 RI = (RI2 pragma P), !, %% pragmas
1147 ( var(P) ->
1148 Ps = [_] % intercept variable
1149 ;
1150 conj2list(P,Ps)
1151 ),
1152 inc_rule_count(RuleCount),
1153 R = pragma(R1,IDs,Ps,Name,RuleCount),
1154 is_rule(RI2,R1,IDs,R).
1155 rule(RI,Name,R) :-
1156 inc_rule_count(RuleCount),
1157 R = pragma(R1,IDs,[],Name,RuleCount),
1158 is_rule(RI,R1,IDs,R).
1160 is_rule(RI,R,IDs,RC) :- %% propagation rule
1161 RI = (H ==> B), !,
1162 conj2list(H,Head2i),
1163 get_ids(Head2i,IDs2,Head2,RC),
1164 IDs = ids([],IDs2),
1165 ( B = (G | RB) ->
1166 R = rule([],Head2,G,RB)
1167 ;
1168 R = rule([],Head2,true,B)
1169 ).
1170 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1171 RI = (H <=> B), !,
1172 ( B = (G | RB) ->
1173 Guard = G,
1174 Body = RB
1175 ; Guard = true,
1176 Body = B
1177 ),
1178 ( H = (H1 \ H2) ->
1179 conj2list(H1,Head2i),
1180 conj2list(H2,Head1i),
1181 get_ids(Head2i,IDs2,Head2,0,N,RC),
1182 get_ids(Head1i,IDs1,Head1,N,_,RC),
1183 IDs = ids(IDs1,IDs2)
1184 ; conj2list(H,Head1i),
1185 Head2 = [],
1186 get_ids(Head1i,IDs1,Head1,RC),
1187 IDs = ids(IDs1,[])
1188 ),
1189 R = rule(Head1,Head2,Guard,Body).
1191 get_ids(Cs,IDs,NCs,RC) :-
1192 get_ids(Cs,IDs,NCs,0,_,RC).
1194 get_ids([],[],[],N,N,_).
1195 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1196 ( C = (NC # N1) ->
1197 ( var(N1) ->
1198 N1 = N
1199 ;
1200 check_direct_pragma(N1,N,RC)
1201 )
1202 ;
1203 NC = C
1204 ),
1205 M is N + 1,
1206 get_ids(Cs,IDs,NCs, M,NN,RC).
1208 check_direct_pragma(passive,Id,PragmaRule) :- !,
1209 PragmaRule = pragma(_,_,_,_,RuleNb),
1210 passive(RuleNb,Id).
1211 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1212 ( direct_pragma(FullPragma),
1213 atom_concat(Abbrev,Remainder,FullPragma) ->
1214 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1215 ;
1216 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1217 ).
1219 direct_pragma(passive).
1221 is_module_declaration((:- module(Mod)),Mod).
1222 is_module_declaration((:- module(Mod,_)),Mod).
1224 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1226 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1227 % Add constraints
1228 add_constraints([]).
1229 add_constraints([C|Cs]) :-
1230 max_occurrence(C,0),
1231 C = _/A,
1232 length(Mode,A),
1233 set_elems(Mode,?),
1234 constraint_mode(C,Mode),
1235 add_constraints(Cs).
1237 % Add rules
1238 add_rules([]).
1239 add_rules([Rule|Rules]) :-
1240 Rule = pragma(_,_,_,_,RuleNb),
1241 rule(RuleNb,Rule),
1242 add_rules(Rules).
1244 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1246 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1247 %% Some input verification:
1249 check_declared_constraints(Constraints) :-
1250 tree_set_empty(Acc),
1251 check_declared_constraints(Constraints,Acc).
1253 check_declared_constraints([],_).
1254 check_declared_constraints([C|Cs],Acc) :-
1255 ( tree_set_memberchk(C,Acc) ->
1256 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1257 ;
1258 true
1259 ),
1260 tree_set_add(Acc,C,NAcc),
1261 check_declared_constraints(Cs,NAcc).
1263 %% - all constraints in heads are declared constraints
1264 %% - all passive pragmas refer to actual head constraints
1266 check_rules(PragmaRules,AstRules,Decls) :-
1267 maplist(check_rule(Decls),PragmaRules,AstRules).
1269 check_rule(Decls,PragmaRule,AstRule) :-
1270 PragmaRule = pragma(_Rule,_IDs,Pragmas,_Name,_N),
1271 check_ast_rule_indexing(AstRule,PragmaRule),
1272 % check_rule_indexing(PragmaRule),
1273 check_ast_trivial_propagation_rule(AstRule,PragmaRule),
1274 % check_trivial_propagation_rule(PragmaRule),
1275 check_ast_head_constraints(AstRule,Decls,PragmaRule),
1276 % Rule = rule(H1,H2,_,_),
1277 % check_head_constraints(H1,Decls,PragmaRule),
1278 % check_head_constraints(H2,Decls,PragmaRule),
1279 check_pragmas(Pragmas,PragmaRule).
1281 %-------------------------------------------------------------------------------
1282 % Make all heads passive in trivial propagation rule
1283 % ... ==> ... | true.
1284 check_ast_trivial_propagation_rule(AstRule,PragmaRule) :-
1285 AstRule = ast_rule(AstHead,_,_,AstBody,_),
1286 ( AstHead = propagation(_),
1287 Body == [] ->
1288 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1289 set_rule_passive(PragmaRule)
1290 ;
1291 true
1292 ).
1294 set_rule_passive(PragmaRule) :-
1295 PragmaRule = pragma(_Rule,_IDs,_Pragmas,_Name,RuleNb),
1296 set_all_passive(RuleNb).
1298 check_trivial_propagation_rule(PragmaRule) :-
1299 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1300 ( Rule = rule([],_,_,true) ->
1301 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1302 set_all_passive(RuleNb)
1303 ;
1304 true
1305 ).
1307 %-------------------------------------------------------------------------------
1308 check_ast_head_constraints(ast_rule(AstHead,_,_,_,_),Decls,PragmaRule) :-
1309 check_ast_head_constraints_(AstHead,Decls,PragmaRule).
1311 check_ast_head_constraints_(simplification(AstConstraints),Decls,PragmaRule) :-
1312 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints).
1313 check_ast_head_constraints_(propagation(AstConstraints),Decls,PragmaRule) :-
1314 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints).
1315 check_ast_head_constraints_(simpagation(AstConstraints1,AstConstraints2),Decls,PragmaRule) :-
1316 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints1).
1317 maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints2).
1319 check_ast_head_constraint(Decls,PragmaRule,chr_constraint(Symbol,_,Constraint)) :-
1320 ( memberchk(Symbol,Decls) ->
1321 true
1322 ;
1323 chr_error(syntax(Constraint),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1324 ).
1326 check_head_constraints([],_,_).
1327 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1328 functor(Constr,F,A),
1329 ( memberchk(F/A,Decls) ->
1330 check_head_constraints(Rest,Decls,PragmaRule)
1331 ;
1332 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1333 ).
1334 %-------------------------------------------------------------------------------
1336 check_pragmas([],_).
1337 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1338 check_pragma(Pragma,PragmaRule),
1339 check_pragmas(Pragmas,PragmaRule).
1341 check_pragma(Pragma,PragmaRule) :-
1342 var(Pragma), !,
1343 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1344 check_pragma(passive(ID), PragmaRule) :-
1345 !,
1346 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1347 ( memberchk_eq(ID,IDs1) ->
1348 true
1349 ; memberchk_eq(ID,IDs2) ->
1350 true
1351 ;
1352 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1353 ),
1354 passive(RuleNb,ID).
1356 check_pragma(mpassive(IDs), PragmaRule) :-
1357 !,
1358 PragmaRule = pragma(_,_,_,_,RuleNb),
1359 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1360 maplist(passive(RuleNb),IDs).
1362 check_pragma(Pragma, PragmaRule) :-
1363 Pragma = already_in_heads,
1364 !,
1365 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1367 check_pragma(Pragma, PragmaRule) :-
1368 Pragma = already_in_head(_),
1369 !,
1370 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1372 check_pragma(Pragma, PragmaRule) :-
1373 Pragma = no_history,
1374 !,
1375 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1376 PragmaRule = pragma(_,_,_,_,N),
1377 no_history(N).
1379 check_pragma(Pragma, PragmaRule) :-
1380 Pragma = history(HistoryName,IDs),
1381 !,
1382 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1383 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1384 ( IDs1 \== [] ->
1385 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1386 ; \+ atom(HistoryName) ->
1387 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1388 ; \+ is_set(IDs) ->
1389 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1390 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1391 history(RuleNb,HistoryName,IDs)
1392 ;
1393 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1394 ).
1395 check_pragma(Pragma,PragmaRule) :-
1396 Pragma = line_number(LineNumber),
1397 !,
1398 PragmaRule = pragma(_,_,_,_,RuleNb),
1399 line_number(RuleNb,LineNumber).
1401 check_history_pragma_ids([], _, _).
1402 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1403 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1404 check_history_pragma_ids(IDs,IDs1,IDs2).
1406 check_pragma(Pragma,PragmaRule) :-
1407 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1409 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1410 %% no_history(+RuleNb) is det.
1411 :- chr_constraint no_history/1.
1412 :- chr_option(mode,no_history(+)).
1413 :- chr_option(type_declaration,no_history(int)).
1415 %% has_no_history(+RuleNb) is semidet.
1416 :- chr_constraint has_no_history/1.
1417 :- chr_option(mode,has_no_history(+)).
1418 :- chr_option(type_declaration,has_no_history(int)).
1420 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1421 has_no_history(_) <=> fail.
1423 :- chr_constraint history/3.
1424 :- chr_option(mode,history(+,+,+)).
1425 :- chr_option(type_declaration,history(any,any,list)).
1427 :- chr_constraint named_history/3.
1429 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1430 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1432 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1433 length(IDs1,L1), length(IDs2,L2),
1434 ( L1 \== L2 ->
1435 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1436 ;
1437 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1438 ).
1440 test_named_history_id_pairs(_, [], _, []).
1441 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1442 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1443 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1445 :- chr_constraint test_named_history_id_pair/4.
1446 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1448 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1449 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1450 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1451 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1453 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1454 named_history(_,_,_) <=> fail.
1456 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1459 format_rule(PragmaRule) :-
1460 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1461 ( MaybeName = yes(Name) ->
1462 write('rule '), write(Name)
1463 ;
1464 write('rule number '), write(RuleNumber)
1465 ),
1466 get_line_number(RuleNumber,LineNumber),
1467 write(' (line '),
1468 write(LineNumber),
1469 write(')').
1471 check_ast_rule_indexing(AstRule,PragmaRule) :-
1472 AstRule = ast_rule(AstHead,AstGuard,_,_,_),
1473 tree_set_empty(EmptyVarSet),
1474 ast_head_variables(AstHead,EmptyVarSet,VarSet),
1475 ast_remove_anti_monotonic_guards(AstGuard,VarSet,MonotonicAstGuard),
1476 ast_term_list_variables(MonotonicAstGuard,EmptyVarSet,GuardVarSet),
1477 check_ast_head_indexing(AstHead,GuardVarSet),
1478 % check_indexing(H1,NG-H2),
1479 % check_indexing(H2,NG-H1),
1480 % EXPERIMENT
1481 ( chr_pp_flag(term_indexing,on) ->
1482 PragmaRule = pragma(Rule,_,_,_,_),
1483 Rule = rule(H1,H2,G,_),
1484 term_variables(H1-H2,HeadVars),
1485 remove_anti_monotonic_guards(G,HeadVars,NG),
1486 term_variables(NG,GuardVariables),
1487 append(H1,H2,Heads),
1488 check_specs_indexing(Heads,GuardVariables,Specs)
1489 ;
1490 true
1491 ).
1493 check_ast_head_indexing(simplification(H1),VarSet) :-
1494 check_ast_indexing(H1,VarSet).
1495 check_ast_head_indexing(propagation(H2),VarSet) :-
1496 check_ast_indexing(H2,VarSet).
1497 check_ast_head_indexing(simpagation(H1,H2),VarSet) :-
1498 ast_constraint_list_variables(H2,VarSet,VarSet1),
1499 check_ast_indexing(H1,VarSet1),
1500 ast_constraint_list_variables(H1,VarSet,VarSet2),
1501 check_ast_indexing(H2,VarSet2).
1503 check_rule_indexing(PragmaRule) :-
1504 PragmaRule = pragma(Rule,_,_,_,_),
1505 Rule = rule(H1,H2,G,_),
1506 term_variables(H1-H2,HeadVars),
1507 remove_anti_monotonic_guards(G,HeadVars,NG),
1508 check_indexing(H1,NG-H2),
1509 check_indexing(H2,NG-H1),
1510 % EXPERIMENT
1511 ( chr_pp_flag(term_indexing,on) ->
1512 term_variables(NG,GuardVariables),
1513 append(H1,H2,Heads),
1514 check_specs_indexing(Heads,GuardVariables,Specs)
1515 ;
1516 true
1517 ).
1519 :- chr_constraint indexing_spec/2.
1520 :- chr_option(mode,indexing_spec(+,+)).
1522 :- chr_constraint get_indexing_spec/2.
1523 :- chr_option(mode,get_indexing_spec(+,-)).
1526 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1527 get_indexing_spec(_,Spec) <=> Spec = [].
1529 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1530 <=>
1531 append(Specs1,Specs2,Specs),
1532 indexing_spec(FA,Specs).
1534 remove_anti_monotonic_guards(G,Vars,NG) :-
1535 conj2list(G,GL),
1536 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1537 list2conj(NGL,NG).
1539 remove_anti_monotonic_guard_list([],_,[]).
1540 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1541 ( G = var(X), memberchk_eq(X,Vars) ->
1542 NGs = RGs
1543 ;
1544 NGs = [G|RGs]
1545 ),
1546 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1548 ast_remove_anti_monotonic_guards([],_,[]).
1549 ast_remove_anti_monotonic_guards([G|Gs],VarSet,NGs) :-
1550 ( G = compound(var,1,[X],_),
1551 ast_var_memberchk(X,VarSet) ->
1552 NGs = RGs
1553 ;
1554 NGs = [G|RGs]
1555 ),
1556 ast_remove_anti_monotonic_guards(Gs,VarSet,RGs).
1557 %-------------------------------------------------------------------------------
1559 check_ast_indexing([],_).
1560 check_ast_indexing([Head|Heads],VarSet) :-
1561 Head = chr_constraint(Symbol,Args,_Constraint),
1562 ast_constraint_list_variables(Heads,VarSet,VarSet1),
1563 check_ast_indexing(Args,1,Symbol,VarSet1),
1564 ast_constraint_variables(Head,VarSet,NVarSet),
1565 check_ast_indexing(Heads,NVarSet).
1567 check_ast_indexing([],_,_,_).
1568 check_ast_indexing([Arg|Args],I,Symbol,VarSet) :-
1569 ( is_indexed_argument(Symbol,I) ->
1570 true
1571 ; ast_nonvar(Arg) ->
1572 indexed_argument(Symbol,I)
1573 ; % ast_var(Arg) ->
1574 ast_term_list_variables(Args,VarSet,VarSet1),
1575 ( ast_var_memberchk(Arg,VarSet1) ->
1576 indexed_argument(Symbol,I)
1577 ;
1578 true
1579 )
1580 ),
1581 J is I + 1,
1582 ast_term_variables(Arg,VarSet,NVarSet),
1583 check_ast_indexing(Args,J,Symbol,NVarSet).
1585 % check_indexing(list(chr_constraint),variables)
1586 check_indexing([],_).
1587 check_indexing([Head|Heads],Other) :-
1588 functor(Head,F,A),
1589 Head =.. [_|Args],
1590 term_variables(Heads-Other,OtherVars),
1591 check_indexing(Args,1,F/A,OtherVars),
1592 check_indexing(Heads,[Head|Other]).
1594 check_indexing([],_,_,_).
1595 check_indexing([Arg|Args],I,FA,OtherVars) :-
1596 ( is_indexed_argument(FA,I) ->
1597 true
1598 ; nonvar(Arg) ->
1599 indexed_argument(FA,I)
1600 ; % var(Arg) ->
1601 term_variables(Args,ArgsVars),
1602 append(ArgsVars,OtherVars,RestVars),
1603 ( memberchk_eq(Arg,RestVars) ->
1604 indexed_argument(FA,I)
1605 ;
1606 true
1607 )
1608 ),
1609 J is I + 1,
1610 term_variables(Arg,NVars),
1611 append(NVars,OtherVars,NOtherVars),
1612 check_indexing(Args,J,FA,NOtherVars).
1613 %-------------------------------------------------------------------------------
1615 check_specs_indexing([],_,[]).
1616 check_specs_indexing([Head|Heads],Variables,Specs) :-
1617 Specs = [Spec|RSpecs],
1618 term_variables(Heads,OtherVariables,Variables),
1619 check_spec_indexing(Head,OtherVariables,Spec),
1620 term_variables(Head,NVariables,Variables),
1621 check_specs_indexing(Heads,NVariables,RSpecs).
1623 check_spec_indexing(Head,OtherVariables,Spec) :-
1624 functor(Head,F,A),
1625 Spec = spec(F,A,ArgSpecs),
1626 Head =.. [_|Args],
1627 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1628 indexing_spec(F/A,[ArgSpecs]).
1630 check_args_spec_indexing([],_,_,[]).
1631 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1632 term_variables(Args,Variables,OtherVariables),
1633 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1634 ArgSpecs = [ArgSpec|RArgSpecs]
1635 ;
1636 ArgSpecs = RArgSpecs
1637 ),
1638 J is I + 1,
1639 term_variables(Arg,NOtherVariables,OtherVariables),
1640 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1642 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1643 ( var(Arg) ->
1644 memberchk_eq(Arg,Variables),
1645 ArgSpec = specinfo(I,any,[])
1646 ;
1647 functor(Arg,F,A),
1648 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1649 Arg =.. [_|Args],
1650 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1651 ).
1653 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1655 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1656 % Occurrences
1658 add_occurrences(PragmaRules,AstRules) :-
1659 maplist(add_rule_occurrences,PragmaRules,AstRules).
1661 add_rule_occurrences(PragmaRule,AstRule) :-
1662 PragmaRule = pragma(_,IDs,_,_,Nb),
1663 AstRule = ast_rule(AstHead,_,_,_,_),
1664 add_head_occurrences(AstHead,IDs,Nb).
1666 add_head_occurrences(simplification(H1),ids(IDs1,_),Nb) :-
1667 maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1).
1668 add_head_occurrences(propagation(H2),ids(_,IDs2),Nb) :-
1669 maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2).
1670 add_head_occurrences(simpagation(H1,H2),ids(IDs1,IDs2),Nb) :-
1671 maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1),
1672 maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2).
1674 add_constraint_occurrence(Nb,OccType,Constraint,ID) :-
1675 Constraint = chr_constraint(Symbol,_,_),
1676 new_occurrence(Symbol,Nb,ID,OccType).
1678 % add_occurrences([],[]).
1679 % add_occurrences([Rule|Rules],[]) :-
1680 % Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1681 % add_occurrences(H1,IDs1,simplification,Nb),
1682 % add_occurrences(H2,IDs2,propagation,Nb),
1683 % add_occurrences(Rules).
1684 %
1685 % add_occurrences([],[],_,_).
1686 % add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1687 % functor(H,F,A),
1688 % FA = F/A,
1689 % new_occurrence(FA,RuleNb,ID,Type),
1690 % add_occurrences(Hs,IDs,Type,RuleNb).
1692 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1694 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1695 % Observation Analysis
1696 %
1697 % CLASSIFICATION
1698 %
1699 %
1700 %
1701 %
1702 %
1703 %
1705 :- chr_constraint observation_analysis/1.
1706 :- chr_option(mode, observation_analysis(+)).
1708 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1709 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1710 ( chr_pp_flag(store_in_guards, on) ->
1711 observation_analysis(RuleNb, Guard, guard, Cs)
1712 ;
1713 true
1714 ),
1715 observation_analysis(RuleNb, Body, body, Cs)
1717 pragma passive(Id).
1718 observation_analysis(_) <=> true.
1720 observation_analysis(RuleNb, Term, GB, Cs) :-
1721 ( all_spawned(RuleNb,GB) ->
1722 true
1723 ; var(Term) ->
1724 spawns_all(RuleNb,GB)
1725 ; Term = true ->
1726 true
1727 ; Term = fail ->
1728 true
1729 ; Term = '!' ->
1730 true
1731 ; Term = (T1,T2) ->
1732 observation_analysis(RuleNb,T1,GB,Cs),
1733 observation_analysis(RuleNb,T2,GB,Cs)
1734 ; Term = (T1;T2) ->
1735 observation_analysis(RuleNb,T1,GB,Cs),
1736 observation_analysis(RuleNb,T2,GB,Cs)
1737 ; Term = (T1->T2) ->
1738 observation_analysis(RuleNb,T1,GB,Cs),
1739 observation_analysis(RuleNb,T2,GB,Cs)
1740 ; Term = (\+ T) ->
1741 observation_analysis(RuleNb,T,GB,Cs)
1742 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1743 spawns(RuleNb,GB,F/A)
1744 ; Term = (_ = _) ->
1745 spawns_all_triggers(RuleNb,GB)
1746 ; Term = (_ is _) ->
1747 spawns_all_triggers(RuleNb,GB)
1748 ; builtin_binds_b(Term,Vars) ->
1749 ( Vars == [] ->
1750 true
1751 ;
1752 spawns_all_triggers(RuleNb,GB)
1753 )
1754 ;
1755 spawns_all(RuleNb,GB)
1756 ).
1758 :- chr_constraint spawns/3.
1759 :- chr_option(mode, spawns(+,+,+)).
1760 :- chr_type spawns_type ---> guard ; body.
1761 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1763 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1764 :- chr_option(mode, spawns_all(+,+)).
1765 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1766 :- chr_option(mode, spawns_all_triggers(+,+)).
1767 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1769 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1770 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1771 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1772 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1773 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1774 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1776 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1777 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1778 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1779 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1781 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1782 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1784 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1785 \
1786 spawns(RuleNb1,GB,C1)
1787 <=>
1788 \+ is_passive(RuleNb2,O)
1789 |
1790 spawns_all(RuleNb1,GB)
1791 pragma
1792 passive(Id).
1794 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1795 ==>
1796 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1797 \+ is_passive(RuleNb2,O), may_trigger(C1)
1798 |
1799 spawns_all_triggers_implies_spawns_all
1800 pragma
1801 passive(Id).
1803 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1804 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1805 spawns_all_triggers_implies_spawns_all \
1806 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1808 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1809 \
1810 spawns(RuleNb1,GB,C1)
1811 <=>
1812 may_trigger(C1),
1813 \+ is_passive(RuleNb2,O)
1814 |
1815 spawns_all_triggers(RuleNb1,GB)
1816 pragma
1817 passive(Id).
1819 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1820 spawns(RuleNb1,GB,C1)
1821 ==>
1822 \+ may_trigger(C1),
1823 \+ is_passive(RuleNb2,O)
1824 |
1825 spawns_all_triggers(RuleNb1,GB)
1826 pragma
1827 passive(Id).
1829 % a bit dangerous this rule: could start propagating too much too soon?
1830 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1831 spawns(RuleNb1,GB,C1)
1832 ==>
1833 RuleNb1 \== RuleNb2, C1 \== C2,
1834 \+ is_passive(RuleNb2,O)
1835 |
1836 spawns(RuleNb1,GB,C2)
1837 pragma
1838 passive(Id).
1840 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1841 spawns_all_triggers(RuleNb1,GB)
1842 ==>
1843 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1844 |
1845 spawns(RuleNb1,GB,C2)
1846 pragma
1847 passive(Id).
1850 :- chr_constraint all_spawned/2.
1851 :- chr_option(mode, all_spawned(+,+)).
1852 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1853 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1854 all_spawned(RuleNb,GB) <=> fail.
1857 % Overview of the supported queries:
1858 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1859 % only succeeds if the occurrence is observed by the
1860 % guard resp. body (depending on the last argument) of its rule
1861 % is_observed(+functor/artiy, +occurrence_number, -)
1862 % succeeds if the occurrence is observed by either the guard or
1863 % the body of its rule
1864 % NOTE: the last argument is NOT bound by this query
1865 %
1866 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1867 % succeeds if the given constraint is observed by the given
1868 % guard resp. body
1869 % do_is_observed(+functor/artiy,+rule_number)
1870 % succeeds if the given constraint is observed by the given
1871 % rule (either its guard or its body)
1874 is_observed(C,O) :-
1875 is_observed(C,O,_),
1876 ai_is_observed(C,O).
1878 is_stored_in_guard(C,RuleNb) :-
1879 chr_pp_flag(store_in_guards, on),
1880 do_is_observed(C,RuleNb,guard).
1882 :- chr_constraint is_observed/3.
1883 :- chr_option(mode, is_observed(+,+,+)).
1884 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1885 is_observed(_,_,_) <=> fail. % this will not happen in practice
1888 :- chr_constraint do_is_observed/3.
1889 :- chr_option(mode, do_is_observed(+,+,?)).
1890 :- chr_constraint do_is_observed/2.
1891 :- chr_option(mode, do_is_observed(+,+)).
1893 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1895 % (1) spawns_all
1896 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1897 % and some non-passive occurrence of some (possibly other) constraint
1898 % exists in a rule (could be same rule) with at least one occurrence of C
1900 spawns_all(RuleNb,GB),
1901 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1902 \
1903 do_is_observed(C,RuleNb,GB)
1904 <=>
1905 \+ is_passive(RuleNb2,O)
1906 |
1907 true.
1909 spawns_all(RuleNb,_),
1910 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1911 \
1912 do_is_observed(C,RuleNb)
1913 <=>
1914 \+ is_passive(RuleNb2,O)
1915 |
1916 true.
1918 % (2) spawns
1919 % a constraint C is observed if the GB of the rule it occurs in spawns a
1920 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1921 % as an occurrence of C
1923 spawns(RuleNb,GB,C2),
1924 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1925 \
1926 do_is_observed(C,RuleNb,GB)
1927 <=>
1928 \+ is_passive(RuleNb2,O)
1929 |
1930 true.
1932 spawns(RuleNb,_,C2),
1933 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1934 \
1935 do_is_observed(C,RuleNb)
1936 <=>
1937 \+ is_passive(RuleNb2,O)
1938 |
1939 true.
1941 % (3) spawns_all_triggers
1942 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1943 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1944 % exists in a rule (could be same rule) with at least one occurrence of C
1946 spawns_all_triggers(RuleNb,GB),
1947 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1948 \
1949 do_is_observed(C,RuleNb,GB)
1950 <=>
1951 \+ is_passive(RuleNb2,O), may_trigger(C2)
1952 |
1953 true.
1955 spawns_all_triggers(RuleNb,_),
1956 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1957 \
1958 do_is_observed(C,RuleNb)
1959 <=>
1960 \+ is_passive(RuleNb2,O), may_trigger(C2)
1961 |
1962 true.
1964 % (4) conservativeness
1965 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1966 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1971 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1973 %%
1974 %% Generated predicates
1975 %% attach_$CONSTRAINT
1976 %% attach_increment
1977 %% detach_$CONSTRAINT
1978 %% attr_unify_hook
1980 %% attach_$CONSTRAINT
1981 generate_attach_detach_a_constraint_all([],[]).
1982 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1983 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1984 generate_attach_a_constraint(Constraint,Clauses1),
1985 generate_detach_a_constraint(Constraint,Clauses2)
1986 ;
1987 Clauses1 = [],
1988 Clauses2 = []
1989 ),
1990 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1991 append([Clauses1,Clauses2,Clauses3],Clauses).
1993 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1994 generate_attach_a_constraint_nil(Constraint,Clause1),
1995 generate_attach_a_constraint_cons(Constraint,Clause2).
1997 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1998 make_name('attach_',FA,Name),
1999 Atom =.. [Name,Vars,Susp].
2001 generate_attach_a_constraint_nil(FA,Clause) :-
2002 Clause = (Head :- true),
2003 attach_constraint_atom(FA,[],_,Head).
2005 generate_attach_a_constraint_cons(FA,Clause) :-
2006 Clause = (Head :- Body),
2007 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
2008 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
2009 Body = ( AttachBody, Subscribe, RecursiveCall ),
2010 get_max_constraint_index(N),
2011 ( N == 1 ->
2012 generate_attach_body_1(FA,Var,Susp,AttachBody)
2013 ;
2014 generate_attach_body_n(FA,Var,Susp,AttachBody)
2015 ),
2016 % SWI-Prolog specific code
2017 chr_pp_flag(solver_events,NMod),
2018 ( NMod \== none ->
2019 Args = [[Var|_],Susp],
2020 get_target_module(Mod),
2021 use_auxiliary_predicate(run_suspensions),
2022 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
2023 ;
2024 Subscribe = true
2025 ).
2027 generate_attach_body_1(FA,Var,Susp,Body) :-
2028 get_target_module(Mod),
2029 Body =
2030 ( get_attr(Var, Mod, Susps) ->
2031 put_attr(Var, Mod, [Susp|Susps])
2032 ;
2033 put_attr(Var, Mod, [Susp])
2034 ).
2036 generate_attach_body_n(F/A,Var,Susp,Body) :-
2037 chr_pp_flag(experiment,off), !,
2038 get_constraint_index(F/A,Position),
2039 get_max_constraint_index(Total),
2040 get_target_module(Mod),
2041 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
2042 singleton_attr(Total,Susp,Position,NewAttr3),
2043 Body =
2044 ( get_attr(Var,Mod,TAttr) ->
2045 AddGoal,
2046 put_attr(Var,Mod,NTAttr)
2047 ;
2048 put_attr(Var,Mod,NewAttr3)
2049 ), !.
2050 generate_attach_body_n(F/A,Var,Susp,Body) :-
2051 chr_pp_flag(experiment,on), !,
2052 get_constraint_index(F/A,Position),
2053 or_pattern(Position,Pattern),
2054 Position1 is Position + 1,
2055 get_max_constraint_index(Total),
2056 get_target_module(Mod),
2057 singleton_attr(Total,Susp,Position,NewAttr3),
2058 Body =
2059 ( get_attr(Var,Mod,TAttr) ->
2060 arg(1,TAttr,BitVector),
2061 arg(Position1,TAttr,Susps),
2062 NBitVector is BitVector \/ Pattern,
2063 setarg(1,TAttr,NBitVector),
2064 setarg(Position1,TAttr,[Susp|Susps])
2065 ;
2066 put_attr(Var,Mod,NewAttr3)
2067 ), !.
2069 %% detach_$CONSTRAINT
2070 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
2071 generate_detach_a_constraint_nil(Constraint,Clause1),
2072 generate_detach_a_constraint_cons(Constraint,Clause2).
2074 detach_constraint_atom(FA,Vars,Susp,Atom) :-
2075 make_name('detach_',FA,Name),
2076 Atom =.. [Name,Vars,Susp].
2078 generate_detach_a_constraint_nil(FA,Clause) :-
2079 Clause = ( Head :- true),
2080 detach_constraint_atom(FA,[],_,Head).
2082 generate_detach_a_constraint_cons(FA,Clause) :-
2083 Clause = (Head :- Body),
2084 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
2085 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
2086 Body = ( DetachBody, RecursiveCall ),
2087 get_max_constraint_index(N),
2088 ( N == 1 ->
2089 generate_detach_body_1(FA,Var,Susp,DetachBody)
2090 ;
2091 generate_detach_body_n(FA,Var,Susp,DetachBody)
2092 ).
2094 generate_detach_body_1(FA,Var,Susp,Body) :-
2095 get_target_module(Mod),
2096 Body =
2097 ( get_attr(Var,Mod,Susps) ->
2098 'chr sbag_del_element'(Susps,Susp,NewSusps),
2099 ( NewSusps == [] ->
2100 del_attr(Var,Mod)
2101 ;
2102 put_attr(Var,Mod,NewSusps)
2103 )
2104 ;
2105 true
2106 ).
2108 generate_detach_body_n(F/A,Var,Susp,Body) :-
2109 get_constraint_index(F/A,Position),
2110 get_max_constraint_index(Total),
2111 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
2112 get_target_module(Mod),
2113 Body =
2114 ( get_attr(Var,Mod,TAttr) ->
2115 RemGoal
2116 ;
2117 true
2118 ), !.
2120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2121 %-------------------------------------------------------------------------------
2122 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
2123 :- chr_constraint generate_indexed_variables_body/4.
2124 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
2125 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
2126 %-------------------------------------------------------------------------------
2127 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
2128 get_indexing_spec(F/A,Specs),
2129 ( chr_pp_flag(term_indexing,on) ->
2130 spectermvars(Specs,Args,F,A,Body,Vars)
2131 ;
2132 get_constraint_type_det(F/A,ArgTypes),
2133 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
2134 ( MaybeBody == empty ->
2135 Body = true,
2136 Vars = []
2137 ; N == 0 ->
2138 ( Args = [Term] ->
2139 true
2140 ;
2141 Term =.. [term|Args]
2142 ),
2143 Body = term_variables(Term,Vars)
2144 ;
2145 MaybeBody = Body
2146 )
2147 ).
2148 generate_indexed_variables_body(FA,_,_,_) <=>
2149 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
2150 %===============================================================================
2152 create_indexed_variables_body([],[],[],_,_,_,empty,0).
2153 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
2154 J is I + 1,
2155 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
2156 ( Mode == (?),
2157 is_indexed_argument(FA,I) ->
2158 ( atomic_type(Type) ->
2159 Body =
2160 (
2161 ( var(V) ->
2162 Vars = [V|Tail]
2163 ;
2164 Vars = Tail
2165 ),
2166 Continuation
2167 ),
2168 ( RBody == empty ->
2169 Continuation = true, Tail = []
2170 ;
2171 Continuation = RBody
2172 )
2173 ;
2174 ( RBody == empty ->
2175 Body = term_variables(V,Vars)
2176 ;
2177 Body = (term_variables(V,Vars,Tail),RBody)
2178 )
2179 ),
2180 N = M
2181 ; Mode == (-), is_indexed_argument(FA,I) ->
2182 ( RBody == empty ->
2183 Body = (Vars = [V])
2184 ;
2185 Body = (Vars = [V|Tail],RBody)
2186 ),
2187 N is M + 1
2188 ;
2189 Vars = Tail,
2190 Body = RBody,
2191 N is M + 1
2192 ).
2193 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2194 % EXPERIMENTAL
2195 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2196 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2198 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2199 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2200 Goal = (ArgGoal,RGoal),
2201 argspecs(Specs,I,TempArgSpecs,RSpecs),
2202 merge_argspecs(TempArgSpecs,ArgSpecs),
2203 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2204 J is I + 1,
2205 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2207 argspecs([],_,[],[]).
2208 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2209 argspecs(Rest,I,ArgSpecs,RestSpecs).
2210 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2211 ( I == J ->
2212 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2213 ( Specs = [] ->
2214 RRestSpecs = RestSpecs
2215 ;
2216 RestSpecs = [Specs|RRestSpecs]
2217 )
2218 ;
2219 ArgSpecs = RArgSpecs,
2220 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2221 ),
2222 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2224 merge_argspecs(In,Out) :-
2225 sort(In,Sorted),
2226 merge_argspecs_(Sorted,Out).
2228 merge_argspecs_([],[]).
2229 merge_argspecs_([X],R) :- !, R = [X].
2230 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2231 ( (F1 == any ; F2 == any) ->
2232 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2233 ; F1 == F2 ->
2234 append(A1,A2,A),
2235 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2236 ;
2237 R = [specinfo(I,F1,A1)|RR],
2238 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2239 ).
2241 arggoal(List,Arg,Goal,L,T) :-
2242 ( List == [] ->
2243 L = T,
2244 Goal = true
2245 ; List = [specinfo(_,any,_)] ->
2246 Goal = term_variables(Arg,L,T)
2247 ;
2248 Goal =
2249 ( var(Arg) ->
2250 L = [Arg|T]
2251 ;
2252 Cases
2253 ),
2254 arggoal_cases(List,Arg,L,T,Cases)
2255 ).
2257 arggoal_cases([],_,L,T,L=T).
2258 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2259 ( ArgSpecs == [] ->
2260 Cases = RCases
2261 ; ArgSpecs == [[]] ->
2262 Cases = RCases
2263 ; FA = F/A ->
2264 Cases = (Case ; RCases),
2265 functor(Term,F,A),
2266 Term =.. [_|Args],
2267 Case = (Arg = Term -> ArgsGoal),
2268 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2269 ),
2270 arggoal_cases(Rest,Arg,L,T,RCases).
2271 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2273 generate_extra_clauses(Constraints,List) :-
2274 generate_activate_clauses(Constraints,List,Tail0),
2275 generate_remove_clauses(Constraints,Tail0,Tail1),
2276 generate_allocate_clauses(Constraints,Tail1,Tail2),
2277 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2278 generate_novel_production(Tail3,Tail4),
2279 generate_extend_history(Tail4,Tail5),
2280 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2281 generate_empty_named_history_initialisations(Tail6,Tail7),
2282 Tail7 = [].
2284 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2285 % remove_constraint_internal/[1/3]
2287 generate_remove_clauses([],List,List).
2288 generate_remove_clauses([C|Cs],List,Tail) :-
2289 generate_remove_clause(C,List,List1),
2290 generate_remove_clauses(Cs,List1,Tail).
2292 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2293 uses_state(Constraint,removed),
2294 ( chr_pp_flag(inline_insertremove,off) ->
2295 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2296 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2297 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2298 ;
2299 delay_phase_end(validate_store_type_assumptions,
2300 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2301 )
2302 ).
2304 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2305 make_name('$remove_constraint_internal_',Constraint,Name),
2306 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2307 Goal =.. [Name, Susp,Delete]
2308 ;
2309 Goal =.. [Name,Susp,Agenda,Delete]
2310 ).
2312 generate_remove_clause(Constraint,List,Tail) :-
2313 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2314 List = [RemoveClause|Tail],
2315 RemoveClause = (Head :- RemoveBody),
2316 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2317 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2318 ;
2319 List = Tail
2320 ).
2322 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2323 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2324 ( Role == active ->
2325 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2326 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2327 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2328 ; Role == partner ->
2329 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2330 GetStateValue = true,
2331 MaybeDelete = DeleteYes
2332 ),
2333 RemoveBody =
2334 (
2335 GetState,
2336 GetStateValue,
2337 UpdateState,
2338 MaybeDelete
2339 )
2340 ;
2341 static_suspension_term(Constraint,Susp2),
2342 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2343 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2344 ( chr_pp_flag(debugable,on) ->
2345 Constraint = Functor / _,
2346 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2347 ;
2348 true
2349 ),
2350 ( Role == active ->
2351 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2352 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2353 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2354 ; Role == partner ->
2355 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2356 GetStateValue = true,
2357 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2358 ),
2359 RemoveBody =
2360 (
2361 Susp = Susp2,
2362 GetStateValue,
2363 UpdateState,
2364 MaybeDelete
2365 )
2366 ).
2368 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2369 % activate_constraint/4
2371 generate_activate_clauses([],List,List).
2372 generate_activate_clauses([C|Cs],List,Tail) :-
2373 generate_activate_clause(C,List,List1),
2374 generate_activate_clauses(Cs,List1,Tail).
2376 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2377 ( chr_pp_flag(inline_insertremove,off) ->
2378 use_auxiliary_predicate(activate_constraint,Constraint),
2379 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2380 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2381 ;
2382 delay_phase_end(validate_store_type_assumptions,
2383 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2384 )
2385 ).
2387 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2388 make_name('$activate_constraint_',Constraint,Name),
2389 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2390 Goal =.. [Name,Store, Susp]
2391 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2392 Goal =.. [Name,Store, Susp, Generation]
2393 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2394 Goal =.. [Name,Store, Vars, Susp, Generation]
2395 ;
2396 Goal =.. [Name,Store, Vars, Susp]
2397 ).
2399 generate_activate_clause(Constraint,List,Tail) :-
2400 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2401 List = [Clause|Tail],
2402 Clause = (Head :- Body),
2403 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2404 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2405 ;
2406 List = Tail
2407 ).
2409 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2410 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2411 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2412 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2413 ;
2414 GenerationHandling = true
2415 ),
2416 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2417 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2418 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2419 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2420 ;
2421 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2422 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2423 chr_none_locked(Vars,NoneLocked),
2424 if_used_state(Constraint,not_stored_yet,
2425 ( State == not_stored_yet ->
2426 ArgumentsGoal,
2427 IndexedVariablesBody,
2428 NoneLocked,
2429 StoreYes
2430 ;
2431 % Vars = [],
2432 StoreNo
2433 ),
2434 % (Vars = [],StoreNo),StoreVarsGoal)
2435 StoreNo,StoreVarsGoal)
2436 ),
2437 Body =
2438 (
2439 GetState,
2440 GetStateValue,
2441 UpdateState,
2442 GenerationHandling,
2443 StoreVarsGoal
2444 ).
2445 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2446 % allocate_constraint/4
2448 generate_allocate_clauses([],List,List).
2449 generate_allocate_clauses([C|Cs],List,Tail) :-
2450 generate_allocate_clause(C,List,List1),
2451 generate_allocate_clauses(Cs,List1,Tail).
2453 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2454 uses_state(Constraint,not_stored_yet),
2455 ( chr_pp_flag(inline_insertremove,off) ->
2456 use_auxiliary_predicate(allocate_constraint,Constraint),
2457 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2458 ;
2459 Goal = (Susp = Suspension, Goal0),
2460 delay_phase_end(validate_store_type_assumptions,
2461 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2462 )
2463 ).
2465 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2466 make_name('$allocate_constraint_',Constraint,Name),
2467 Goal =.. [Name,Susp|Args].
2469 generate_allocate_clause(Constraint,List,Tail) :-
2470 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2471 List = [Clause|Tail],
2472 Clause = (Head :- Body),
2473 Constraint = _/A,
2474 length(Args,A),
2475 allocate_constraint_atom(Constraint,Susp,Args,Head),
2476 allocate_constraint_body(Constraint,Susp,Args,Body)
2477 ;
2478 List = Tail
2479 ).
2481 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2482 static_suspension_term(Constraint,Suspension),
2483 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2484 ( chr_pp_flag(debugable,on) ->
2485 Constraint = Functor / _,
2486 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2487 ;
2488 true
2489 ),
2490 ( chr_pp_flag(debugable,on) ->
2491 ( may_trigger(Constraint) ->
2492 append(Args,[Susp],VarsSusp),
2493 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2494 get_target_module(Mod),
2495 Continuation = Mod : ContinuationGoal
2496 ;
2497 Continuation = true
2498 ),
2499 Init = (Susp = Suspension),
2500 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2501 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2502 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2503 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2504 Susp = Suspension, Init = true, CreateContinuation = true
2505 ;
2506 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2507 ),
2508 ( uses_history(Constraint) ->
2509 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2510 ;
2511 CreateHistory = true
2512 ),
2513 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2514 ( has_suspension_field(Constraint,id) ->
2515 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2516 gen_id(Id,GenID)
2517 ;
2518 GenID = true
2519 ),
2520 Body =
2521 (
2522 Init,
2523 CreateContinuation,
2524 CreateGeneration,
2525 CreateHistory,
2526 CreateState,
2527 GenID
2528 ).
2530 gen_id(Id,'chr gen_id'(Id)).
2531 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2532 % insert_constraint_internal
2534 generate_insert_constraint_internal_clauses([],List,List).
2535 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2536 generate_insert_constraint_internal_clause(C,List,List1),
2537 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2539 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2540 ( chr_pp_flag(inline_insertremove,off) ->
2541 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2542 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2543 ;
2544 delay_phase_end(validate_store_type_assumptions,
2545 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2546 )
2547 ).
2550 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2551 insert_constraint_internal_constraint_name(Constraint,Name),
2552 ( chr_pp_flag(debugable,on) ->
2553 Goal =.. [Name, Vars, Self, Closure | Args]
2554 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2555 Goal =.. [Name,Self | Args]
2556 ;
2557 Goal =.. [Name,Vars, Self | Args]
2558 ).
2560 insert_constraint_internal_constraint_name(Constraint,Name) :-
2561 make_name('$insert_constraint_internal_',Constraint,Name).
2563 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2564 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2565 List = [Clause|Tail],
2566 Clause = (Head :- Body),
2567 Constraint = _/A,
2568 length(Args,A),
2569 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2570 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2571 ;
2572 List = Tail
2573 ).
2576 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2577 static_suspension_term(Constraint,Suspension),
2578 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2579 ( chr_pp_flag(debugable,on) ->
2580 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2581 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2582 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2583 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2584 ;
2585 CreateGeneration = true
2586 ),
2587 ( chr_pp_flag(debugable,on) ->
2588 Constraint = Functor / _,
2589 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2590 ;
2591 true
2592 ),
2593 ( uses_history(Constraint) ->
2594 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2595 ;
2596 CreateHistory = true
2597 ),
2598 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2599 List = [Clause|Tail],
2600 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2601 suspension_term_base_fields(Constraint,BaseFields),
2602 ( has_suspension_field(Constraint,id) ->
2603 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2604 gen_id(Id,GenID)
2605 ;
2606 GenID = true
2607 ),
2608 Body =
2609 (
2610 Susp = Suspension,
2611 CreateState,
2612 CreateGeneration,
2613 CreateHistory,
2614 GenID
2615 )
2616 ;
2617 ( has_suspension_field(Constraint,id) ->
2618 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2619 gen_id(Id,GenID)
2620 ;
2621 GenID = true
2622 ),
2623 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2624 chr_none_locked(Vars,NoneLocked),
2625 Body =
2626 (
2627 Susp = Suspension,
2628 IndexedVariablesBody,
2629 NoneLocked,
2630 CreateState,
2631 CreateGeneration,
2632 CreateHistory,
2633 GenID
2634 )
2635 ).
2637 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2638 % novel_production/2
2640 generate_novel_production(List,Tail) :-
2641 ( is_used_auxiliary_predicate(novel_production) ->
2642 List = [Clause|Tail],
2643 Clause =
2644 (
2645 '$novel_production'( Self, Tuple) :-
2646 % arg( 3, Self, Ref), % ARGXXX
2647 % 'chr get_mutable'( History, Ref),
2648 arg( 3, Self, History), % ARGXXX
2649 ( hprolog:get_ds( Tuple, History, _) ->
2650 fail
2651 ;
2652 true
2653 )
2654 )
2655 ;
2656 List = Tail
2657 ).
2659 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2660 % extend_history/2
2662 generate_extend_history(List,Tail) :-
2663 ( is_used_auxiliary_predicate(extend_history) ->
2664 List = [Clause|Tail],
2665 Clause =
2666 (
2667 '$extend_history'( Self, Tuple) :-
2668 % arg( 3, Self, Ref), % ARGXXX
2669 % 'chr get_mutable'( History, Ref),
2670 arg( 3, Self, History), % ARGXXX
2671 hprolog:put_ds( Tuple, History, x, NewHistory),
2672 setarg( 3, Self, NewHistory) % ARGXXX
2673 )
2674 ;
2675 List = Tail
2676 ).
2678 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2679 %
2680 :- chr_constraint
2681 empty_named_history_initialisations/2,
2682 generate_empty_named_history_initialisation/1,
2683 find_empty_named_histories/0.
2685 generate_empty_named_history_initialisations(List, Tail) :-
2686 empty_named_history_initialisations(List, Tail),
2687 find_empty_named_histories.
2689 find_empty_named_histories, history(_, Name, []) ==>
2690 generate_empty_named_history_initialisation(Name).
2692 generate_empty_named_history_initialisation(Name) \
2693 generate_empty_named_history_initialisation(Name) <=> true.
2694 generate_empty_named_history_initialisation(Name) \
2695 empty_named_history_initialisations(List, Tail) # Passive
2696 <=>
2697 empty_named_history_global_variable(Name, GlobalVariable),
2698 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2699 empty_named_history_initialisations(Rest, Tail)
2700 pragma passive(Passive).
2702 find_empty_named_histories \
2703 generate_empty_named_history_initialisation(_) # Passive <=> true
2704 pragma passive(Passive).
2706 find_empty_named_histories,
2707 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2708 pragma passive(Passive).
2710 find_empty_named_histories <=>
2711 chr_error(internal, 'find_empty_named_histories was not removed', []).
2714 empty_named_history_global_variable(Name, GlobalVariable) :-
2715 atom_concat('chr empty named history ', Name, GlobalVariable).
2717 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2718 empty_named_history_global_variable(Name, GlobalVariable).
2720 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2721 empty_named_history_global_variable(Name, GlobalVariable).
2724 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2725 % run_suspensions/2
2727 generate_run_suspensions_clauses([],List,List).
2728 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2729 generate_run_suspensions_clause(C,List,List1),
2730 generate_run_suspensions_clauses(Cs,List1,Tail).
2732 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2733 make_name('$run_suspensions_',Constraint,Name),
2734 Goal =.. [Name,Suspensions].
2736 generate_run_suspensions_clause(Constraint,List,Tail) :-
2737 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2738 List = [Clause1,Clause2|Tail],
2739 run_suspensions_goal(Constraint,[],Clause1),
2740 ( chr_pp_flag(debugable,on) ->
2741 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2742 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2743 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2744 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2745 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2746 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2747 Clause2 =
2748 (
2749 Clause2Head :-
2750 GetState,
2751 GetStateValue,
2752 ( State==active ->
2753 UpdateState,
2754 GetGeneration,
2755 GetGenerationValue,
2756 Generation is Gen+1,
2757 UpdateGeneration,
2758 GetContinuation,
2759 (
2760 'chr debug_event'(wake(Suspension)),
2761 call(Continuation)
2762 ;
2763 'chr debug_event'(fail(Suspension)), !,
2764 fail
2765 ),
2766 (
2767 'chr debug_event'(exit(Suspension))
2768 ;
2769 'chr debug_event'(redo(Suspension)),
2770 fail
2771 ),
2772 GetPost,
2773 GetPostValue,
2774 ( Post==triggered ->
2775 UpdatePost % catching constraints that did not do anything
2776 ;
2777 true
2778 )
2779 ;
2780 true
2781 ),
2782 Clause2Recursion
2783 )
2784 ;
2785 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2786 static_suspension_term(Constraint,SuspensionTerm),
2787 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2788 append(Arguments,[Suspension],VarsSusp),
2789 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2790 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2791 ( uses_field(Constraint,generation) ->
2792 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2793 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2794 ;
2795 GenerationHandling = true
2796 ),
2797 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2798 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2799 if_used_state(Constraint,removed,
2800 ( GetState,
2801 ( State==active
2802 -> ReactivateConstraint
2803 ; true)
2804 ),ReactivateConstraint,CondReactivate),
2805 ReactivateConstraint =
2806 (
2807 UpdateState,
2808 GenerationHandling,
2809 Continuation,
2810 GetPostState,
2811 ( Post==triggered ->
2812 UpdatePostState % catching constraints that did not do anything
2813 ;
2814 true
2815 )
2816 ),
2817 Clause2 =
2818 (
2819 Clause2Head :-
2820 Suspension = SuspensionTerm,
2821 CondReactivate,
2822 Clause2Recursion
2823 )
2824 )
2825 ;
2826 List = Tail
2827 ).
2829 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2831 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2832 generate_attach_increment(Clauses) :-
2833 get_max_constraint_index(N),
2834 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2835 Clauses = [Clause1,Clause2],
2836 generate_attach_increment_empty(Clause1),
2837 ( N == 1 ->
2838 generate_attach_increment_one(Clause2)
2839 ;
2840 generate_attach_increment_many(N,Clause2)
2841 )
2842 ;
2843 Clauses = []
2844 ).
2846 generate_attach_increment_empty((attach_increment([],_) :- true)).
2848 generate_attach_increment_one(Clause) :-
2849 Head = attach_increment([Var|Vars],Susps),
2850 get_target_module(Mod),
2851 chr_not_locked(Var,NotLocked),
2852 Body =
2853 (
2854 NotLocked,
2855 ( get_attr(Var,Mod,VarSusps) ->
2856 sort(VarSusps,SortedVarSusps),
2857 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2858 put_attr(Var,Mod,MergedSusps)
2859 ;
2860 put_attr(Var,Mod,Susps)
2861 ),
2862 attach_increment(Vars,Susps)
2863 ),
2864 Clause = (Head :- Body).
2866 generate_attach_increment_many(N,Clause) :-
2867 Head = attach_increment([Var|Vars],TAttr1),
2868 % writeln(merge_attributes_1_before),
2869 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2870 % writeln(merge_attributes_1_after),
2871 get_target_module(Mod),
2872 chr_not_locked(Var,NotLocked),
2873 Body =
2874 (
2875 NotLocked,
2876 ( get_attr(Var,Mod,TAttr2) ->
2877 MergeGoal,
2878 put_attr(Var,Mod,Attr)
2879 ;
2880 put_attr(Var,Mod,TAttr1)
2881 ),
2882 attach_increment(Vars,TAttr1)
2883 ),
2884 Clause = (Head :- Body).
2886 %% attr_unify_hook
2887 generate_attr_unify_hook(Clauses) :-
2888 get_max_constraint_index(N),
2889 ( N == 0 ->
2890 Clauses = []
2891 ;
2892 Clauses = [GoalsClause|HookClauses],
2893 GoalsClause = attribute_goals(_,Goals,Goals),
2894 ( N == 1 ->
2895 generate_attr_unify_hook_one(HookClauses)
2896 ;
2897 generate_attr_unify_hook_many(N,HookClauses)
2898 )
2899 ).
2901 generate_attr_unify_hook_one([Clause]) :-
2902 Head = attr_unify_hook(Susps,Other),
2903 get_target_module(Mod),
2904 get_indexed_constraint(1,C),
2905 ( get_store_type(C,ST),
2906 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2907 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2908 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2909 ( atomic_types_suspended_constraint(C) ->
2910 SortGoal1 = true,
2911 SortedSusps = Susps,
2912 SortGoal2 = true,
2913 SortedOtherSusps = OtherSusps,
2914 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2915 NonvarBody = true
2916 ;
2917 SortGoal1 = sort(Susps, SortedSusps),
2918 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2919 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2920 use_auxiliary_predicate(attach_increment),
2921 NonvarBody =
2922 ( compound(Other) ->
2923 term_variables(Other,OtherVars),
2924 attach_increment(OtherVars, SortedSusps)
2925 ;
2926 true
2927 )
2928 ),
2929 Body =
2930 (
2931 SortGoal1,
2932 ( var(Other) ->
2933 ( get_attr(Other,Mod,OtherSusps) ->
2934 SortGoal2,
2935 MergeGoal,
2936 put_attr(Other,Mod,NewSusps),
2937 WakeNewSusps
2938 ;
2939 put_attr(Other,Mod,SortedSusps),
2940 WakeSusps
2941 )
2942 ;
2943 NonvarBody,
2944 WakeSusps
2945 )
2946 ),
2947 Clause = (Head :- Body)
2948 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2949 make_run_suspensions(List,List,WakeNewSusps),
2950 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2951 Body =
2952 ( get_attr(Other,Mod,OtherSusps) ->
2953 MergeGoal,
2954 WakeNewSusps
2955 ;
2956 put_attr(Other,Mod,Susps)
2957 ),
2958 Clause = (Head :- Body)
2959 ).
2962 generate_attr_unify_hook_many(N,[Clause]) :-
2963 chr_pp_flag(dynattr,off), !,
2964 Head = attr_unify_hook(Attr,Other),
2965 get_target_module(Mod),
2966 make_attr(N,Mask,SuspsList,Attr),
2967 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2968 list2conj(SortGoalList,SortGoals),
2969 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2970 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2971 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2972 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2973 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2974 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2975 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2976 NonvarBody = true
2977 ;
2978 use_auxiliary_predicate(attach_increment),
2979 NonvarBody =
2980 ( compound(Other) ->
2981 term_variables(Other,OtherVars),
2982 attach_increment(OtherVars,SortedAttr)
2983 ;
2984 true
2985 )
2986 ),
2987 Body =
2988 (
2989 SortGoals,
2990 ( var(Other) ->
2991 ( get_attr(Other,Mod,TOtherAttr) ->
2992 MergeGoal,
2993 put_attr(Other,Mod,MergedAttr),
2994 WakeMergedSusps
2995 ;
2996 put_attr(Other,Mod,SortedAttr),
2997 WakeSortedSusps
2998 )
2999 ;
3000 NonvarBody,
3001 WakeSortedSusps
3002 )
3003 ),
3004 Clause = (Head :- Body).
3006 % NEW
3007 generate_attr_unify_hook_many(N,Clauses) :-
3008 Head = attr_unify_hook(Attr,Other),
3009 get_target_module(Mod),
3010 normalize_attr(Attr,NormalGoal,NormalAttr),
3011 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
3012 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
3013 make_run_suspensions(N),
3014 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
3015 NonvarBody = true
3016 ;
3017 use_auxiliary_predicate(attach_increment),
3018 NonvarBody =
3019 ( compound(Other) ->
3020 term_variables(Other,OtherVars),
3021 attach_increment(OtherVars,NormalAttr)
3022 ;
3023 true
3024 )
3025 ),
3026 Body =
3027 (
3028 NormalGoal,
3029 ( var(Other) ->
3030 ( get_attr(Other,Mod,OtherAttr) ->
3031 NormalOtherGoal,
3032 MergeGoal,
3033 put_attr(Other,Mod,MergedAttr),
3034 '$dispatch_run_suspensions'(MergedAttr)
3035 ;
3036 put_attr(Other,Mod,NormalAttr),
3037 '$dispatch_run_suspensions'(NormalAttr)
3038 )
3039 ;
3040 NonvarBody,
3041 '$dispatch_run_suspensions'(NormalAttr)
3042 )
3043 ),
3044 Clause = (Head :- Body),
3045 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
3046 DispatchList1 = ('$dispatch_run_suspensions'([])),
3047 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
3048 run_suspensions_dispatchers(N,[],Dispatchers).
3050 % NEW
3051 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
3052 ( N > 0 ->
3053 get_indexed_constraint(N,C),
3054 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
3055 ( may_trigger(C) ->
3056 run_suspensions_goal(C,List,Body)
3057 ;
3058 Body = true
3059 ),
3060 M is N - 1,
3061 run_suspensions_dispatchers(M,NAcc,Dispatchers)
3062 ;
3063 Dispatchers = Acc
3064 ).
3066 % NEW
3067 make_run_suspensions(N) :-
3068 ( N > 0 ->
3069 ( get_indexed_constraint(N,C),
3070 may_trigger(C) ->
3071 use_auxiliary_predicate(run_suspensions,C)
3072 ;
3073 true
3074 ),
3075 M is N - 1,
3076 make_run_suspensions(M)
3077 ;
3078 true
3079 ).
3081 make_run_suspensions(AllSusps,OneSusps,Goal) :-
3082 make_run_suspensions(1,AllSusps,OneSusps,Goal).
3084 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
3085 ( get_indexed_constraint(Index,C), may_trigger(C) ->
3086 use_auxiliary_predicate(run_suspensions,C),
3087 ( wakes_partially(C) ->
3088 run_suspensions_goal(C,OneSusps,Goal)
3089 ;
3090 run_suspensions_goal(C,AllSusps,Goal)
3091 )
3092 ;
3093 Goal = true
3094 ).
3096 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
3097 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
3099 make_run_suspensions_loop([],[],_,true).
3100 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
3101 make_run_suspensions(I,AllSusps,OneSusps,Goal),
3102 J is I + 1,
3103 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
3105 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3106 % $insert_in_store_F/A
3107 % $delete_from_store_F/A
3109 generate_insert_delete_constraints([],[]).
3110 generate_insert_delete_constraints([FA|Rest],Clauses) :-
3111 ( is_stored(FA) ->
3112 generate_insert_delete_constraint(FA,Clauses,RestClauses)
3113 ;
3114 Clauses = RestClauses
3115 ),
3116 generate_insert_delete_constraints(Rest,RestClauses).
3118 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
3119 insert_constraint_clause(FA,Clauses,RestClauses1),
3120 delete_constraint_clause(FA,RestClauses1,RestClauses).
3122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3123 % insert_in_store
3125 insert_constraint_goal(FA,Susp,Vars,Goal) :-
3126 ( chr_pp_flag(inline_insertremove,off) ->
3127 use_auxiliary_predicate(insert_in_store,FA),
3128 insert_constraint_atom(FA,Susp,Goal)
3129 ;
3130 delay_phase_end(validate_store_type_assumptions,
3131 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
3132 insert_constraint_direct_used_vars(UsedVars,Vars)
3133 )
3134 )
3135 ).
3137 insert_constraint_direct_used_vars([],_).
3138 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
3139 nth1(Index,Vars,Var),
3140 insert_constraint_direct_used_vars(Rest,Vars).
3142 insert_constraint_atom(FA,Susp,Call) :-
3143 make_name('$insert_in_store_',FA,Functor),
3144 Call =.. [Functor,Susp].
3146 insert_constraint_clause(C,Clauses,RestClauses) :-
3147 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3148 Clauses = [Clause|RestClauses],
3149 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3150 insert_constraint_atom(C,Susp,Head),
3151 insert_constraint_body(C,Susp,UsedVars,Body),
3152 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3153 ( chr_pp_flag(store_counter,on) ->
3154 InsertCounterInc = '$insert_counter_inc'
3155 ;
3156 InsertCounterInc = true
3157 )
3158 ;
3159 Clauses = RestClauses
3160 ).
3162 insert_constraint_used_vars([],_,_,true).
3163 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3164 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3165 insert_constraint_used_vars(Rest,C,Susp,Goals).
3167 insert_constraint_body(C,Susp,UsedVars,Body) :-
3168 get_store_type(C,StoreType),
3169 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3171 insert_constraint_body(default,C,Susp,[],Body) :-
3172 global_list_store_name(C,StoreName),
3173 make_get_store_goal(StoreName,Store,GetStoreGoal),
3174 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3175 ( chr_pp_flag(debugable,on) ->
3176 Cell = [Susp|Store],
3177 Body =
3178 (
3179 GetStoreGoal,
3180 UpdateStoreGoal
3181 )
3182 ;
3183 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3184 Body =
3185 (
3186 GetStoreGoal,
3187 Cell = [Susp|Store],
3188 UpdateStoreGoal,
3189 ( Store = [NextSusp|_] ->
3190 SetGoal
3191 ;
3192 true
3193 )
3194 )
3195 ).
3196 % get_target_module(Mod),
3197 % get_max_constraint_index(Total),
3198 % ( Total == 1 ->
3199 % generate_attach_body_1(C,Store,Susp,AttachBody)
3200 % ;
3201 % generate_attach_body_n(C,Store,Susp,AttachBody)
3202 % ),
3203 % Body =
3204 % (
3205 % 'chr default_store'(Store),
3206 % AttachBody
3207 % ).
3208 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3209 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3210 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3211 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3212 sort_out_used_vars(MixedUsedVars,UsedVars).
3213 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3214 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3215 constants_store_index_name(C,Index,IndexName),
3216 IndexLookup =.. [IndexName,Key,StoreName],
3217 Body =
3218 ( IndexLookup ->
3219 nb_getval(StoreName,Store),
3220 b_setval(StoreName,[Susp|Store])
3221 ;
3222 true
3223 ).
3224 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3225 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3226 constants_store_index_name(C,Index,IndexName),
3227 IndexLookup =.. [IndexName,Key,StoreName],
3228 Body =
3229 ( IndexLookup ->
3230 nb_getval(StoreName,Store),
3231 b_setval(StoreName,[Susp|Store])
3232 ;
3233 true
3234 ).
3235 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3236 global_ground_store_name(C,StoreName),
3237 make_get_store_goal(StoreName,Store,GetStoreGoal),
3238 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3239 ( chr_pp_flag(debugable,on) ->
3240 Cell = [Susp|Store],
3241 Body =
3242 (
3243 GetStoreGoal,
3244 UpdateStoreGoal
3245 )
3246 ;
3247 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3248 Body =
3249 (
3250 GetStoreGoal,
3251 Cell = [Susp|Store],
3252 UpdateStoreGoal,
3253 ( Store = [NextSusp|_] ->
3254 SetGoal
3255 ;
3256 true
3257 )
3258 )
3259 ).
3260 % global_ground_store_name(C,StoreName),
3261 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3262 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3263 % Body =
3264 % (
3265 % GetStoreGoal, % nb_getval(StoreName,Store),
3266 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3267 % ).
3268 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3269 % TODO: generalize to more than one !!!
3270 get_target_module(Module),
3271 Body = ( get_attr(Variable,Module,AssocStore) ->
3272 insert_assoc_store(AssocStore,Key,Susp)
3273 ;
3274 new_assoc_store(AssocStore),
3275 put_attr(Variable,Module,AssocStore),
3276 insert_assoc_store(AssocStore,Key,Susp)
3277 ).
3279 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3280 global_singleton_store_name(C,StoreName),
3281 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3282 Body =
3283 (
3284 UpdateStoreGoal
3285 ).
3286 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3287 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3288 list2conj(Bodies,Body),
3289 sort_out_used_vars(NestedUsedVars,UsedVars).
3290 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3291 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3292 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3293 UsedVars = [Index-Var],
3294 get_identifier_size(ISize),
3295 functor(Struct,struct,ISize),
3296 get_identifier_index(C,Index,IIndex),
3297 arg(IIndex,Struct,Susps),
3298 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3299 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3300 UsedVars = [Index-Var],
3301 type_indexed_identifier_structure(IndexType,Struct),
3302 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3303 arg(IIndex,Struct,Susps),
3304 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3306 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3307 flatten(NestedUsedVars,FlatUsedVars),
3308 sort(FlatUsedVars,SortedFlatUsedVars),
3309 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3311 sort_out_used_vars1([],[]).
3312 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3313 sort_out_used_vars1([I-X,J-Y|R],L) :-
3314 ( I == J ->
3315 X = Y,
3316 sort_out_used_vars1([I-X|R],L)
3317 ;
3318 L = [I-X|T],
3319 sort_out_used_vars1([J-Y|R],T)
3320 ).
3322 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3323 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3324 multi_hash_store_name(FA,Index,StoreName),
3325 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3326 Body =
3327 (
3328 KeyBody,
3329 nb_getval(StoreName,Store),
3330 insert_iht(Store,Key,Susp)
3331 ),
3332 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3334 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3335 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3336 multi_hash_store_name(FA,Index,StoreName),
3337 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3338 make_get_store_goal(StoreName,Store,GetStoreGoal),
3339 ( chr_pp_flag(ht_removal,on)
3340 -> ht_prev_field(Index,PrevField),
3341 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3342 SetGoal),
3343 Body =
3344 (
3345 GetStoreGoal,
3346 insert_ht(Store,Key,Susp,Result),
3347 ( Result = [_,NextSusp|_]
3348 -> SetGoal
3349 ; true
3350 )
3351 )
3352 ; Body =
3353 (
3354 GetStoreGoal,
3355 insert_ht(Store,Key,Susp)
3356 )
3357 ),
3358 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3360 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3361 % Delete
3363 delete_constraint_clause(C,Clauses,RestClauses) :-
3364 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3365 Clauses = [Clause|RestClauses],
3366 Clause = (Head :- Body),
3367 delete_constraint_atom(C,Susp,Head),
3368 C = F/A,
3369 functor(Head,F,A),
3370 delete_constraint_body(C,Head,Susp,[],Body)
3371 ;
3372 Clauses = RestClauses
3373 ).
3375 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3376 functor(Head,F,A),
3377 C = F/A,
3378 ( chr_pp_flag(inline_insertremove,off) ->
3379 use_auxiliary_predicate(delete_from_store,C),
3380 delete_constraint_atom(C,Susp,Goal)
3381 ;
3382 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3383 ).
3385 delete_constraint_atom(C,Susp,Atom) :-
3386 make_name('$delete_from_store_',C,Functor),
3387 Atom =.. [Functor,Susp].
3390 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3391 Body = (CounterBody,DeleteBody),
3392 ( chr_pp_flag(store_counter,on) ->
3393 CounterBody = '$delete_counter_inc'
3394 ;
3395 CounterBody = true
3396 ),
3397 get_store_type(C,StoreType),
3398 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3400 delete_constraint_body(default,C,_,Susp,_,Body) :-
3401 ( chr_pp_flag(debugable,on) ->
3402 global_list_store_name(C,StoreName),
3403 make_get_store_goal(StoreName,Store,GetStoreGoal),
3404 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3405 Body =
3406 (
3407 GetStoreGoal, % nb_getval(StoreName,Store),
3408 'chr sbag_del_element'(Store,Susp,NStore),
3409 UpdateStoreGoal % b_setval(StoreName,NStore)
3410 )
3411 ;
3412 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3413 global_list_store_name(C,StoreName),
3414 make_get_store_goal(StoreName,Store,GetStoreGoal),
3415 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3416 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3417 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3418 Body =
3419 (
3420 GetGoal,
3421 ( var(PredCell) ->
3422 GetStoreGoal, % nb_getval(StoreName,Store),
3423 Store = [_|Tail],
3424 UpdateStoreGoal,
3425 ( Tail = [NextSusp|_] ->
3426 SetGoal1
3427 ;
3428 true
3429 )
3430 ;
3431 PredCell = [_,_|Tail],
3432 setarg(2,PredCell,Tail),
3433 ( Tail = [NextSusp|_] ->
3434 SetGoal2
3435 ;
3436 true
3437 )
3438 )
3439 )
3440 ).
3441 % get_target_module(Mod),
3442 % get_max_constraint_index(Total),
3443 % ( Total == 1 ->
3444 % generate_detach_body_1(C,Store,Susp,DetachBody),
3445 % Body =
3446 % (
3447 % 'chr default_store'(Store),
3448 % DetachBody
3449 % )
3450 % ;
3451 % generate_detach_body_n(C,Store,Susp,DetachBody),
3452 % Body =
3453 % (
3454 % 'chr default_store'(Store),
3455 % DetachBody
3456 % )
3457 % ).
3458 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3459 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3460 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3461 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3462 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3463 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3464 constants_store_index_name(C,Index,IndexName),
3465 IndexLookup =.. [IndexName,Key,StoreName],
3466 Body =
3467 ( KeyBody,
3468 ( IndexLookup ->
3469 nb_getval(StoreName,Store),
3470 'chr sbag_del_element'(Store,Susp,NStore),
3471 b_setval(StoreName,NStore)
3472 ;
3473 true
3474 )).
3475 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3476 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3477 constants_store_index_name(C,Index,IndexName),
3478 IndexLookup =.. [IndexName,Key,StoreName],
3479 Body =
3480 ( KeyBody,
3481 ( IndexLookup ->
3482 nb_getval(StoreName,Store),
3483 'chr sbag_del_element'(Store,Susp,NStore),
3484 b_setval(StoreName,NStore)
3485 ;
3486 true
3487 )).
3488 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3489 ( chr_pp_flag(debugable,on) ->
3490 global_ground_store_name(C,StoreName),
3491 make_get_store_goal(StoreName,Store,GetStoreGoal),
3492 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3493 Body =
3494 (
3495 GetStoreGoal, % nb_getval(StoreName,Store),
3496 'chr sbag_del_element'(Store,Susp,NStore),
3497 UpdateStoreGoal % b_setval(StoreName,NStore)
3498 )
3499 ;
3500 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3501 global_ground_store_name(C,StoreName),
3502 make_get_store_goal(StoreName,Store,GetStoreGoal),
3503 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3504 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3505 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3506 Body =
3507 (
3508 GetGoal,
3509 ( var(PredCell) ->
3510 GetStoreGoal, % nb_getval(StoreName,Store),
3511 Store = [_|Tail],
3512 UpdateStoreGoal,
3513 ( Tail = [NextSusp|_] ->
3514 SetGoal1
3515 ;
3516 true
3517 )
3518 ;
3519 PredCell = [_,_|Tail],
3520 setarg(2,PredCell,Tail),
3521 ( Tail = [NextSusp|_] ->
3522 SetGoal2
3523 ;
3524 true
3525 )
3526 )
3527 )
3528 ).
3529 % global_ground_store_name(C,StoreName),
3530 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3531 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3532 % Body =
3533 % (
3534 % GetStoreGoal, % nb_getval(StoreName,Store),
3535 % 'chr sbag_del_element'(Store,Susp,NStore),
3536 % UpdateStoreGoal % b_setval(StoreName,NStore)
3537 % ).
3538 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3539 get_target_module(Module),
3540 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3541 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3542 Body = (
3543 VariableGoal,
3544 get_attr(Variable,Module,AssocStore),
3545 KeyGoal,
3546 delete_assoc_store(AssocStore,Key,Susp)
3547 ).
3548 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3549 global_singleton_store_name(C,StoreName),
3550 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3551 Body =
3552 (
3553 UpdateStoreGoal % b_setval(StoreName,[])
3554 ).
3555 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3556 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3557 list2conj(Bodies,Body).
3558 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3559 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3560 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3561 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3562 get_identifier_size(ISize),
3563 functor(Struct,struct,ISize),
3564 get_identifier_index(C,Index,IIndex),
3565 arg(IIndex,Struct,Susps),
3566 Body = (
3567 VariableGoal,
3568 Variable = Struct,
3569 'chr sbag_del_element'(Susps,Susp,NSusps),
3570 setarg(IIndex,Variable,NSusps)
3571 ).
3572 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3573 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3574 type_indexed_identifier_structure(IndexType,Struct),
3575 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3576 arg(IIndex,Struct,Susps),
3577 Body = (
3578 VariableGoal,
3579 Variable = Struct,
3580 'chr sbag_del_element'(Susps,Susp,NSusps),
3581 setarg(IIndex,Variable,NSusps)
3582 ).
3584 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3585 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3586 multi_hash_store_name(FA,Index,StoreName),
3587 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3588 Body =
3589 (
3590 KeyBody,
3591 nb_getval(StoreName,Store),
3592 delete_iht(Store,Key,Susp)
3593 ),
3594 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3595 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3596 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3597 multi_hash_store_name(C,Index,StoreName),
3598 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3599 make_get_store_goal(StoreName,Store,GetStoreGoal),
3600 ( chr_pp_flag(ht_removal,on)
3601 -> ht_prev_field(Index,PrevField),
3602 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3603 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3604 SetGoal1),
3605 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3606 SetGoal2),
3607 Body =
3608 (
3609 GetGoal,
3610 ( var(Prev)
3611 -> GetStoreGoal,
3612 KeyBody,
3613 delete_first_ht(Store,Key,Values),
3614 ( Values = [NextSusp|_]
3615 -> SetGoal1
3616 ; true
3617 )
3618 ; Prev = [_,_|Values],
3619 setarg(2,Prev,Values),
3620 ( Values = [NextSusp|_]
3621 -> SetGoal2
3622 ; true
3623 )
3624 )
3625 )
3626 ; Body =
3627 (
3628 KeyBody,
3629 GetStoreGoal, % nb_getval(StoreName,Store),
3630 delete_ht(Store,Key,Susp)
3631 )
3632 ),
3633 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3635 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3637 :- chr_constraint
3638 module_initializer/1,
3639 module_initializers/1.
3641 module_initializers(G), module_initializer(Initializer) <=>
3642 G = (Initializer,Initializers),
3643 module_initializers(Initializers).
3645 module_initializers(G) <=>
3646 G = true.
3648 generate_attach_code(Constraints,Clauses) :-
3649 enumerate_stores_code(Constraints,Enumerate),
3650 append(Enumerate,L,Clauses),
3651 generate_attach_code(Constraints,L,T),
3652 module_initializers(Initializers),
3653 prolog_global_variables_code(PrologGlobalVariables),
3654 % Do not rename or the 'chr_initialization' predicate
3655 % without warning SSS
3656 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3658 generate_attach_code([],L,L).
3659 generate_attach_code([C|Cs],L,T) :-
3660 get_store_type(C,StoreType),
3661 generate_attach_code(StoreType,C,L,L1),
3662 generate_attach_code(Cs,L1,T).
3664 generate_attach_code(default,C,L,T) :-
3665 global_list_store_initialisation(C,L,T).
3666 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3667 multi_inthash_store_initialisations(Indexes,C,L,L1),
3668 multi_inthash_via_lookups(Indexes,C,L1,T).
3669 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3670 multi_hash_store_initialisations(Indexes,C,L,L1),
3671 multi_hash_lookups(Indexes,C,L1,T).
3672 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3673 constants_initializers(C,Index,Constants),
3674 atomic_constants_code(C,Index,Constants,L,T).
3675 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3676 constants_initializers(C,Index,Constants),
3677 ground_constants_code(C,Index,Constants,L,T).
3678 generate_attach_code(global_ground,C,L,T) :-
3679 global_ground_store_initialisation(C,L,T).
3680 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3681 use_auxiliary_module(chr_assoc_store).
3682 generate_attach_code(global_singleton,C,L,T) :-
3683 global_singleton_store_initialisation(C,L,T).
3684 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3685 multi_store_generate_attach_code(StoreTypes,C,L,T).
3686 generate_attach_code(identifier_store(Index),C,L,T) :-
3687 get_identifier_index(C,Index,IIndex),
3688 ( IIndex == 2 ->
3689 get_identifier_size(ISize),
3690 functor(Struct,struct,ISize),
3691 Struct =.. [_,Label|Stores],
3692 set_elems(Stores,[]),
3693 Clause1 = new_identifier(Label,Struct),
3694 functor(Struct2,struct,ISize),
3695 arg(1,Struct2,Label2),
3696 Clause2 =
3697 ( user:portray(Struct2) :-
3698 write('<id:'),
3699 print(Label2),
3700 write('>')
3701 ),
3702 functor(Struct3,struct,ISize),
3703 arg(1,Struct3,Label3),
3704 Clause3 = identifier_label(Struct3,Label3),
3705 L = [Clause1,Clause2,Clause3|T]
3706 ;
3707 L = T
3708 ).
3709 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3710 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3711 ( IIndex == 2 ->
3712 identifier_store_initialization(IndexType,L,L1),
3713 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3714 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3715 get_type_indexed_identifier_size(IndexType,ISize),
3716 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3717 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3718 type_indexed_identifier_structure(IndexType,Struct),
3719 Struct =.. [_,Label|Stores],
3720 set_elems(Stores,[]),
3721 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3722 Clause1 =.. [Name1,Label,Struct],
3723 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3724 Goal1 =.. [Name1,Label1b,S1b],
3725 type_indexed_identifier_structure(IndexType,Struct1b),
3726 Struct1b =.. [_,Label1b|Stores1b],
3727 set_elems(Stores1b,[]),
3728 Expansion1 = (S1b = Struct1b),
3729 Clause1b = user:goal_expansion(Goal1,Expansion1),
3730 % writeln(Clause1-Clause1b),
3731 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3732 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3733 type_indexed_identifier_structure(IndexType,Struct2),
3734 arg(1,Struct2,Label2),
3735 Clause2 =
3736 ( user:portray(Struct2) :-
3737 write('<id:'),
3738 print(Label2),
3739 write('>')
3740 ),
3741 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3742 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3743 type_indexed_identifier_structure(IndexType,Struct3),
3744 arg(1,Struct3,Label3),
3745 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3746 Clause3 =.. [Name3,Struct3,Label3],
3747 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3748 Goal3b =.. [Name3,S3b,L3b],
3749 type_indexed_identifier_structure(IndexType,Struct3b),
3750 arg(1,Struct3b,L3b),
3751 Expansion3b = (S3b = Struct3b),
3752 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3753 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3754 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3755 identifier_store_name(IndexType,GlobalVariable),
3756 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3757 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3758 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3759 Clause4 =
3760 ( LookupAtom :-
3761 nb_getval(GlobalVariable,HT),
3762 ( lookup_ht(HT,X,[IX]) ->
3763 true
3764 ;
3765 NewIdentifierGoal,
3766 insert_ht(HT,X,IX)
3767 )
3768 ),
3769 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3770 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3771 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3772 ;
3773 L = T
3774 ).
3776 constants_initializers(C,Index,Constants) :-
3777 maplist(constant_initializer(C,Index),Constants).
3779 constant_initializer(C,Index,Constant) :-
3780 constants_store_name(C,Index,Constant,StoreName),
3781 prolog_global_variable(StoreName),
3782 module_initializer(nb_setval(StoreName,[])).
3784 lookup_identifier_atom(Key,X,IX,Atom) :-
3785 atom_concat('lookup_identifier_',Key,LookupFunctor),
3786 Atom =.. [LookupFunctor,X,IX].
3788 identifier_label_atom(IndexType,IX,X,Atom) :-
3789 type_indexed_identifier_name(IndexType,identifier_label,Name),
3790 Atom =.. [Name,IX,X].
3792 multi_store_generate_attach_code([],_,L,L).
3793 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3794 generate_attach_code(ST,C,L,L1),
3795 multi_store_generate_attach_code(STs,C,L1,T).
3797 multi_inthash_store_initialisations([],_,L,L).
3798 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3799 use_auxiliary_module(chr_integertable_store),
3800 multi_hash_store_name(FA,Index,StoreName),
3801 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3802 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3803 L1 = L,
3804 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3805 multi_hash_store_initialisations([],_,L,L).
3806 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3807 use_auxiliary_module(chr_hashtable_store),
3808 multi_hash_store_name(FA,Index,StoreName),
3809 prolog_global_variable(StoreName),
3810 make_init_store_goal(StoreName,HT,InitStoreGoal),
3811 module_initializer((new_ht(HT),InitStoreGoal)),
3812 L1 = L,
3813 multi_hash_store_initialisations(Indexes,FA,L1,T).
3815 global_list_store_initialisation(C,L,T) :-
3816 ( is_stored(C) ->
3817 global_list_store_name(C,StoreName),
3818 prolog_global_variable(StoreName),
3819 make_init_store_goal(StoreName,[],InitStoreGoal),
3820 module_initializer(InitStoreGoal)
3821 ;
3822 true
3823 ),
3824 L = T.
3825 global_ground_store_initialisation(C,L,T) :-
3826 global_ground_store_name(C,StoreName),
3827 prolog_global_variable(StoreName),
3828 make_init_store_goal(StoreName,[],InitStoreGoal),
3829 module_initializer(InitStoreGoal),
3830 L = T.
3831 global_singleton_store_initialisation(C,L,T) :-
3832 global_singleton_store_name(C,StoreName),
3833 prolog_global_variable(StoreName),
3834 make_init_store_goal(StoreName,[],InitStoreGoal),
3835 module_initializer(InitStoreGoal),
3836 L = T.
3837 identifier_store_initialization(IndexType,L,T) :-
3838 use_auxiliary_module(chr_hashtable_store),
3839 identifier_store_name(IndexType,StoreName),
3840 prolog_global_variable(StoreName),
3841 make_init_store_goal(StoreName,HT,InitStoreGoal),
3842 module_initializer((new_ht(HT),InitStoreGoal)),
3843 L = T.
3846 multi_inthash_via_lookups([],_,L,L).
3847 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3848 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3849 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3850 L = [(Head :- Body)|L1],
3851 multi_inthash_via_lookups(Indexes,C,L1,T).
3852 multi_hash_lookups([],_,L,L).
3853 multi_hash_lookups([Index|Indexes],C,L,T) :-
3854 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3855 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3856 L = [(Head :- Body)|L1],
3857 multi_hash_lookups(Indexes,C,L1,T).
3859 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3860 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3861 Head =.. [Name,Key,SuspsList].
3863 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3864 %
3865 % Returns goal that performs hash table lookup.
3866 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3867 % INLINED:
3868 get_store_type(ConstraintSymbol,multi_store(Stores)),
3869 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3870 ( ground(Key) ->
3871 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3872 Goal = nb_getval(StoreName,SuspsList)
3873 ;
3874 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3875 Lookup =.. [IndexName,Key,StoreName],
3876 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3877 )
3878 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3879 ( ground(Key) ->
3880 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3881 Goal = nb_getval(StoreName,SuspsList)
3882 ;
3883 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3884 Lookup =.. [IndexName,Key,StoreName],
3885 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3886 )
3887 ; memberchk(multi_hash([Index]),Stores) ->
3888 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3889 make_get_store_goal(StoreName,HT,GetStoreGoal),
3890 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3891 Goal =
3892 (
3893 GetStoreGoal, % nb_getval(StoreName,HT),
3894 HashCall, % hash_term(Key,Hash),
3895 lookup_ht1(HT,Hash,Key,SuspsList)
3896 )
3897 ;
3898 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3899 Goal =
3900 (
3901 GetStoreGoal, % nb_getval(StoreName,HT),
3902 Lookup
3903 )
3904 )
3905 ; HashType == inthash ->
3906 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3907 make_get_store_goal(StoreName,HT,GetStoreGoal),
3908 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3909 Goal =
3910 (
3911 GetStoreGoal, % nb_getval(StoreName,HT),
3912 Lookup
3913 )
3914 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3915 % find alternative index
3916 % -> SubIndex + RestIndex
3917 % -> SubKey + RestKeys
3918 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3919 % instantiate rest goal?
3920 % Goal = (SubGoal,RestGoal)
3921 ).
3924 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3925 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3927 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3928 ( ground(Key) ->
3929 % This is based on a property of SWI-Prolog's
3930 % hash_term/2 predicate:
3931 % the hash value is stable over repeated invocations
3932 % of SWI-Prolog
3933 hash_term(Key,Hash),
3934 Call = true
3935 % ; Index = [IndexPos],
3936 % get_constraint_type(Constraint,ArgTypes),
3937 % nth1(IndexPos,ArgTypes,Type),
3938 % unalias_type(Type,NormalType),
3939 % memberchk_eq(NormalType,[int,natural]) ->
3940 % ( NormalType == int ->
3941 % Call = (Hash is abs(Key))
3942 % ;
3943 % Hash = Key,
3944 % Call = true
3945 % )
3946 % ;
3947 % nonvar(Key),
3948 % specialize_hash_term(Key,NewKey),
3949 % NewKey \== Key,
3950 % Call = hash_term(NewKey,Hash)
3951 ).
3953 % specialize_hash_term(Term,NewTerm) :-
3954 % ( ground(Term) ->
3955 % hash_term(Term,NewTerm)
3956 % ; var(Term) ->
3957 % NewTerm = Term
3958 % ;
3959 % Term =.. [F|Args],
3960 % maplist(specialize_hash_term,Args,NewArgs),
3961 % NewTerm =.. [F|NewArgs]
3962 % ).
3964 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3965 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3966 ( /* chr_pp_flag(experiment,off) ->
3967 true
3968 ; */ atomic(Key) ->
3969 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3970 ; ground(Key) ->
3971 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3972 ;
3973 ( Index = [Pos],
3974 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3975 is_chr_constants_type(Type,_,_)
3976 ->
3977 true
3978 ;
3979 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3980 )
3981 ),
3982 delay_phase_end(validate_store_type_assumptions,
3983 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3985 :- chr_constraint actual_atomic_multi_hash_keys/3.
3986 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3988 :- chr_constraint actual_ground_multi_hash_keys/3.
3989 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3991 :- chr_constraint actual_non_ground_multi_hash_key/2.
3992 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3994 /*
3995 actual_atomic_multi_hash_keys(C,Index,Keys)
3996 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3998 actual_ground_multi_hash_keys(C,Index,Keys)
3999 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
4001 actual_non_ground_multi_hash_key(C,Index)
4002 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
4003 */
4004 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4005 <=> append(Keys1,Keys2,Keys0),
4006 sort(Keys0,Keys),
4007 actual_atomic_multi_hash_keys(C,Index,Keys).
4009 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
4010 <=> append(Keys1,Keys2,Keys0),
4011 sort(Keys0,Keys),
4012 actual_ground_multi_hash_keys(C,Index,Keys).
4014 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
4015 <=> append(Keys1,Keys2,Keys0),
4016 sort(Keys0,Keys),
4017 actual_ground_multi_hash_keys(C,Index,Keys).
4019 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
4020 <=> true.
4022 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
4023 <=> true.
4025 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
4026 <=> true.
4028 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
4029 %
4030 % Returns predicate name of hash table lookup predicate.
4031 multi_hash_lookup_name(F/A,Index,Name) :-
4032 atom_concat_list(Index,IndexName),
4033 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
4035 multi_hash_store_name(F/A,Index,Name) :-
4036 get_target_module(Mod),
4037 atom_concat_list(Index,IndexName),
4038 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
4040 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
4041 ( Index = [I] ->
4042 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
4043 ;
4044 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
4045 Key =.. [k|Keys],
4046 list2conj(Bodies,KeyBody)
4047 ).
4049 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
4050 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
4052 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
4053 ( Index = [I] ->
4054 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
4055 ;
4056 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
4057 Key =.. [k|Keys],
4058 list2conj(Bodies,KeyBody)
4059 ).
4061 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
4062 arg(Index,Head,OriginalArg),
4063 ( term_variables(OriginalArg,OriginalVars),
4064 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
4065 translate(OriginalVars,VarDict,Vars) ->
4066 Goal = true
4067 ;
4068 functor(Head,F,A),
4069 C = F/A,
4070 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
4071 ).
4073 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
4074 ( Index = [I] ->
4075 UsedVars = [I-Key]
4076 ;
4077 pairup(Index,Keys,UsedVars),
4078 Key =.. [k|Keys]
4079 ).
4081 args(Index,Head,KeyArgs) :-
4082 maplist(arg1(Head),Index,KeyArgs).
4084 split_args(Indexes,Args,IArgs,NIArgs) :-
4085 split_args(Indexes,Args,1,IArgs,NIArgs).
4087 split_args([],Args,_,[],Args).
4088 split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :-
4089 NJ is J + 1,
4090 ( I == J ->
4091 IArgs = [Arg|Rest],
4092 split_args(Is,Args,NJ,Rest,NIArgs)
4093 ;
4094 NIArgs = [Arg|Rest],
4095 split_args([I|Is],Args,NJ,IArgs,Rest)
4096 ).
4099 %-------------------------------------------------------------------------------
4100 atomic_constants_code(C,Index,Constants,L,T) :-
4101 constants_store_index_name(C,Index,IndexName),
4102 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
4103 append(Clauses,T,L).
4105 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
4106 constants_store_name(C,Index,Constant,StoreName),
4107 Clause =.. [IndexName,Constant,StoreName].
4109 %-------------------------------------------------------------------------------
4110 ground_constants_code(C,Index,Terms,L,T) :-
4111 constants_store_index_name(C,Index,IndexName),
4112 maplist(constants_store_name(C,Index),Terms,StoreNames),
4113 length(Terms,N),
4114 replicate(N,[],More),
4115 trie_index([Terms|More],StoreNames,IndexName,L,T).
4117 constants_store_name(F/A,Index,Term,Name) :-
4118 get_target_module(Mod),
4119 term_to_atom(Term,Constant),
4120 term_to_atom(Index,IndexAtom),
4121 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
4123 constants_store_index_name(F/A,Index,Name) :-
4124 get_target_module(Mod),
4125 term_to_atom(Index,IndexAtom),
4126 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
4128 % trie index code {{{
4129 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
4130 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
4132 trie_step([],_,_,[],[],L,L) :- !.
4133 % length MorePatterns == length Patterns == length Results
4134 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
4135 MorePatterns = [List|_],
4136 length(List,N),
4137 aggregate_all(set(F/A),
4138 ( member(Pattern,Patterns),
4139 functor(Pattern,F,A)
4140 ),
4141 FAs),
4142 N1 is N + 1,
4143 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4145 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4146 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4147 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4148 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4150 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4151 Clause = (Head :- Body),
4152 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4153 N1 is N + 1,
4154 functor(Head,Symbol,N1),
4155 arg(1,Head,IndexPattern),
4156 Head =.. [_,_|RestArgs],
4157 once(append(Vs,[Result],RestArgs)),
4158 /* IndexPattern = F() */
4159 functor(IndexPattern,F,A),
4160 IndexPattern =.. [_|Args],
4161 append(Args,RestArgs,RecArgs),
4162 ( RecArgs == [Result] ->
4163 /* nothing more to match on */
4164 List = Tail,
4165 Body = true,
4166 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4167 MoreResults = [Result]
4168 ; /* more things to match on */
4169 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4170 ( MoreCases = [OneMoreCase] ->
4171 /* only one more thing to match on */
4172 List = Tail,
4173 Body = true,
4174 append([Cases,OneMoreCase,MoreResults],RecArgs)
4175 ;
4176 /* more than one thing to match on */
4177 /* [ x1,..., xn]
4178 [xs1,...,xsn]
4179 */
4180 pairup(Cases,MoreCases,CasePairs),
4181 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4182 append(Args,Vs,[First|Rest]),
4183 First-Rest = CommonPatternPair,
4184 % Body = RSymbol(DiffVars,Result)
4185 gensym(Prefix,RSymbol),
4186 append(DiffVars,[Result],RecCallVars),
4187 Body =.. [RSymbol|RecCallVars],
4188 maplist(head_tail,Differences,CHs,CTs),
4189 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4190 )
4191 ).
4193 head_tail([H|T],H,T).
4195 rec_cases([],[],[],_,[],[],[]).
4196 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4197 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4198 Cases = [Case|NCases],
4199 MoreCases = [MoreCase|NMoreCases],
4200 MoreResults = [Result|NMoreResults],
4201 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4202 ;
4203 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4204 ).
4205 % }}}
4207 %% common_pattern(+terms,-term,-vars,-differences) is det.
4208 common_pattern(Ts,T,Vars,Differences) :-
4209 fold1(chr_translate:gct,Ts,T),
4210 term_variables(T,Vars),
4211 findall(Vars,member(T,Ts),Differences).
4213 gct(T1,T2,T) :-
4214 gct_(T1,T2,T,[],_).
4216 gct_(T1,T2,T,Dict0,Dict) :-
4217 ( nonvar(T1),
4218 nonvar(T2),
4219 functor(T1,F1,A1),
4220 functor(T2,F2,A2),
4221 F1 == F2,
4222 A1 == A2 ->
4223 functor(T,F1,A1),
4224 T1 =.. [_|Args1],
4225 T2 =.. [_|Args2],
4226 T =.. [_|Args],
4227 maplist_dcg(chr_translate:gct_,Args1,Args2,Args,Dict0,Dict)
4228 ;
4229 /* T is a variable */
4230 ( lookup_eq(Dict0,T1+T2,T) ->
4231 /* we already have a variable for this difference */
4232 Dict = Dict0
4233 ;
4234 /* T is a fresh variable */
4235 Dict = [(T1+T2)-T|Dict0]
4236 )
4237 ).
4240 %-------------------------------------------------------------------------------
4241 global_list_store_name(F/A,Name) :-
4242 get_target_module(Mod),
4243 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4244 global_ground_store_name(F/A,Name) :-
4245 get_target_module(Mod),
4246 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4247 global_singleton_store_name(F/A,Name) :-
4248 get_target_module(Mod),
4249 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4251 identifier_store_name(TypeName,Name) :-
4252 get_target_module(Mod),
4253 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4255 :- chr_constraint prolog_global_variable/1.
4256 :- chr_option(mode,prolog_global_variable(+)).
4258 :- chr_constraint prolog_global_variables/1.
4259 :- chr_option(mode,prolog_global_variables(-)).
4261 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4263 prolog_global_variables(List), prolog_global_variable(Name) <=>
4264 List = [Name|Tail],
4265 prolog_global_variables(Tail).
4266 prolog_global_variables(List) <=> List = [].
4268 %% SWI begin
4269 prolog_global_variables_code(Code) :-
4270 prolog_global_variables(Names),
4271 ( Names == [] ->
4272 Code = []
4273 ;
4274 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4275 Code = [(:- dynamic user:exception/3),
4276 (:- multifile user:exception/3),
4277 (user:exception(undefined_global_variable,Name,retry) :-
4278 (
4279 '$chr_prolog_global_variable'(Name),
4280 '$chr_initialization'
4281 )
4282 )
4283 |
4284 NameDeclarations
4285 ]
4286 ).
4287 %% SWI end
4288 %% SICStus begin
4289 % prolog_global_variables_code([]).
4290 %% SICStus end
4291 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4292 %sbag_member_call(S,L,sysh:mem(S,L)).
4293 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4294 %sbag_member_call(S,L,member(S,L)).
4295 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4296 %update_mutable_call(A,B,setarg(1, B, A)).
4297 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4298 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4300 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4301 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4302 % create_get_mutable(Value,Field,Get1).
4303 %
4304 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4305 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4306 % update_mutable_call(NewValue,Field,Set).
4307 %
4308 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4309 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4310 % create_get_mutable_ref(Value,Field,Get1),
4311 % update_mutable_call(NewValue,Field,Set).
4312 %
4313 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4314 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4315 % create_mutable_call(Value,Field,Create).
4316 %
4317 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4318 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4319 % create_get_mutable(Value,Field,Get).
4320 %
4321 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4322 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4323 % create_get_mutable_ref(Value,Field,Get),
4324 % update_mutable_call(NewValue,Field,Set).
4326 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4327 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4329 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4330 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4332 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4333 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4334 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4336 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4337 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4339 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4340 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4342 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4343 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4344 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4346 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4348 enumerate_stores_code(Constraints,[Clause|List]) :-
4349 Head = '$enumerate_constraints'(Constraint),
4350 Clause = ( Head :- Body),
4351 enumerate_store_bodies(Constraints,Constraint,List),
4352 ( List = [] ->
4353 Body = fail
4354 ;
4355 Body = ( nonvar(Constraint) ->
4356 functor(Constraint,Functor,_),
4357 '$enumerate_constraints'(Functor,Constraint)
4358 ;
4359 '$enumerate_constraints'(_,Constraint)
4360 )
4361 ).
4363 enumerate_store_bodies([],_,[]).
4364 enumerate_store_bodies([C|Cs],Constraint,L) :-
4365 ( is_stored(C) ->
4366 get_store_type(C,StoreType),
4367 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4368 true
4369 ;
4370 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4371 ),
4372 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4373 C = F/_,
4374 Constraint0 =.. [F|Arguments],
4375 Head = '$enumerate_constraints'(F,Constraint),
4376 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4377 L = [(Head :- Body)|T]
4378 ;
4379 L = T
4380 ),
4381 enumerate_store_bodies(Cs,Constraint,T).
4383 enumerate_store_body(default,C,Susp,Body) :-
4384 global_list_store_name(C,StoreName),
4385 sbag_member_call(Susp,List,Sbag),
4386 make_get_store_goal(StoreName,List,GetStoreGoal),
4387 Body =
4388 (
4389 GetStoreGoal, % nb_getval(StoreName,List),
4390 Sbag
4391 ).
4392 % get_constraint_index(C,Index),
4393 % get_target_module(Mod),
4394 % get_max_constraint_index(MaxIndex),
4395 % Body1 =
4396 % (
4397 % 'chr default_store'(GlobalStore),
4398 % get_attr(GlobalStore,Mod,Attr)
4399 % ),
4400 % ( MaxIndex > 1 ->
4401 % NIndex is Index + 1,
4402 % sbag_member_call(Susp,List,Sbag),
4403 % Body2 =
4404 % (
4405 % arg(NIndex,Attr,List),
4406 % Sbag
4407 % )
4408 % ;
4409 % sbag_member_call(Susp,Attr,Sbag),
4410 % Body2 = Sbag
4411 % ),
4412 % Body = (Body1,Body2).
4413 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4414 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4415 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4416 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4417 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4418 Completeness == complete, % fail if incomplete
4419 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4420 list2disj(Disjuncts, Disjunction),
4421 Body = ( Disjunction, member(Susp,Susps) ).
4422 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4423 constants_store_name(C,Index,Constant,StoreName).
4425 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4426 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4427 enumerate_store_body(global_ground,C,Susp,Body) :-
4428 global_ground_store_name(C,StoreName),
4429 sbag_member_call(Susp,List,Sbag),
4430 make_get_store_goal(StoreName,List,GetStoreGoal),
4431 Body =
4432 (
4433 GetStoreGoal, % nb_getval(StoreName,List),
4434 Sbag
4435 ).
4436 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4437 Body = fail.
4438 enumerate_store_body(global_singleton,C,Susp,Body) :-
4439 global_singleton_store_name(C,StoreName),
4440 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4441 Body =
4442 (
4443 GetStoreGoal, % nb_getval(StoreName,Susp),
4444 Susp \== []
4445 ).
4446 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4447 ( memberchk(global_ground,STs) ->
4448 enumerate_store_body(global_ground,C,Susp,Body)
4449 ;
4450 once((
4451 member(ST,STs),
4452 enumerate_store_body(ST,C,Susp,Body)
4453 ))
4454 ).
4455 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4456 Body = fail.
4457 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4458 Body = fail.
4460 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4461 multi_hash_store_name(C,I,StoreName),
4462 B =
4463 (
4464 nb_getval(StoreName,HT),
4465 value_iht(HT,Susp)
4466 ).
4467 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4468 multi_hash_store_name(C,I,StoreName),
4469 make_get_store_goal(StoreName,HT,GetStoreGoal),
4470 B =
4471 (
4472 GetStoreGoal, % nb_getval(StoreName,HT),
4473 value_ht(HT,Susp)
4474 ).
4476 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4477 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4478 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4480 :- chr_constraint
4481 background_info/1,
4482 background_info/2,
4483 get_bg_info/1,
4484 get_bg_info/2,
4485 get_bg_info_answer/1.
4487 background_info(X), background_info(Y) <=>
4488 append(X,Y,XY), background_info(XY).
4489 background_info(X) \ get_bg_info(Q) <=> Q=X.
4490 get_bg_info(Q) <=> Q = [].
4492 background_info(T,I), get_bg_info(A,Q) ==>
4493 copy_term_nat(T,T1),
4494 subsumes_chk(T1,A)
4495 |
4496 copy_term_nat(T-I,A-X),
4497 get_bg_info_answer([X]).
4498 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4499 append(X,Y,XY), get_bg_info_answer(XY).
4501 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4502 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4504 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4507 :- chr_constraint
4508 prev_guard_list/8,
4509 prev_guard_list/6,
4510 simplify_guards/1,
4511 set_all_passive/1.
4513 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4514 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4515 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4516 :- chr_option(mode,simplify_guards(+)).
4517 :- chr_option(mode,set_all_passive(+)).
4519 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4520 % GUARD SIMPLIFICATION
4521 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4522 % If the negation of the guards of earlier rules entails (part of)
4523 % the current guard, the current guard can be simplified. We can only
4524 % use earlier rules with a head that matches if the head of the current
4525 % rule does, and which make it impossible for the current rule to match
4526 % if they fire (i.e. they shouldn't be propagation rules and their
4527 % head constraints must be subsets of those of the current rule).
4528 % At this point, we know for sure that the negation of the guard
4529 % of such a rule has to be true (otherwise the earlier rule would have
4530 % fired, because of the refined operational semantics), so we can use
4531 % that information to simplify the guard by replacing all entailed
4532 % conditions by true/0. As a consequence, the never-stored analysis
4533 % (in a further phase) will detect more cases of never-stored constraints.
4534 %
4535 % e.g. c(X),d(Y) <=> X > 0 | ...
4536 % e(X) <=> X < 0 | ...
4537 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4538 % \____________/
4539 % true
4541 guard_simplification :-
4542 ( chr_pp_flag(guard_simplification,on) ->
4543 precompute_head_matchings,
4544 simplify_guards(1)
4545 ;
4546 true
4547 ).
4549 % for every rule, we create a prev_guard_list where the last argument
4550 % eventually is a list of the negations of earlier guards
4551 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4552 <=>
4553 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4554 append(Head1,Head2,Heads),
4555 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4556 tree_set_empty(Done),
4557 multiple_occ_constraints_checked(Done),
4558 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4560 append(IDs1,IDs2,IDs),
4561 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4562 empty_q(EmptyHeap),
4563 insert_list_q(HeapData,EmptyHeap,Heap),
4564 next_prev_rule(Heap,_,Heap1),
4565 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4566 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4567 NextRule is RuleNb+1,
4568 simplify_guards(NextRule).
4570 next_prev_rule(Heap,RuleNb,NHeap) :-
4571 ( find_min_q(Heap,_-Priority) ->
4572 Priority = (-RuleNb),
4573 normalize_heap(Heap,Priority,NHeap)
4574 ;
4575 RuleNb = 0,
4576 NHeap = Heap
4577 ).
4579 normalize_heap(Heap,Priority,NHeap) :-
4580 ( find_min_q(Heap,_-Priority) ->
4581 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4582 ( O > 1 ->
4583 NO is O -1,
4584 get_occurrence(C,NO,RuleNb,_),
4585 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4586 ;
4587 Heap2 = Heap1
4588 ),
4589 normalize_heap(Heap2,Priority,NHeap)
4590 ;
4591 NHeap = Heap
4592 ).
4594 % no more rule
4595 simplify_guards(_)
4596 <=>
4597 true.
4599 % The negation of the guard of a non-propagation rule is added
4600 % if its kept head constraints are a subset of the kept constraints of
4601 % the rule we're working on, and its removed head constraints (at least one)
4602 % are a subset of the removed constraints.
4604 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4605 <=>
4606 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4607 H1 \== [],
4608 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4609 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4610 |
4611 append(H1,H2,Heads),
4612 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4613 append(GuardList,DerivedInfo,GL1),
4614 normalize_conj_list(GL1,GL),
4615 append(GH_New1,GH,GH1),
4616 normalize_conj_list(GH1,GH_New),
4617 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4618 % PrevPrevRuleNb is PrevRuleNb-1,
4619 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4621 % if this isn't the case, we skip this one and try the next rule
4622 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4623 <=>
4624 ( N > 0 ->
4625 next_prev_rule(Heap,N1,NHeap),
4626 % N1 is N-1,
4627 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4628 ;
4629 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4630 ).
4632 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4633 <=>
4634 GH \== []
4635 |
4636 head_types_modes_condition(GH,H,TypeInfo),
4637 conj2list(TypeInfo,TI),
4638 term_variables(H,HeadVars),
4639 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4640 normalize_conj_list(Info,InfoL),
4641 append(H,InfoL,RelevantTerms),
4642 add_background_info([G|RelevantTerms],BGInfo),
4643 append(InfoL,BGInfo,AllInfo_),
4644 normalize_conj_list(AllInfo_,AllInfo),
4645 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4647 head_types_modes_condition([],H,true).
4648 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4649 types_modes_condition(H,GH,TI1),
4650 head_types_modes_condition(GHs,H,TI2).
4652 add_background_info(Term,Info) :-
4653 get_bg_info(GeneralInfo),
4654 add_background_info2(Term,TermInfo),
4655 append(GeneralInfo,TermInfo,Info).
4657 add_background_info2(X,[]) :- var(X), !.
4658 add_background_info2([],[]) :- !.
4659 add_background_info2([X|Xs],Info) :- !,
4660 add_background_info2(X,Info1),
4661 add_background_info2(Xs,Infos),
4662 append(Info1,Infos,Info).
4664 add_background_info2(X,Info) :-
4665 (functor(X,_,A), A>0 ->
4666 X =.. [_|XArgs],
4667 add_background_info2(XArgs,XArgInfo)
4668 ;
4669 XArgInfo = []
4670 ),
4671 get_bg_info(X,XInfo),
4672 append(XInfo,XArgInfo,Info).
4674 %%
4675 % when all earlier guards are added or skipped, we simplify the guard.
4676 % if it's different from the original one, we change the rule
4678 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4679 <=>
4680 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4681 G \== true, % let's not try to simplify this ;)
4682 append(M,GuardList,Info),
4683 (% if guard + context is a contradiction, it should be simplified to "fail"
4684 conj2list(G,GL), append(Info,GL,GuardWithContext),
4685 guard_entailment:entails_guard(GuardWithContext,fail) ->
4686 SimpleGuard = fail
4687 ;
4688 % otherwise we try to remove redundant conjuncts
4689 simplify_guard(G,B,Info,SimpleGuard,NB)
4690 ),
4691 G \== SimpleGuard % only do this if we can change the guard
4692 |
4693 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4694 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4696 %% normalize_conj_list(+List,-NormalList) is det.
4697 %
4698 % Removes =true= elements and flattens out conjunctions.
4700 normalize_conj_list(List,NormalList) :-
4701 list2conj(List,Conj),
4702 conj2list(Conj,NormalList).
4704 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4705 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4706 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4708 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4709 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4710 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4711 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4712 append(Renaming1,ExtraRenaming,Renaming2),
4713 list2conj(PrevMatchings,Match),
4714 negate_b(Match,HeadsDontMatch),
4715 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4716 list2conj(HeadsMatch,HeadsMatchBut),
4717 term_variables(Renaming2,RenVars),
4718 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4719 new_vars(MGVars,RenVars,ExtraRenaming2),
4720 append(Renaming2,ExtraRenaming2,Renaming),
4721 ( PrevGuard == true -> % true can't fail
4722 Info_ = HeadsDontMatch
4723 ;
4724 negate_b(PrevGuard,TheGuardFailed),
4725 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4726 ),
4727 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4728 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4729 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4730 list2conj(RenamedMatchings_,RenamedMatchings),
4731 apply_guard_wrt_term(H,RenamedG2,GH2),
4732 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4733 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4735 simplify_guard(G,B,Info,SG,NB) :-
4736 conj2list(G,LG),
4737 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4738 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4739 list2conj(SGL,SG).
4742 new_vars([],_,[]).
4743 new_vars([A|As],RV,ER) :-
4744 ( memberchk_eq(A,RV) ->
4745 new_vars(As,RV,ER)
4746 ;
4747 ER = [A-NewA,NewA-A|ER2],
4748 new_vars(As,RV,ER2)
4749 ).
4751 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4752 %
4753 % check if a list of constraints is a subset of another list of constraints
4754 % (multiset-subset), meanwhile computing a variable renaming to convert
4755 % one into the other.
4756 head_subset(H,Head,Renaming) :-
4757 head_subset(H,Head,Renaming,[],_).
4759 head_subset([],Remainder,Renaming,Renaming,Remainder).
4760 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4761 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4762 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4764 % check if A is in the list, remove it from Headleft
4765 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4766 ( variable_replacement(A,X,Acc,Renaming),
4767 Remainder = Xs
4768 ;
4769 Remainder = [X|RRemainder],
4770 head_member(Xs,A,Renaming,Acc,RRemainder)
4771 ).
4772 %-------------------------------------------------------------------------------%
4773 % memoing code to speed up repeated computation
4775 :- chr_constraint precompute_head_matchings/0.
4777 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4778 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4779 append(H1,H2,Heads),
4780 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4781 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4782 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4784 precompute_head_matchings <=> true.
4786 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4787 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4789 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4790 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4792 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4793 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4794 <=>
4795 Q1 = NHeads,
4796 Q2 = Matchings.
4797 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4799 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4800 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4801 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4802 %-------------------------------------------------------------------------------%
4804 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4805 extract_arguments(Heads,Arguments),
4806 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4807 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4809 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4810 extract_arguments(Heads,Arguments),
4811 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4812 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4814 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4815 extract_arguments(Heads,Arguments1),
4816 extract_arguments(MatchingFreeHeads,Arguments2),
4817 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4819 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4820 %
4821 % Returns list of arguments of given list of constraints.
4822 extract_arguments([],[]).
4823 extract_arguments([Constraint|Constraints],AllArguments) :-
4824 Constraint =.. [_|Arguments],
4825 append(Arguments,RestArguments,AllArguments),
4826 extract_arguments(Constraints,RestArguments).
4828 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4829 %
4830 % Substitutes arguments of constraints with those in the given list.
4832 substitute_arguments([],[],[]).
4833 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4834 functor(Constraint,F,N),
4835 split_at(N,Variables,Arguments,RestVariables),
4836 NConstraint =.. [F|Arguments],
4837 substitute_arguments(Constraints,RestVariables,NConstraints).
4839 make_matchings_explicit([],[],_,MC,MC,[]).
4840 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4841 ( var(Arg) ->
4842 ( memberchk_eq(Arg,VarAcc) ->
4843 list2disj(MatchingCondition,MatchingCondition_disj),
4844 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4845 NVarAcc = VarAcc
4846 ;
4847 Matchings = RestMatchings,
4848 NewVar = Arg,
4849 NVarAcc = [Arg|VarAcc]
4850 ),
4851 MatchingCondition2 = MatchingCondition
4852 ;
4853 functor(Arg,F,A),
4854 Arg =.. [F|RecArgs],
4855 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4856 FlatArg =.. [F|RecVars],
4857 ( RecMatchings == [] ->
4858 Matchings = [functor(NewVar,F,A)|RestMatchings]
4859 ;
4860 list2conj(RecMatchings,ArgM_conj),
4861 list2disj(MatchingCondition,MatchingCondition_disj),
4862 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4863 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4864 ),
4865 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4866 term_variables(Args,ArgVars),
4867 append(ArgVars,VarAcc,NVarAcc)
4868 ),
4869 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4872 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4873 %
4874 % Returns list of new variables and list of pairwise unifications between given list and variables.
4876 make_matchings_explicit_not_negated([],[],[]).
4877 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4878 Matchings = [Var = X|RMatchings],
4879 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4881 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4882 %
4883 % (Partially) applies substitutions of =Goal= to given list.
4885 apply_guard_wrt_term([],_Guard,[]).
4886 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4887 ( var(Term) ->
4888 apply_guard_wrt_variable(Guard,Term,NTerm)
4889 ;
4890 Term =.. [F|HArgs],
4891 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4892 NTerm =.. [F|NewHArgs]
4893 ),
4894 apply_guard_wrt_term(RH,Guard,RGH).
4896 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4897 %
4898 % (Partially) applies goal =Guard= wrt variable.
4900 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4901 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4902 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4903 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4904 ( Guard = (X = Y), Variable == X ->
4905 NVariable = Y
4906 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4907 functor(NVariable,Functor,Arity)
4908 ;
4909 NVariable = Variable
4910 ).
4913 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4914 % ALWAYS FAILING GUARDS
4915 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4917 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4918 ==>
4919 chr_pp_flag(check_impossible_rules,on),
4920 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4921 conj2list(G,GL),
4922 append(M,GuardList,Info),
4923 append(Info,GL,GuardWithContext),
4924 guard_entailment:entails_guard(GuardWithContext,fail)
4925 |
4926 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4927 set_all_passive(RuleNb).
4929 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4930 % HEAD SIMPLIFICATION
4931 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4933 % now we check the head matchings (guard may have been simplified meanwhile)
4934 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4935 <=>
4936 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4937 simplify_heads(M,GuardList,G,B,NewM,NewB),
4938 NewM \== [],
4939 extract_arguments(Head1,VH1),
4940 extract_arguments(Head2,VH2),
4941 extract_arguments(H,VH),
4942 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4943 substitute_arguments(Head1,H1,NewH1),
4944 substitute_arguments(Head2,H2,NewH2),
4945 append(NewB,NewB_,NewBody),
4946 list2conj(NewBody,BodyMatchings),
4947 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4948 (Head1 \== NewH1 ; Head2 \== NewH2 )
4949 |
4950 rule(RuleNb,NewRule).
4952 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4953 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4954 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4956 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4957 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4958 ( NH == M ->
4959 H2_ = M,
4960 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4961 ;
4962 (M = functor(X,F,A), NH == X ->
4963 length(A_args,A),
4964 (var(H2) ->
4965 NewB1 = [],
4966 H2_ =.. [F|A_args]
4967 ;
4968 H2 =.. [F|OrigArgs],
4969 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4970 H2_ =.. [F|A_args_]
4971 ),
4972 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4973 append(NewB1,NewB2,NewB)
4974 ;
4975 H2_ = H2,
4976 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4977 )
4978 ).
4980 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4981 ( NH == M ->
4982 H1_ = M,
4983 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4984 ;
4985 (M = functor(X,F,A), NH == X ->
4986 length(A_args,A),
4987 (var(H1) ->
4988 NewB1 = [],
4989 H1_ =.. [F|A_args]
4990 ;
4991 H1 =.. [F|OrigArgs],
4992 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4993 H1_ =.. [F|A_args_]
4994 ),
4995 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4996 append(NewB1,NewB2,NewB)
4997 ;
4998 H1_ = H1,
4999 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
5000 )
5001 ).
5003 use_same_args([],[],[],_,_,[]).
5004 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5005 var(OA),!,
5006 Out = OA,
5007 use_same_args(ROA,RNA,ROut,G,Body,NewB).
5008 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
5009 nonvar(OA),!,
5010 ( common_variables(OA,Body) ->
5011 NewB = [NA = OA|NextB]
5012 ;
5013 NewB = NextB
5014 ),
5015 Out = NA,
5016 use_same_args(ROA,RNA,ROut,G,Body,NextB).
5019 simplify_heads([],_GuardList,_G,_Body,[],[]).
5020 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
5021 M = (A = B),
5022 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
5023 guard_entailment:entails_guard(GuardList,(A=B)) ->
5024 ( common_variables(B,G-RM-GuardList) ->
5025 NewB = NextB,
5026 NewM = NextM
5027 ;
5028 ( common_variables(B,Body) ->
5029 NewB = [A = B|NextB]
5030 ;
5031 NewB = NextB
5032 ),
5033 NewM = [A|NextM]
5034 )
5035 ;
5036 ( nonvar(B), functor(B,BFu,BAr),
5037 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
5038 NewB = NextB,
5039 ( common_variables(B,G-RM-GuardList) ->
5040 NewM = NextM
5041 ;
5042 NewM = [functor(A,BFu,BAr)|NextM]
5043 )
5044 ;
5045 NewM = NextM,
5046 NewB = NextB
5047 )
5048 ),
5049 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
5051 common_variables(B,G) :-
5052 term_variables(B,BVars),
5053 term_variables(G,GVars),
5054 intersect_eq(BVars,GVars,L),
5055 L \== [].
5058 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
5059 set_all_passive(_) <=> true.
5063 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5064 % OCCURRENCE SUBSUMPTION
5065 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5067 :- chr_constraint
5068 first_occ_in_rule/4,
5069 next_occ_in_rule/6.
5071 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
5072 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
5074 :- chr_constraint multiple_occ_constraints_checked/1.
5075 :- chr_option(mode,multiple_occ_constraints_checked(+)).
5077 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
5078 occurrence(C,O,RuleNb,ID,_),
5079 occurrence(C,O2,RuleNb,ID2,_),
5080 rule(RuleNb,Rule)
5081 \
5082 multiple_occ_constraints_checked(Done)
5083 <=>
5084 O < O2,
5085 chr_pp_flag(occurrence_subsumption,on),
5086 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
5087 H1 \== [],
5088 \+ tree_set_memberchk(C,Done)
5089 |
5090 first_occ_in_rule(RuleNb,C,O,ID),
5091 tree_set_add(Done,C,NDone),
5092 multiple_occ_constraints_checked(NDone).
5094 % Find first occurrence of constraint =C= in rule =RuleNb=
5095 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
5096 <=>
5097 O < O2
5098 |
5099 first_occ_in_rule(RuleNb,C,O,ID).
5101 first_occ_in_rule(RuleNb,C,O,ID_o1)
5102 <=>
5103 C = F/A,
5104 functor(FreshHead,F,A),
5105 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
5107 % Skip passive occurrences.
5108 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
5109 <=>
5110 O2 is O+1
5111 |
5112 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
5114 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)
5115 <=>
5116 O2 is O+1,
5117 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
5118 |
5119 append(H1,H2,Heads),
5120 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
5121 ( ExtraCond == [chr_pp_void_info] ->
5122 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
5123 ;
5124 append(ExtraCond,Cond,NewCond),
5125 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
5126 copy_term(GuardList,FGuardList),
5127 variable_replacement(GuardList,FGuardList,GLRepl),
5128 copy_with_variable_replacement(GuardList,GuardList2,Repl),
5129 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
5130 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
5131 append(NewCond,GuardList2,BigCond),
5132 append(BigCond,GuardList3,BigCond2),
5133 copy_with_variable_replacement(M,M2,Repl),
5134 copy_with_variable_replacement(M,M3,Repl2),
5135 append(M3,BigCond2,BigCond3),
5136 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5137 list2conj(CheckCond,OccSubsum),
5138 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5139 ( OccSubsum \= chr_pp_void_info ->
5140 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5141 passive(RuleNb,ID_o2)
5142 ;
5143 true
5144 )
5145 ;
5146 true
5147 ),!,
5148 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5149 ).
5152 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5153 <=>
5154 true.
5156 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5157 <=>
5158 true.
5160 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5161 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5162 append(ID2,ID1,IDs),
5163 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5164 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5165 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5166 copy_with_variable_replacement(G,FG,Repl),
5167 extract_explicit_matchings(FG,FG2),
5168 negate_b(FG2,NotFG),
5169 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5170 ( subsumes(FH,FH2) ->
5171 FailCond = [(NotFG;FMPCond)]
5172 ;
5173 % in this case, not much can be done
5174 % e.g. c(f(...)), c(g(...)) <=> ...
5175 FailCond = [chr_pp_void_info]
5176 ).
5178 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5179 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5180 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5181 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5182 Cond = (chr_pp_not_in_store(H);Cond1),
5183 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5185 extract_explicit_matchings((A,B),D) :- !,
5186 ( extract_explicit_matchings(A) ->
5187 extract_explicit_matchings(B,D)
5188 ;
5189 D = (A,E),
5190 extract_explicit_matchings(B,E)
5191 ).
5192 extract_explicit_matchings(A,D) :- !,
5193 ( extract_explicit_matchings(A) ->
5194 D = true
5195 ;
5196 D = A
5197 ).
5199 extract_explicit_matchings(A=B) :-
5200 var(A), var(B), !, A=B.
5201 extract_explicit_matchings(A==B) :-
5202 var(A), var(B), !, A=B.
5204 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5205 % TYPE INFORMATION
5206 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5208 :- chr_constraint
5209 type_definition/2,
5210 type_alias/2,
5211 constraint_type/2,
5212 get_type_definition/2,
5213 get_constraint_type/2.
5216 :- chr_option(mode,type_definition(?,?)).
5217 :- chr_option(mode,get_type_definition(?,?)).
5218 :- chr_option(mode,type_alias(?,?)).
5219 :- chr_option(mode,constraint_type(+,+)).
5220 :- chr_option(mode,get_constraint_type(+,-)).
5222 assert_constraint_type(Constraint,ArgTypes) :-
5223 ( ground(ArgTypes) ->
5224 constraint_type(Constraint,ArgTypes)
5225 ;
5226 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5227 ).
5229 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5230 % Consistency checks of type aliases
5232 type_alias(T1,T2) <=>
5233 var(T1)
5234 |
5235 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5237 type_alias(T1,T2) <=>
5238 var(T2)
5239 |
5240 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5242 type_alias(T,T2) <=>
5243 functor(T,F,A),
5244 functor(T2,F,A),
5245 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5246 |
5247 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5249 type_alias(T1,A1), type_alias(T2,A2) <=>
5250 functor(T1,F,A),
5251 functor(T2,F,A),
5252 \+ (T1\=T2)
5253 |
5254 copy_term_nat(T1,T1_),
5255 copy_term_nat(T2,T2_),
5256 T1_ = T2_,
5257 chr_error(type_error,
5258 '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_]).
5260 type_alias(T,B) \ type_alias(X,T2) <=>
5261 functor(T,F,A),
5262 functor(T2,F,A),
5263 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5264 subsumes(T1,T3)
5265 |
5266 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5267 type_alias(X2,D1).
5269 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5270 % Consistency checks of type definitions
5272 type_definition(T1,_), type_definition(T2,_)
5273 <=>
5274 functor(T1,F,A), functor(T2,F,A)
5275 |
5276 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5278 type_definition(T1,_), type_alias(T2,_)
5279 <=>
5280 functor(T1,F,A), functor(T2,F,A)
5281 |
5282 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5284 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5285 %% get_type_definition(+Type,-Definition) is semidet.
5286 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5288 get_type_definition(T,Def)
5289 <=>
5290 \+ ground(T)
5291 |
5292 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5294 type_alias(T,D) \ get_type_definition(T2,Def)
5295 <=>
5296 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5297 copy_term_nat((T,D),(T1,D1)),T1=T2
5298 |
5299 ( get_type_definition(D1,Def) ->
5300 true
5301 ;
5302 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5303 ).
5305 type_definition(T,D) \ get_type_definition(T2,Def)
5306 <=>
5307 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5308 copy_term_nat((T,D),(T1,D1)),T1=T2
5309 |
5310 Def = D1.
5312 get_type_definition(Type,Def)
5313 <=>
5314 atomic_builtin_type(Type,_,_)
5315 |
5316 Def = [Type].
5318 get_type_definition(Type,Def)
5319 <=>
5320 compound_builtin_type(Type,_,_,_)
5321 |
5322 Def = [Type].
5324 get_type_definition(X,Y) <=> fail.
5326 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5327 %% get_type_definition_det(+Type,-Definition) is det.
5328 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5329 get_type_definition_det(Type,Definition) :-
5330 ( get_type_definition(Type,Definition) ->
5331 true
5332 ;
5333 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5334 ).
5336 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5337 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5338 %
5339 % Return argument types of =ConstraintSymbol=, but fails if none where
5340 % declared.
5341 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5342 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5343 get_constraint_type(_,_) <=> fail.
5345 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5346 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5347 %
5348 % Like =get_constraint_type/2=, but returns list of =any= types when
5349 % no types are declared.
5350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5351 get_constraint_type_det(ConstraintSymbol,Types) :-
5352 ( get_constraint_type(ConstraintSymbol,Types) ->
5353 true
5354 ;
5355 ConstraintSymbol = _ / N,
5356 replicate(N,any,Types)
5357 ).
5358 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5359 %% unalias_type(+Alias,-Type) is det.
5360 %
5361 % Follows alias chain until base type is reached.
5362 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5363 :- chr_constraint unalias_type/2.
5365 unalias_var @
5366 unalias_type(Alias,BaseType)
5367 <=>
5368 var(Alias)
5369 |
5370 BaseType = Alias.
5372 unalias_alias @
5373 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5374 <=>
5375 nonvar(AliasProtoType),
5376 nonvar(Alias),
5377 functor(AliasProtoType,F,A),
5378 functor(Alias,F,A),
5379 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5380 Alias = AliasInstance
5381 |
5382 unalias_type(Type,BaseType).
5384 unalias_type_definition @
5385 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5386 <=>
5387 nonvar(ProtoType),
5388 nonvar(Alias),
5389 functor(ProtoType,F,A),
5390 functor(Alias,F,A)
5391 |
5392 BaseType = Alias.
5394 unalias_atomic_builtin @
5395 unalias_type(Alias,BaseType)
5396 <=>
5397 atomic_builtin_type(Alias,_,_)
5398 |
5399 BaseType = Alias.
5401 unalias_compound_builtin @
5402 unalias_type(Alias,BaseType)
5403 <=>
5404 compound_builtin_type(Alias,_,_,_)
5405 |
5406 BaseType = Alias.
5408 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5409 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5410 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5411 :- chr_constraint types_modes_condition/3.
5412 :- chr_option(mode,types_modes_condition(+,+,?)).
5413 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5415 types_modes_condition([],[],T) <=> T=true.
5417 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5418 <=>
5419 functor(Head,F,A)
5420 |
5421 Head =.. [_|Args],
5422 Condition = (ModesCondition, TypesCondition, RestCondition),
5423 modes_condition(Modes,Args,ModesCondition),
5424 get_constraint_type_det(F/A,Types),
5425 UnrollHead =.. [_|RealArgs],
5426 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5427 types_modes_condition(Heads,UnrollHeads,RestCondition).
5429 types_modes_condition([Head|_],_,_)
5430 <=>
5431 functor(Head,F,A),
5432 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5435 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5436 %% modes_condition(+Modes,+Args,-Condition) is det.
5437 %
5438 % Return =Condition= on =Args= that checks =Modes=.
5439 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5440 modes_condition([],[],true).
5441 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5442 ( Mode == (+) ->
5443 Condition = ( ground(Arg) , RCondition )
5444 ; Mode == (-) ->
5445 Condition = ( var(Arg) , RCondition )
5446 ;
5447 Condition = RCondition
5448 ),
5449 modes_condition(Modes,Args,RCondition).
5451 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5452 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5453 %
5454 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5455 % =UnrollArgs= controls the depth of type definition unrolling.
5456 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5457 types_condition([],[],[],[],true).
5458 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5459 ( Mode == (-) ->
5460 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5461 ;
5462 get_type_definition_det(Type,Def),
5463 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5464 ( Mode == (+) ->
5465 TypeConditionList = TypeConditionList1
5466 ;
5467 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5468 )
5469 ),
5470 list2disj(TypeConditionList,DisjTypeConditionList),
5471 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5473 type_condition([],_,_,_,[]).
5474 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5475 ( var(DefCase) ->
5476 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5477 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5478 true
5479 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5480 true
5481 ;
5482 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5483 ),
5484 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5486 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5487 :- chr_type atomic_builtin_type ---> any
5488 ; number
5489 ; float
5490 ; int
5491 ; natural
5492 ; dense_int
5493 ; chr_identifier
5494 ; chr_identifier(any)
5495 ; /* all possible values are given
5496 */
5497 chr_enum(list(any))
5498 ; /* all values of interest are given
5499 for the other values a handler is provided */
5500 chr_enum(list(any),any)
5501 ; /* all possible values appear in rule heads;
5502 to distinguish between multiple chr_constants
5503 we have a key*/
5504 chr_constants(any)
5505 ; /* all relevant values appear in rule heads;
5506 for other values a handler is provided */
5507 chr_constants(any,any).
5508 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5510 ast_atomic_builtin_type(Type,AstTerm,Goal) :-
5511 ast_term_to_term(AstTerm,Term),
5512 atomic_builtin_type(Type,Term,Goal).
5514 ast_compound_builtin_type(Type,AstTerm,Goal) :-
5515 ast_term_to_term(AstTerm,Term),
5516 compound_builtin_type(Type,Term,_,Goal).
5518 atomic_builtin_type(any,_Arg,true).
5519 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5520 atomic_builtin_type(int,Arg,integer(Arg)).
5521 atomic_builtin_type(number,Arg,number(Arg)).
5522 atomic_builtin_type(float,Arg,float(Arg)).
5523 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5524 atomic_builtin_type(chr_identifier,_Arg,true).
5526 compound_builtin_type(chr_constants(_),_Arg,true,true).
5527 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5528 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5529 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5530 once(( member(Constant,Constants),
5531 unifiable(Arg,Constant,_)
5532 )
5533 )
5534 ).
5535 compound_builtin_type(chr_enum(_,_),Arg,true,true).
5537 is_chr_constants_type(chr_constants(Key),Key,no).
5538 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5540 is_chr_enum_type(chr_enum(Constants), Constants, no).
5541 is_chr_enum_type(chr_enum(Constants,Handler), Constants, yes(Handler)).
5543 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5544 ( nonvar(DefCase) ->
5545 functor(DefCase,F,A),
5546 ( A == 0 ->
5547 Condition = (Arg = DefCase)
5548 ; var(UnrollArg) ->
5549 Condition = functor(Arg,F,A)
5550 ; functor(UnrollArg,F,A) ->
5551 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5552 DefCase =.. [_|ArgTypes],
5553 UnrollArg =.. [_|UnrollArgs],
5554 functor(Template,F,A),
5555 Template =.. [_|TemplateArgs],
5556 replicate(A,Mode,ArgModes),
5557 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5558 ;
5559 Condition = functor(Arg,F,A)
5560 )
5561 ;
5562 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5563 ).
5566 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5567 % STATIC TYPE CHECKING
5568 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5569 % Checks head constraints and CHR constraint calls in bodies.
5570 %
5571 % TODO:
5572 % - type clashes involving built-in types
5573 % - Prolog built-ins in guard and body
5574 % - indicate position in terms in error messages
5575 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5576 :- chr_constraint
5577 static_type_check/2.
5579 % 1. Check the declared types
5581 constraint_type(Constraint,ArgTypes), static_type_check(_,_)
5582 ==>
5583 forall(
5584 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5585 ( get_type_definition(Type,_) ->
5586 true
5587 ;
5588 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5589 )
5590 ).
5592 % 2. Check the rules
5594 :- chr_type type_error_src ---> head(any) ; body(any).
5596 static_type_check(PragmaRules,AstRules)
5597 <=>
5598 maplist(static_type_check_rule,PragmaRules,AstRules).
5600 static_type_check_rule(PragmaRule,AstRule) :-
5601 AstRule = ast_rule(AstHead,_AstGuard,_Guard,AstBody,_Body),
5602 (
5603 catch(
5604 ( ast_static_type_check_head(AstHead),
5605 ast_static_type_check_body(AstBody)
5606 ),
5607 type_error(Error),
5608 ( Error = invalid_functor(Src,Term,Type) ->
5609 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5610 [chr_translate:format_src(Src),format_rule(PragmaRule),Term,Type])
5611 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5612 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5613 [Var,format_rule(PragmaRule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5614 )
5615 ),
5616 fail % cleanup constraints
5617 ;
5618 true
5619 ).
5621 %------------------------------------------------------------------------------%
5622 % Static Type Checking: Head Constraints {{{
5623 ast_static_type_check_head(simplification(AstConstraints)) :-
5624 maplist(ast_static_type_check_head_constraint,AstConstraints).
5625 ast_static_type_check_head(propagation(AstConstraints)) :-
5626 maplist(ast_static_type_check_head_constraint,AstConstraints).
5627 ast_static_type_check_head(simpagation(AstConstraints1,AstConstraints2)) :-
5628 maplist(ast_static_type_check_head_constraint,AstConstraints1),
5629 maplist(ast_static_type_check_head_constraint,AstConstraints2).
5631 ast_static_type_check_head_constraint(AstConstraint) :-
5632 AstConstraint = chr_constraint(Symbol,Arguments,_),
5633 get_constraint_type_det(Symbol,Types),
5634 maplist(ast_static_type_check_term(head(Head)),Arguments,Types).
5635 % }}}
5636 %------------------------------------------------------------------------------%
5637 % Static Type Checking: Terms {{{
5638 :- chr_constraint ast_static_type_check_term/3.
5639 :- chr_option(mode,ast_static_type_check_term(?,?,?)).
5640 :- chr_option(type_declaration,ast_static_type_check_term(type_error_src,any,any)).
5642 ast_static_type_check_term(_,_,any)
5643 <=>
5644 true.
5646 ast_static_type_check_term(Src,var(Id,Var),Type)
5647 <=>
5648 ast_static_type_check_var(Id,var(Id,Var),Type,Src).
5650 ast_static_type_check_term(Src,Term,Type)
5651 <=>
5652 ast_atomic_builtin_type(Type,Term,Goal)
5653 |
5654 ( call(Goal) ->
5655 true
5656 ;
5657 throw(type_error(invalid_functor(Src,Term,Type)))
5658 ).
5659 ast_static_type_check_term(Src,Term,Type)
5660 <=>
5661 ast_compound_builtin_type(Type,Term,Goal)
5662 |
5663 ( call(Goal) ->
5664 true
5665 ;
5666 throw(type_error(invalid_functor(Src,Term,Type)))
5667 ).
5668 type_alias(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5669 <=>
5670 functor(Type,F,A),
5671 functor(AType,F,A)
5672 |
5673 copy_term_nat(AType-ADef,Type-Def),
5674 ast_static_type_check_term(Src,Term,Def).
5676 type_definition(AType,ADef) \ ast_static_type_check_term(Src,Term,Type)
5677 <=>
5678 functor(Type,F,A),
5679 functor(AType,F,A)
5680 |
5681 copy_term_nat(AType-ADef,Type-Variants),
5682 ast_functor(Term,TF,TA),
5683 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5684 ast_args(Term,Args),
5685 Variant =.. [_|Types],
5686 maplist(ast_static_type_check_term(Src),Args,Types)
5687 ;
5688 throw(type_error(invalid_functor(Src,Term,Type)))
5689 ).
5691 ast_static_type_check_term(Src,Term,Type)
5692 <=>
5693 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5694 % }}}
5695 %------------------------------------------------------------------------------%
5696 % Static Type Checking: Variables {{{
5698 :- chr_constraint ast_static_type_check_var/4.
5699 :- chr_option(mode,ast_static_type_check_var(+,?,?,?)).
5700 :- chr_option(type_declaration,ast_static_type_check_var(var_id,any,any,type_error_src)).
5702 type_alias(AType,ADef) \ ast_static_type_check_var(VarId,Var,Type,Src)
5703 <=>
5704 functor(AType,F,A),
5705 functor(Type,F,A)
5706 |
5707 copy_term_nat(AType-ADef,Type-Def),
5708 ast_static_type_check_var(VarId,Var,Def,Src).
5710 ast_static_type_check_var(VarId,Var,Type,Src)
5711 <=>
5712 atomic_builtin_type(Type,_,_)
5713 |
5714 ast_static_atomic_builtin_type_check_var(VarId,Var,Type,Src).
5716 ast_static_type_check_var(VarId,Var,Type,Src)
5717 <=>
5718 compound_builtin_type(Type,_,_,_)
5719 |
5720 true.
5723 ast_static_type_check_var(VarId,Var,Type1,Src1), ast_static_type_check_var(VarId,_Var,Type2,Src2)
5724 <=>
5725 Type1 \== Type2
5726 |
5727 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5729 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5730 :- chr_constraint ast_static_atomic_builtin_type_check_var/4.
5731 :- chr_option(mode,ast_static_atomic_builtin_type_check_var(+,?,+,?)).
5732 :- chr_option(type_declaration,ast_static_atomic_builtin_type_check_var(var_id,any,atomic_builtin_type,type_error_src)).
5734 ast_static_atomic_builtin_type_check_var(_,_,any,_) <=> true.
5735 ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_)
5736 <=>
5737 true.
5738 ast_static_atomic_builtin_type_check_var(VarId,_,float,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5739 <=>
5740 true.
5741 ast_static_atomic_builtin_type_check_var(VarId,_,int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5742 <=>
5743 true.
5744 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5745 <=>
5746 true.
5747 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_)
5748 <=>
5749 true.
5750 ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5751 <=>
5752 true.
5753 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_)
5754 <=>
5755 true.
5756 ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,natural,_)
5757 <=>
5758 true.
5759 ast_static_atomic_builtin_type_check_var(VarId,Var,Type1,Src1), ast_static_atomic_builtin_type_check_var(VarId,_Var,Type2,Src2)
5760 <=>
5761 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5762 % }}}
5763 %------------------------------------------------------------------------------%
5764 % Static Type Checking: Bodies {{{
5765 ast_static_type_check_body([]).
5766 ast_static_type_check_body([Goal|Goals]) :-
5767 ast_symbol(Goal,Symbol),
5768 get_constraint_type_det(Symbol,Types),
5769 ast_args(Goal,Args),
5770 maplist(ast_static_type_check_term(body(Goal)),Args,Types),
5771 ast_static_type_check_body(Goals).
5773 % }}}
5774 %------------------------------------------------------------------------------%
5776 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5777 %% format_src(+type_error_src) is det.
5778 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5779 format_src(head(Head)) :- format('head ~w',[Head]).
5780 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5782 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5783 % Dynamic type checking
5784 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5786 :- chr_constraint
5787 dynamic_type_check/0,
5788 dynamic_type_check_clauses/1,
5789 get_dynamic_type_check_clauses/1.
5791 generate_dynamic_type_check_clauses(Clauses) :-
5792 ( chr_pp_flag(debugable,on) ->
5793 dynamic_type_check,
5794 get_dynamic_type_check_clauses(Clauses0),
5795 append(Clauses0,
5796 [('$dynamic_type_check'(Type,Term) :-
5797 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5798 )],
5799 Clauses)
5800 ;
5801 Clauses = []
5802 ).
5804 type_definition(T,D), dynamic_type_check
5805 ==>
5806 copy_term_nat(T-D,Type-Definition),
5807 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5808 dynamic_type_check_clauses(DynamicChecks).
5809 type_alias(A,B), dynamic_type_check
5810 ==>
5811 copy_term_nat(A-B,Alias-Body),
5812 dynamic_type_check_alias_clause(Alias,Body,Clause),
5813 dynamic_type_check_clauses([Clause]).
5815 dynamic_type_check <=>
5816 findall(
5817 ('$dynamic_type_check'(Type,Term) :- Goal),
5818 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5819 BuiltinChecks
5820 ),
5821 dynamic_type_check_clauses(BuiltinChecks).
5823 dynamic_type_check_clause(T,DC,Clause) :-
5824 copy_term(T-DC,Type-DefinitionClause),
5825 functor(DefinitionClause,F,A),
5826 functor(Term,F,A),
5827 DefinitionClause =.. [_|DCArgs],
5828 Term =.. [_|TermArgs],
5829 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5830 list2conj(RecursiveCallList,RecursiveCalls),
5831 Clause = (
5832 '$dynamic_type_check'(Type,Term) :-
5833 RecursiveCalls
5834 ).
5836 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5837 Clause = (
5838 '$dynamic_type_check'(Alias,Term) :-
5839 '$dynamic_type_check'(Body,Term)
5840 ).
5842 dynamic_type_check_call(Type,Term,Call) :-
5843 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5844 % Call = when(nonvar(Term),Goal)
5845 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5846 % Call = when(nonvar(Term),Goal)
5847 % ;
5848 ( Type == any ->
5849 Call = true
5850 ;
5851 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5852 )
5853 % )
5854 .
5856 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5857 <=>
5858 append(C1,C2,C),
5859 dynamic_type_check_clauses(C).
5861 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5862 <=>
5863 Q = C.
5864 get_dynamic_type_check_clauses(Q)
5865 <=>
5866 Q = [].
5868 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5869 % Atomic Types
5870 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5871 % Some optimizations can be applied for atomic types...
5872 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5874 atomic_types_suspended_constraint(C) :-
5875 C = _/N,
5876 get_constraint_type(C,ArgTypes),
5877 get_constraint_mode(C,ArgModes),
5878 numlist(1,N,Indexes),
5879 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5881 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5882 ( is_indexed_argument(C,Index) ->
5883 ( Mode == (?) ->
5884 atomic_type(Type)
5885 ;
5886 true
5887 )
5888 ;
5889 true
5890 ).
5892 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5893 %% atomic_type(+Type) is semidet.
5894 %
5895 % Succeeds when all values of =Type= are atomic.
5896 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5897 :- chr_constraint atomic_type/1.
5899 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5901 type_definition(TypePat,Def) \ atomic_type(Type)
5902 <=>
5903 functor(Type,F,A), functor(TypePat,F,A)
5904 |
5905 maplist(atomic,Def).
5907 type_alias(TypePat,Alias) \ atomic_type(Type)
5908 <=>
5909 functor(Type,F,A), functor(TypePat,F,A)
5910 |
5911 atomic(Alias),
5912 copy_term_nat(TypePat-Alias,Type-NType),
5913 atomic_type(NType).
5915 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5916 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5917 %
5918 % Succeeds when all values of =Type= are atomic
5919 % and the atom values are finitely enumerable.
5920 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5921 :- chr_constraint enumerated_atomic_type/2.
5923 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5925 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5926 <=>
5927 functor(Type,F,A), functor(TypePat,F,A)
5928 |
5929 maplist(atomic,Def),
5930 Atoms = Def.
5932 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5933 <=>
5934 functor(Type,F,A), functor(TypePat,F,A)
5935 |
5936 atomic(Alias),
5937 copy_term_nat(TypePat-Alias,Type-NType),
5938 enumerated_atomic_type(NType,Atoms).
5940 enumerated_atomic_type(_,_)
5941 <=>
5942 fail.
5943 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5945 :- chr_constraint
5946 stored/3, % constraint,occurrence,(yes/no/maybe)
5947 stored_completing/3,
5948 stored_complete/3,
5949 is_stored/1,
5950 is_finally_stored/1,
5951 check_all_passive/2.
5953 :- chr_option(mode,stored(+,+,+)).
5954 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5955 :- chr_type storedinfo ---> yes ; no ; maybe.
5956 :- chr_option(mode,stored_complete(+,+,+)).
5957 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5958 :- chr_option(mode,guard_list(+,+,+,+)).
5959 :- chr_option(mode,check_all_passive(+,+)).
5960 :- chr_option(type_declaration,check_all_passive(any,list)).
5962 % change yes in maybe when yes becomes passive
5963 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5964 stored(C,O,yes), stored_complete(C,RO,Yesses)
5965 <=> O < RO | NYesses is Yesses - 1,
5966 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5967 % change yes in maybe when not observed
5968 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5969 <=> O < RO |
5970 NYesses is Yesses - 1,
5971 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5973 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5974 ==> RO =< MO2 | % C2 is never stored
5975 passive(RuleNb,ID).
5980 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5982 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5983 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5984 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5986 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5987 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5988 check_all_passive(RuleNb,IDs2).
5990 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5991 check_all_passive(RuleNb,IDs).
5993 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5994 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5996 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5998 % collect the storage information
5999 stored(C,O,yes) \ stored_completing(C,O,Yesses)
6000 <=> NO is O + 1, NYesses is Yesses + 1,
6001 stored_completing(C,NO,NYesses).
6002 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
6003 <=> NO is O + 1,
6004 stored_completing(C,NO,Yesses).
6006 stored(C,O,no) \ stored_completing(C,O,Yesses)
6007 <=> stored_complete(C,O,Yesses).
6008 stored_completing(C,O,Yesses)
6009 <=> stored_complete(C,O,Yesses).
6011 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
6012 O2 > O | passive(RuleNb,Id).
6014 % decide whether a constraint is stored
6015 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
6016 <=> RO =< MO | fail.
6017 is_stored(C) <=> true.
6019 % decide whether a constraint is suspends after occurrences
6020 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
6021 <=> RO =< MO | fail.
6022 is_finally_stored(C) <=> true.
6024 storage_analysis(Constraints) :-
6025 ( chr_pp_flag(storage_analysis,on) ->
6026 check_constraint_storages(Constraints)
6027 ;
6028 true
6029 ).
6031 check_constraint_storages(Symbols) :- maplist(check_constraint_storage,Symbols).
6033 check_constraint_storage(C) :-
6034 get_max_occurrence(C,MO),
6035 check_occurrences_storage(C,1,MO).
6037 check_occurrences_storage(C,O,MO) :-
6038 ( O > MO ->
6039 stored_completing(C,1,0)
6040 ;
6041 check_occurrence_storage(C,O),
6042 NO is O + 1,
6043 check_occurrences_storage(C,NO,MO)
6044 ).
6046 check_occurrence_storage(C,O) :-
6047 get_occurrence(C,O,RuleNb,ID,OccType),
6048 ( is_passive(RuleNb,ID) ->
6049 stored(C,O,maybe)
6050 ;
6051 get_rule(RuleNb,PragmaRule),
6052 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
6053 ( OccType == simplification, select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6054 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
6055 ; OccType == propagation, select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6056 check_storage_head2(Head2,O,Heads1,Body)
6057 )
6058 ).
6060 check_storage_head1(Head,O,H1,H2,G) :-
6061 functor(Head,F,A),
6062 C = F/A,
6063 ( H1 == [Head],
6064 H2 == [],
6065 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
6066 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
6067 Head =.. [_|L],
6068 no_matching(L,[]) ->
6069 stored(C,O,no)
6070 ;
6071 stored(C,O,maybe)
6072 ).
6074 no_matching([],_).
6075 no_matching([X|Xs],Prev) :-
6076 var(X),
6077 \+ memberchk_eq(X,Prev),
6078 no_matching(Xs,[X|Prev]).
6080 check_storage_head2(Head,O,H1,B) :-
6081 functor(Head,F,A),
6082 C = F/A,
6083 ( %(
6084 ( H1 \== [], B == true )
6085 %;
6086 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
6087 %)
6088 ->
6089 stored(C,O,maybe)
6090 ;
6091 stored(C,O,yes)
6092 ).
6094 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6096 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6097 %% ____ _ ____ _ _ _ _
6098 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
6099 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
6100 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
6101 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
6102 %% |_|
6104 constraints_code(Constraints,Clauses) :-
6105 (chr_pp_flag(reduced_indexing,on),
6106 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
6107 none_suspended_on_variables
6108 ;
6109 true
6110 ),
6111 constraints_code1(Constraints,Clauses,[]).
6113 %===============================================================================
6114 :- chr_constraint constraints_code1/3.
6115 :- chr_option(mode,constraints_code1(+,+,+)).
6116 :- chr_option(type_declaration,constraints_code1(list,any,any)).
6117 %-------------------------------------------------------------------------------
6118 constraints_code1([],L,T) <=> L = T.
6119 constraints_code1([C|RCs],L,T)
6120 <=>
6121 constraint_code(C,L,T1),
6122 constraints_code1(RCs,T1,T).
6123 %===============================================================================
6124 :- chr_constraint constraint_code/3.
6125 :- chr_option(mode,constraint_code(+,+,+)).
6126 %-------------------------------------------------------------------------------
6127 %% Generate code for a single CHR constraint
6128 constraint_code(Constraint, L, T)
6129 <=> true
6130 | ( (chr_pp_flag(debugable,on) ;
6131 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
6132 ( may_trigger(Constraint) ;
6133 get_allocation_occurrence(Constraint,AO),
6134 get_max_occurrence(Constraint,MO), MO >= AO ) )
6135 ->
6136 constraint_prelude(Constraint,Clause),
6137 add_dummy_location(Clause,LocatedClause),
6138 L = [LocatedClause | L1]
6139 ;
6140 L = L1
6141 ),
6142 Id = [0],
6143 occurrences_code(Constraint,1,Id,NId,L1,L2),
6144 gen_cond_attach_clause(Constraint,NId,L2,T).
6146 %===============================================================================
6147 %% Generate prelude predicate for a constraint.
6148 %% f(...) :- f/a_0(...,Susp).
6149 constraint_prelude(F/A, Clause) :-
6150 vars_susp(A,Vars,Susp,VarsSusp),
6151 Head =.. [ F | Vars],
6152 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
6153 build_head(F,A,[0],VarsSusp,Delegate),
6154 ( chr_pp_flag(debugable,on) ->
6155 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
6156 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
6157 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6158 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
6160 ( get_constraint_type(F/A,ArgTypeList) ->
6161 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
6162 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
6163 ;
6164 DynamicTypeChecks = true
6165 ),
6167 Clause =
6168 ( Head :-
6169 DynamicTypeChecks,
6170 InsertGoal,
6171 InsertCall,
6172 AttachCall,
6173 Inactive,
6174 'chr debug_event'(insert(Head#Susp)),
6175 (
6176 'chr debug_event'(call(Susp)),
6177 Delegate
6178 ;
6179 'chr debug_event'(fail(Susp)), !,
6180 fail
6181 ),
6182 (
6183 'chr debug_event'(exit(Susp))
6184 ;
6185 'chr debug_event'(redo(Susp)),
6186 fail
6187 )
6188 )
6189 ; get_allocation_occurrence(F/A,0) ->
6190 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6191 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6192 Clause = ( Head :- Goal, Inactive, Delegate )
6193 ;
6194 Clause = ( Head :- Delegate )
6195 ).
6197 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6198 ( may_trigger(F/A) ->
6199 build_head(F,A,[0],VarsSusp,Delegate),
6200 ( chr_pp_flag(debugable,off) ->
6201 Goal = Delegate
6202 ;
6203 get_target_module(Mod),
6204 Goal = Mod:Delegate
6205 )
6206 ;
6207 Goal = true
6208 ).
6210 %===============================================================================
6211 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6212 :- chr_option(mode,has_active_occurrence(+)).
6213 :- chr_option(mode,has_active_occurrence(+,+)).
6215 :- chr_constraint memo_has_active_occurrence/1.
6216 :- chr_option(mode,memo_has_active_occurrence(+)).
6217 %-------------------------------------------------------------------------------
6218 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6219 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6221 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6222 O > MO | fail.
6223 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6224 has_active_occurrence(C,O) <=>
6225 NO is O + 1,
6226 has_active_occurrence(C,NO).
6227 has_active_occurrence(C,O) <=> true.
6228 %===============================================================================
6230 gen_cond_attach_clause(F/A,Id,L,T) :-
6231 ( is_finally_stored(F/A) ->
6232 get_allocation_occurrence(F/A,AllocationOccurrence),
6233 get_max_occurrence(F/A,MaxOccurrence),
6234 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6235 ( only_ground_indexed_arguments(F/A) ->
6236 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6237 ;
6238 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6239 )
6240 ; vars_susp(A,Args,Susp,AllArgs),
6241 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6242 ),
6243 build_head(F,A,Id,AllArgs,Head),
6244 Clause = ( Head :- Body ),
6245 add_dummy_location(Clause,LocatedClause),
6246 L = [LocatedClause | T]
6247 ;
6248 L = T
6249 ).
6251 :- chr_constraint use_auxiliary_predicate/1.
6252 :- chr_option(mode,use_auxiliary_predicate(+)).
6254 :- chr_constraint use_auxiliary_predicate/2.
6255 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6257 :- chr_constraint is_used_auxiliary_predicate/1.
6258 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6260 :- chr_constraint is_used_auxiliary_predicate/2.
6261 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6264 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6266 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6268 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6270 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6272 is_used_auxiliary_predicate(P) <=> fail.
6274 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6275 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6277 is_used_auxiliary_predicate(P,C) <=> fail.
6279 %------------------------------------------------------------------------------%
6280 % Only generate import statements for actually used modules.
6281 %------------------------------------------------------------------------------%
6283 :- chr_constraint use_auxiliary_module/1.
6284 :- chr_option(mode,use_auxiliary_module(+)).
6286 :- chr_constraint is_used_auxiliary_module/1.
6287 :- chr_option(mode,is_used_auxiliary_module(+)).
6290 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6292 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6294 is_used_auxiliary_module(P) <=> fail.
6296 % only called for constraints with
6297 % at least one
6298 % non-ground indexed argument
6299 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6300 vars_susp(A,Args,Susp,AllArgs),
6301 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6302 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6303 Attach = true
6304 ;
6305 attach_constraint_atom(F/A,Vars,Susp,Attach)
6306 ),
6307 FTerm =.. [F|Args],
6308 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6309 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6310 ( may_trigger(F/A) ->
6311 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6312 Goal =
6313 (
6314 ( var(Susp) ->
6315 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6316 InsertCall,
6317 Attach
6318 ;
6319 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6320 )
6321 )
6322 ;
6323 Goal =
6324 (
6325 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6326 InsertCall,
6327 Attach
6328 )
6329 ).
6331 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6332 vars_susp(A,Args,Susp,AllArgs),
6333 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6334 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6335 attach_constraint_atom(F/A,Vars,Susp,Attach)
6336 ;
6337 Attach = true
6338 ),
6339 FTerm =.. [F|Args],
6340 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6341 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6342 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6343 Goal =
6344 (
6345 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6346 InsertCall
6347 )
6348 ;
6349 Goal =
6350 (
6351 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6352 InsertCall,
6353 Attach
6354 )
6355 ).
6357 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6358 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6359 attach_constraint_atom(FA,Vars,Susp,Attach)
6360 ;
6361 Attach = true
6362 ),
6363 insert_constraint_goal(FA,Susp,Args,InsertCall),
6364 ( chr_pp_flag(late_allocation,on) ->
6365 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6366 ;
6367 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6368 ).
6370 %-------------------------------------------------------------------------------
6371 :- chr_constraint occurrences_code/6.
6372 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6373 %-------------------------------------------------------------------------------
6374 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6375 <=> O > MO
6376 | NId = Id, L = T.
6377 occurrences_code(C,O,Id,NId,L,T)
6378 <=>
6379 occurrence_code(C,O,Id,Id1,L,L1),
6380 NO is O + 1,
6381 occurrences_code(C,NO,Id1,NId,L1,T).
6382 %-------------------------------------------------------------------------------
6383 :- chr_constraint occurrence_code/6.
6384 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6385 %-------------------------------------------------------------------------------
6386 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6387 <=>
6388 ( named_history(RuleNb,_,_) ->
6389 does_use_history(C,O)
6390 ;
6391 true
6392 ),
6393 NId = Id,
6394 L = T.
6395 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6396 <=> true |
6397 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6398 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6399 NId = Id,
6400 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6401 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6403 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6404 ( should_skip_to_next_id(C,O) ->
6405 inc_id(Id,NId),
6406 ( unconditional_occurrence(C,O) ->
6407 L1 = T
6408 ;
6409 gen_alloc_inc_clause(C,O,Id,L1,T)
6410 )
6411 ;
6412 NId = Id,
6413 L1 = T
6414 )
6415 ).
6417 occurrence_code(C,O,_,_,_,_)
6418 <=>
6419 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6420 %-------------------------------------------------------------------------------
6422 %% Generate code based on one removed head of a CHR rule
6423 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6424 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6425 Rule = rule(_,Head2,_,_),
6426 ( Head2 == [] ->
6427 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6428 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6429 ;
6430 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6431 ).
6433 %% Generate code based on one persistent head of a CHR rule
6434 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6435 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6436 Rule = rule(Head1,_,_,_),
6437 ( Head1 == [] ->
6438 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6439 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6440 ;
6441 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6442 ).
6444 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6445 vars_susp(A,Vars,Susp,VarsSusp),
6446 build_head(F,A,Id,VarsSusp,Head),
6447 inc_id(Id,IncId),
6448 build_head(F,A,IncId,VarsSusp,CallHead),
6449 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6450 Clause =
6451 (
6452 Head :-
6453 ConditionalAlloc,
6454 CallHead
6455 ),
6456 add_dummy_location(Clause,LocatedClause),
6457 L = [LocatedClause|T].
6459 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6460 get_allocation_occurrence(FA,AO),
6461 get_occurrence_code_id(FA,AO,AId),
6462 get_occurrence_code_id(FA,O,Id),
6463 ( chr_pp_flag(debugable,off), Id == AId ->
6464 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6465 ( may_trigger(FA) ->
6466 Goal = (var(Susp) -> Goal0 ; true)
6467 ;
6468 Goal = Goal0
6469 )
6470 ;
6471 Goal = true
6472 ).
6474 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6475 get_allocation_occurrence(FA,AO),
6476 ( chr_pp_flag(debugable,off), O < AO ->
6477 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6478 ( may_trigger(FA) ->
6479 Goal = (var(Susp) -> Goal0 ; true)
6480 ;
6481 Goal = Goal0
6482 )
6483 ;
6484 Goal = true
6485 ).
6487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6489 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6490 %
6491 % Reorders guard goals with respect to partner constraint retrieval goals and
6492 % active constraint. Returns combined partner retrieval + guard goal.
6494 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6495 ( chr_pp_flag(guard_via_reschedule,on) ->
6496 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6497 list2conj(ScheduleSkeleton,GoalSkeleton)
6498 ;
6499 length(Retrievals,RL), length(LookupSkeleton,RL),
6500 length(GuardList,GL), length(GuardListSkeleton,GL),
6501 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6502 list2conj(GoalListSkeleton,GoalSkeleton)
6503 ).
6504 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6505 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6506 initialize_unit_dictionary(ActiveHead,Dict),
6507 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6508 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6509 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6510 dependency_reorder(Units,NUnits),
6511 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6512 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6513 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6515 wrappedunits2lists([],[],[],[]).
6516 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6517 Ss = [GoalCopy|TSs],
6518 ( WrappedGoal = lookup(Goal) ->
6519 Ls = [GoalCopy|TLs],
6520 Gs = TGs
6521 ; WrappedGoal = guard(Goal) ->
6522 Gs = [N-GoalCopy|TGs],
6523 Ls = TLs
6524 ),
6525 wrappedunits2lists(Units,TGs,TLs,TSs).
6527 guard_splitting(Rule,SplitGuardList) :-
6528 Rule = rule(H1,H2,Guard,_),
6529 append(H1,H2,Heads),
6530 conj2list(Guard,GuardList),
6531 term_variables(Heads,HeadVars),
6532 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6533 append(GuardPrefix,[RestGuard],SplitGuardList),
6534 term_variables(RestGuardList,GuardVars1),
6535 % variables that are declared to be ground don't need to be locked
6536 ground_vars(Heads,GroundVars),
6537 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6538 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6539 maplist(chr_lock,GuardVars,Locks),
6540 maplist(chr_unlock,GuardVars,Unlocks),
6541 list2conj(Locks,LockPhase),
6542 list2conj(Unlocks,UnlockPhase),
6543 list2conj(RestGuardList,RestGuard1),
6544 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6546 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6547 Rule = rule(_,_,_,Body),
6548 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6549 my_term_copy(Body,VarDict2,BodyCopy).
6552 split_off_simple_guard_new([],_,[],[]).
6553 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6554 ( simple_guard_new(G,VarDict) ->
6555 S = [G|Ss],
6556 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6557 ;
6558 S = [],
6559 C = [G|Gs]
6560 ).
6562 % simple guard: cheap and benign (does not bind variables)
6563 simple_guard_new(G,Vars) :-
6564 builtin_binds_b(G,BoundVars),
6565 not(( member(V,BoundVars),
6566 memberchk_eq(V,Vars)
6567 )).
6569 dependency_reorder(Units,NUnits) :-
6570 dependency_reorder(Units,[],NUnits).
6572 dependency_reorder([],Acc,Result) :-
6573 reverse(Acc,Result).
6575 dependency_reorder([Unit|Units],Acc,Result) :-
6576 Unit = unit(_GID,_Goal,Type,GIDs),
6577 ( Type == fixed ->
6578 NAcc = [Unit|Acc]
6579 ;
6580 dependency_insert(Acc,Unit,GIDs,NAcc)
6581 ),
6582 dependency_reorder(Units,NAcc,Result).
6584 dependency_insert([],Unit,_,[Unit]).
6585 dependency_insert([X|Xs],Unit,GIDs,L) :-
6586 X = unit(GID,_,_,_),
6587 ( memberchk(GID,GIDs) ->
6588 L = [Unit,X|Xs]
6589 ;
6590 L = [X | T],
6591 dependency_insert(Xs,Unit,GIDs,T)
6592 ).
6594 build_units(Retrievals,Guard,InitialDict,Units) :-
6595 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6596 build_guard_units(Guard,N,Dict,Tail).
6598 build_retrieval_units([],N,N,Dict,Dict,L,L).
6599 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6600 term_variables(U,Vs),
6601 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6602 L = [unit(N,U,fixed,GIDs)|L1],
6603 N1 is N + 1,
6604 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6606 initialize_unit_dictionary(Term,Dict) :-
6607 term_variables(Term,Vars),
6608 pair_all_with(Vars,0,Dict).
6610 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6611 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6612 ( lookup_eq(Dict,V,GID) ->
6613 ( (GID == This ; memberchk(GID,GIDs) ) ->
6614 GIDs1 = GIDs
6615 ;
6616 GIDs1 = [GID|GIDs]
6617 ),
6618 Dict1 = Dict
6619 ;
6620 Dict1 = [V - This|Dict],
6621 GIDs1 = GIDs
6622 ),
6623 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6625 build_guard_units(Guard,N,Dict,Units) :-
6626 ( Guard = [Goal] ->
6627 Units = [unit(N,Goal,fixed,[])]
6628 ; Guard = [Goal|Goals] ->
6629 term_variables(Goal,Vs),
6630 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6631 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6632 N1 is N + 1,
6633 build_guard_units(Goals,N1,NDict,RUnits)
6634 ).
6636 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6637 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6638 ( lookup_eq(Dict,V,GID) ->
6639 ( (GID == This ; memberchk(GID,GIDs) ) ->
6640 GIDs1 = GIDs
6641 ;
6642 GIDs1 = [GID|GIDs]
6643 ),
6644 Dict1 = [V - This|Dict]
6645 ;
6646 Dict1 = [V - This|Dict],
6647 GIDs1 = GIDs
6648 ),
6649 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6651 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6653 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6654 %% ____ _ ____ _ _
6655 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6656 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6657 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6658 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6659 %%
6660 %% _ _ _ ___ __
6661 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6662 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6663 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6664 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6665 %% |_|
6666 :- chr_constraint
6667 functional_dependency/4,
6668 get_functional_dependency/4.
6670 :- chr_option(mode,functional_dependency(+,+,?,?)).
6671 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6673 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6674 <=>
6675 RuleNb > 1, AO > O
6676 |
6677 functional_dependency(C,1,Pattern,Key).
6679 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6680 <=>
6681 RuleNb2 >= RuleNb1
6682 |
6683 QPattern = Pattern, QKey = Key.
6684 get_functional_dependency(_,_,_,_)
6685 <=>
6686 fail.
6688 functional_dependency_analysis(Rules) :-
6689 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6690 functional_dependency_analysis_main(Rules)
6691 ;
6692 true
6693 ).
6695 functional_dependency_analysis_main([]).
6696 functional_dependency_analysis_main([PRule|PRules]) :-
6697 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6698 functional_dependency(C,RuleNb,Pattern,Key)
6699 ;
6700 true
6701 ),
6702 functional_dependency_analysis_main(PRules).
6704 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6705 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6706 Rule = rule(H1,H2,Guard,_),
6707 ( H1 = [C1],
6708 H2 = [C2] ->
6709 true
6710 ; H1 = [C1,C2],
6711 H2 == [] ->
6712 true
6713 ),
6714 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6715 term_variables(C1,Vs),
6716 \+ (
6717 member(V1,Vs),
6718 lookup_eq(List,V1,V2),
6719 memberchk_eq(V2,Vs)
6720 ),
6721 select_pragma_unique_variables(Vs,List,Key1),
6722 copy_term_nat(C1-Key1,Pattern-Key),
6723 functor(C1,F,A).
6725 select_pragma_unique_variables([],_,[]).
6726 select_pragma_unique_variables([V|Vs],List,L) :-
6727 ( lookup_eq(List,V,_) ->
6728 L = T
6729 ;
6730 L = [V|T]
6731 ),
6732 select_pragma_unique_variables(Vs,List,T).
6734 % depends on functional dependency analysis
6735 % and shape of rule: C1 \ C2 <=> true.
6736 set_semantics_rules(Rules) :-
6737 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6738 set_semantics_rules_main(Rules)
6739 ;
6740 true
6741 ).
6743 set_semantics_rules_main([]).
6744 set_semantics_rules_main([R|Rs]) :-
6745 set_semantics_rule_main(R),
6746 set_semantics_rules_main(Rs).
6748 set_semantics_rule_main(PragmaRule) :-
6749 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6750 ( Rule = rule([C1],[C2],true,_),
6751 IDs = ids([ID1],[ID2]),
6752 \+ is_passive(RuleNb,ID1),
6753 functor(C1,F,A),
6754 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6755 copy_term_nat(Pattern-Key,C1-Key1),
6756 copy_term_nat(Pattern-Key,C2-Key2),
6757 Key1 == Key2 ->
6758 passive(RuleNb,ID2)
6759 ;
6760 true
6761 ).
6763 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6764 \+ any_passive_head(RuleNb),
6765 variable_replacement(C1-C2,C2-C1,List),
6766 copy_with_variable_replacement(G,OtherG,List),
6767 negate_b(G,NotG),
6768 once(entails_b(NotG,OtherG)).
6770 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6771 % where C1 and C2 are symmteric constraints
6772 symmetry_analysis(Rules) :-
6773 ( chr_pp_flag(check_unnecessary_active,off) ->
6774 true
6775 ;
6776 symmetry_analysis_main(Rules)
6777 ).
6779 symmetry_analysis_main([]).
6780 symmetry_analysis_main([R|Rs]) :-
6781 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6782 Rule = rule(H1,H2,_,_),
6783 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6784 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6785 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6786 ;
6787 true
6788 ),
6789 symmetry_analysis_main(Rs).
6791 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6792 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6793 ( \+ is_passive(RuleNb,ID),
6794 member2(PreHs,PreIDs,PreH-PreID),
6795 \+ is_passive(RuleNb,PreID),
6796 variable_replacement(PreH,H,List),
6797 copy_with_variable_replacement(Rule,Rule2,List),
6798 identical_guarded_rules(Rule,Rule2) ->
6799 passive(RuleNb,ID)
6800 ;
6801 true
6802 ),
6803 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6805 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6806 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6807 ( \+ is_passive(RuleNb,ID),
6808 member2(PreHs,PreIDs,PreH-PreID),
6809 \+ is_passive(RuleNb,PreID),
6810 variable_replacement(PreH,H,List),
6811 copy_with_variable_replacement(Rule,Rule2,List),
6812 identical_rules(Rule,Rule2) ->
6813 passive(RuleNb,ID)
6814 ;
6815 true
6816 ),
6817 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6819 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6821 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6822 %% ____ _ _ _ __ _ _ _
6823 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6824 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6825 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6826 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6827 %% |_|
6828 %% {{{
6830 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,Symbol,O,Id,L,T) :-
6831 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6832 head_info1(Head,Symbol,_Vars,Susp,HeadVars,HeadPairs),
6833 build_head(Symbol,Id,HeadVars,ClauseHead),
6834 get_constraint_mode(Symbol,Mode),
6835 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6838 guard_splitting(Rule,GuardList0),
6839 ( is_stored_in_guard(Symbol, RuleNb) ->
6840 GuardList = [Hole1|GuardList0]
6841 ;
6842 GuardList = GuardList0
6843 ),
6844 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6846 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6848 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6850 ( is_stored_in_guard(Symbol, RuleNb) ->
6851 gen_occ_allocation_in_guard(Symbol,O,Vars,Susp,Allocation),
6852 gen_uncond_attach_goal(Symbol,Susp,Vars,Attachment,_),
6853 GuardCopyList = [Hole1Copy|_],
6854 Hole1Copy = (Allocation, Attachment)
6855 ;
6856 true
6857 ),
6860 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6861 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6863 ( chr_pp_flag(debugable,on) ->
6864 Rule = rule(_,_,Guard,Body),
6865 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6866 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6867 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6868 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6869 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6870 ;
6871 Cut = ActualCut
6872 ),
6873 actual_cut(Symbol,O,ActualCut),
6874 Clause = ( ClauseHead :-
6875 FirstMatching,
6876 RescheduledTest,
6877 Cut,
6878 SuspsDetachments,
6879 SuspDetachment,
6880 BodyCopy
6881 ),
6882 add_location(Clause,RuleNb,LocatedClause),
6883 L = [LocatedClause | T].
6885 actual_cut(Symbol,Occurrence,ActualCut) :-
6886 ( unconditional_occurrence(Symbol,Occurrence),
6887 chr_pp_flag(late_allocation,on) ->
6888 ActualCut = true
6889 ;
6890 ActualCut = (!)
6891 ).
6892 % }}}
6894 add_location(Clause,RuleNb,NClause) :-
6895 ( chr_pp_flag(line_numbers,on) ->
6896 get_chr_source_file(File),
6897 get_line_number(RuleNb,LineNb),
6898 NClause = '$source_location'(File,LineNb):Clause
6899 ;
6900 NClause = Clause
6901 ).
6903 add_dummy_location(Clause,NClause) :-
6904 ( chr_pp_flag(line_numbers,on) ->
6905 get_chr_source_file(File),
6906 NClause = '$source_location'(File,1):Clause
6907 ;
6908 NClause = Clause
6909 ).
6910 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6911 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6912 %
6913 % Return goal matching newly introduced variables with variables in
6914 % previously looked-up heads.
6915 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6916 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6917 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6919 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6920 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6921 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6922 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6923 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6924 list2conj(GoalList,Goal).
6926 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6927 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6928 ( Mode == (+) ->
6929 term_variables(Arg,GroundVars0,GroundVars),
6930 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6931 ;
6932 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6933 ).
6934 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6935 ( var(Arg) ->
6936 ( lookup_eq(VarDict,Arg,OtherVar) ->
6937 ( Mode = (+) ->
6938 ( memberchk_eq(Arg,GroundVars) ->
6939 GoalList = [Var = OtherVar | RestGoalList],
6940 GroundVars1 = GroundVars
6941 ;
6942 GoalList = [Var == OtherVar | RestGoalList],
6943 GroundVars1 = [Arg|GroundVars]
6944 )
6945 ;
6946 GoalList = [Var == OtherVar | RestGoalList],
6947 GroundVars1 = GroundVars
6948 ),
6949 VarDict1 = VarDict
6950 ;
6951 VarDict1 = [Arg-Var | VarDict],
6952 GoalList = RestGoalList,
6953 ( Mode = (+) ->
6954 GroundVars1 = [Arg|GroundVars]
6955 ;
6956 GroundVars1 = GroundVars
6957 )
6958 ),
6959 Pairs = Rest,
6960 RestModes = Modes
6961 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6962 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6963 GoalList = [Goal|RestGoalList],
6964 VarDict = VarDict1,
6965 GroundVars1 = GroundVars,
6966 Pairs = Rest,
6967 RestModes = Modes
6968 ; atomic(Arg) ->
6969 ( Mode = (+) ->
6970 GoalList = [ Var = Arg | RestGoalList]
6971 ;
6972 GoalList = [ Var == Arg | RestGoalList]
6973 ),
6974 VarDict = VarDict1,
6975 GroundVars1 = GroundVars,
6976 Pairs = Rest,
6977 RestModes = Modes
6978 ; Mode == (+), is_ground(GroundVars,Arg) ->
6979 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6980 GoalList = [ Var = ArgCopy | RestGoalList],
6981 VarDict = VarDict1,
6982 GroundVars1 = GroundVars,
6983 Pairs = Rest,
6984 RestModes = Modes
6985 ; Mode == (?), is_ground(GroundVars,Arg) ->
6986 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6987 GoalList = [ Var == ArgCopy | RestGoalList],
6988 VarDict = VarDict1,
6989 GroundVars1 = GroundVars,
6990 Pairs = Rest,
6991 RestModes = Modes
6992 ; Arg =.. [_|Args],
6993 functor(Arg,Fct,N),
6994 functor(Term,Fct,N),
6995 Term =.. [_|Vars],
6996 ( Mode = (+) ->
6997 GoalList = [ Var = Term | RestGoalList ]
6998 ;
6999 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
7000 ),
7001 pairup(Args,Vars,NewPairs),
7002 append(NewPairs,Rest,Pairs),
7003 replicate(N,Mode,NewModes),
7004 append(NewModes,Modes,RestModes),
7005 VarDict1 = VarDict,
7006 GroundVars1 = GroundVars
7007 ),
7008 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
7010 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7011 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
7012 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7013 add_heads_types([],VarTypes,VarTypes).
7014 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
7015 add_head_types(Head,VarTypes,VarTypes1),
7016 add_heads_types(Heads,VarTypes1,NVarTypes).
7018 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7019 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
7020 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7021 add_head_types(Head,VarTypes,NVarTypes) :-
7022 functor(Head,F,A),
7023 get_constraint_type_det(F/A,ArgTypes),
7024 Head =.. [_|Args],
7025 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
7027 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7028 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
7029 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7030 add_args_types([],[],VarTypes,VarTypes).
7031 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
7032 add_arg_types(Arg,Type,VarTypes,VarTypes1),
7033 add_args_types(Args,Types,VarTypes1,NVarTypes).
7035 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7036 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
7037 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7038 % OPTIMIZATION: don't add if `any'
7039 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
7040 ( Type == any ->
7041 NVarTypes = VarTypes
7042 ; var(Term) ->
7043 ( lookup_eq(VarTypes,Term,_) ->
7044 NVarTypes = VarTypes
7045 ;
7046 NVarTypes = [Term-Type|VarTypes]
7047 )
7048 ; % nonvar
7049 NVarTypes = VarTypes % approximate with any
7050 ).
7054 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7055 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
7056 %
7057 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7058 add_heads_ground_variables([],GroundVars,GroundVars).
7059 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
7060 add_head_ground_variables(Head,GroundVars,GroundVars1),
7061 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
7063 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7064 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
7065 %
7066 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7067 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
7068 functor(Head,F,A),
7069 get_constraint_mode(F/A,ArgModes),
7070 Head =.. [_|Args],
7071 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
7074 add_arg_ground_variables([],[],GroundVars,GroundVars).
7075 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
7076 ( Mode == (+) ->
7077 term_variables(Arg,Vars),
7078 add_var_ground_variables(Vars,GroundVars,GroundVars1)
7079 ;
7080 GroundVars = GroundVars1
7081 ),
7082 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
7084 add_var_ground_variables([],GroundVars,GroundVars).
7085 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
7086 ( memberchk_eq(Var,GroundVars) ->
7087 GroundVars1 = GroundVars
7088 ;
7089 GroundVars1 = [Var|GroundVars]
7090 ),
7091 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
7092 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7093 %% is_ground(+GroundVars,+Term) is semidet.
7094 %
7095 % Determine whether =Term= is always ground.
7096 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7097 is_ground(GroundVars,Term) :-
7098 ( ground(Term) ->
7099 true
7100 ; compound(Term) ->
7101 Term =.. [_|Args],
7102 maplist(is_ground(GroundVars),Args)
7103 ;
7104 memberchk_eq(Term,GroundVars)
7105 ).
7107 %% check_ground(+GroundVars,+Term,-Goal) is det.
7108 %
7109 % Return runtime check to see whether =Term= is ground.
7110 check_ground(GroundVars,Term,Goal) :-
7111 term_variables(Term,Variables),
7112 check_ground_variables(Variables,GroundVars,Goal).
7114 check_ground_variables([],_,true).
7115 check_ground_variables([Var|Vars],GroundVars,Goal) :-
7116 ( memberchk_eq(Var,GroundVars) ->
7117 check_ground_variables(Vars,GroundVars,Goal)
7118 ;
7119 Goal = (ground(Var), RGoal),
7120 check_ground_variables(Vars,GroundVars,RGoal)
7121 ).
7123 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
7124 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
7126 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
7127 ( Heads = [_|_] ->
7128 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
7129 ;
7130 GoalList = [],
7131 Susps = [],
7132 VarDict = NVarDict,
7133 GroundVars = NGroundVars
7134 ).
7136 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
7137 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
7138 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
7139 functor(H,F,A),
7140 head_info(H,A,Vars,_,_,Pairs),
7141 get_store_type(F/A,StoreType),
7142 ( StoreType == default ->
7143 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
7144 delay_phase_end(validate_store_type_assumptions,
7145 ( static_suspension_term(F/A,Suspension),
7146 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
7147 get_static_suspension_field(F/A,Suspension,state,active,GetState)
7148 )
7149 ),
7150 % create_get_mutable_ref(active,State,GetMutable),
7151 get_constraint_mode(F/A,Mode),
7152 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7153 NPairs = Pairs,
7154 sbag_member_call(Susp,VarSusps,Sbag),
7155 ExistentialLookup = (
7156 ViaGoal,
7157 Sbag,
7158 Susp = Suspension, % not inlined
7159 GetState
7160 ),
7161 inline_matching_goal(MatchingGoal,MatchingGoal2)
7162 ;
7163 delay_phase_end(validate_store_type_assumptions,
7164 ( static_suspension_term(F/A,Suspension),
7165 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7166 )
7167 ),
7168 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7169 get_constraint_mode(F/A,Mode),
7170 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7171 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
7172 filter_append(NPairs,VarDict1,DA_), % order important here
7173 translate(GroundVars1,DA_,GroundVarsA),
7174 translate(GroundVars1,VarDict1,GroundVarsB),
7175 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB)
7176 ),
7177 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7178 Goal =
7179 (
7180 ExistentialLookup,
7181 DiffSuspGoals,
7182 MatchingGoal2
7183 ),
7184 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7186 inline_matching_goal(G1,G2) :-
7187 inline_matching_goal(G1,G2,[],[]).
7189 inline_matching_goal(A==B,true,GVA,GVB) :-
7190 memberchk_eq(A,GVA),
7191 memberchk_eq(B,GVB),
7192 A=B, !.
7193 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7194 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7195 inline_matching_goal(A,A2,GVA,GVB),
7196 inline_matching_goal(B,B2,GVA,GVB).
7197 inline_matching_goal(X,X,_,_).
7200 filter_mode([],_,_,[]).
7201 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7202 ( Var == V ->
7203 Modes = [M|MT],
7204 filter_mode(Rest,R,Ms,MT)
7205 ;
7206 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7207 ).
7209 filter_append([],VarDict,VarDict).
7210 filter_append([X|Xs],VarDict,NVarDict) :-
7211 ( X = silent(_) ->
7212 filter_append(Xs,VarDict,NVarDict)
7213 ;
7214 NVarDict = [X|NVarDict0],
7215 filter_append(Xs,VarDict,NVarDict0)
7216 ).
7218 check_unique_keys([],_).
7219 check_unique_keys([V|Vs],Dict) :-
7220 lookup_eq(Dict,V,_),
7221 check_unique_keys(Vs,Dict).
7223 % Generates tests to ensure the found constraint differs from previously found constraints
7224 % TODO: detect more cases where constraints need be different
7225 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7226 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7227 list2conj(DiffSuspGoalList,DiffSuspGoals).
7229 different_from_other_susps_(_,[],_,_,[]) :- !.
7230 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7231 ( functor(Head,F,A), functor(PreHead,F,A),
7232 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7233 \+ \+ PreHeadCopy = HeadCopy ->
7235 List = [Susp \== PreSusp | Tail]
7236 ;
7237 List = Tail
7238 ),
7239 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7241 % passive_head_via(in,in,in,in,out,out,out) :-
7242 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7243 functor(Head,F,A),
7244 get_constraint_index(F/A,Pos),
7245 /* which static variables may contain runtime variables */
7246 common_variables(Head,PrevHeads,CommonVars0),
7247 ground_vars([Head],GroundVars),
7248 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7249 /********************************************************/
7250 global_list_store_name(F/A,Name),
7251 GlobalGoal = nb_getval(Name,AllSusps),
7252 get_constraint_mode(F/A,ArgModes),
7253 ( Vars == [] ->
7254 Goal = GlobalGoal
7255 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7256 translate([CommonVar],VarDict,[Var]),
7257 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7258 Goal = AttrGoal
7259 ;
7260 translate(CommonVars,VarDict,Vars),
7261 add_heads_types(PrevHeads,[],TypeDict),
7262 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7263 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7264 Goal =
7265 ( ViaGoal ->
7266 AttrGoal
7267 ;
7268 GlobalGoal
7269 )
7270 ).
7272 common_variables(T,Ts,Vs) :-
7273 term_variables(T,V1),
7274 term_variables(Ts,V2),
7275 intersect_eq(V1,V2,Vs).
7277 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7278 via_goal(Vars,TypeDict,ViaGoal,Var),
7279 get_target_module(Mod),
7280 AttrGoal =
7281 ( get_attr(Var,Mod,TSusps),
7282 TSuspsEqSusps % TSusps = Susps
7283 ),
7284 get_max_constraint_index(N),
7285 ( N == 1 ->
7286 TSuspsEqSusps = true, % TSusps = Susps
7287 AllSusps = TSusps
7288 ;
7289 get_constraint_index(FA,Pos),
7290 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7291 ).
7292 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7293 ( Vars = [] ->
7294 ViaGoal = fail
7295 ; Vars = [A] ->
7296 lookup_type(TypeDict,A,Type),
7297 ( atomic_type(Type) ->
7298 ViaGoal = var(A),
7299 A = Var
7300 ;
7301 ViaGoal = 'chr newvia_1'(A,Var)
7302 )
7303 ; Vars = [A,B] ->
7304 ViaGoal = 'chr newvia_2'(A,B,Var)
7305 ;
7306 ViaGoal = 'chr newvia'(Vars,Var)
7307 ).
7308 lookup_type(TypeDict,Var,Type) :-
7309 ( lookup_eq(TypeDict,Var,Type) ->
7310 true
7311 ;
7312 Type = any % default type
7313 ).
7314 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7315 get_target_module(Mod),
7316 AttrGoal =
7317 ( get_attr(Var,Mod,TSusps),
7318 TSuspsEqSusps % TSusps = Susps
7319 ),
7320 get_max_constraint_index(N),
7321 ( N == 1 ->
7322 TSuspsEqSusps = true, % TSusps = Susps
7323 AllSusps = TSusps
7324 ;
7325 get_constraint_index(FA,Pos),
7326 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7327 ).
7329 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7330 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7331 list2conj(GuardCopyList,GuardCopy).
7333 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7334 Rule = rule(_,H,Guard,Body),
7335 conj2list(Guard,GuardList),
7336 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7337 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7339 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7340 term_variables(RestGuardList,GuardVars),
7341 term_variables(RestGuardListCopyCore,GuardCopyVars),
7342 % variables that are declared to be ground don't need to be locked
7343 ground_vars(H,GroundVars),
7344 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7345 ( chr_pp_flag(guard_locks,off) ->
7346 Locks = [],
7347 Unlocks = []
7348 ;
7349 bagof(Lock - Unlock,
7350 X ^ Y ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7351 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7352 memberchk_eq(Y,GuardCopyVars), % redundant check? or multiple entries for X possible?
7353 chr_lock(Y,Lock),
7354 chr_unlock(Y,Unlock)
7355 ),
7356 LocksUnlocks) ->
7357 once(pairup(Locks,Unlocks,LocksUnlocks))
7358 ;
7359 Locks = [],
7360 Unlocks = []
7361 ),
7362 list2conj(Locks,LockPhase),
7363 list2conj(Unlocks,UnlockPhase),
7364 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7365 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7366 my_term_copy(Body,VarDict2,BodyCopy).
7369 split_off_simple_guard([],_,[],[]).
7370 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7371 ( simple_guard(G,VarDict) ->
7372 S = [G|Ss],
7373 split_off_simple_guard(Gs,VarDict,Ss,C)
7374 ;
7375 S = [],
7376 C = [G|Gs]
7377 ).
7379 % simple guard: cheap and benign (does not bind variables)
7380 simple_guard(G,VarDict) :-
7381 binds_b(G,Vars),
7382 \+ (( member(V,Vars),
7383 lookup_eq(VarDict,V,_)
7384 )).
7386 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7387 functor(Head,F,A),
7388 C = F/A,
7389 ( is_stored(C) ->
7390 (
7391 (
7392 Id == [0], chr_pp_flag(store_in_guards, off)
7393 ;
7394 ( get_allocation_occurrence(C,AO),
7395 get_max_occurrence(C,MO),
7396 MO < AO )
7397 ),
7398 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7399 SuspDetachment = true
7400 ;
7401 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7402 ( chr_pp_flag(late_allocation,on) ->
7403 SuspDetachment =
7404 ( var(Susp) ->
7405 true
7406 ;
7407 UnCondSuspDetachment
7408 )
7409 ;
7410 SuspDetachment = UnCondSuspDetachment
7411 )
7412 )
7413 ;
7414 SuspDetachment = true
7415 ).
7417 partner_constraint_detachments([],[],_,true).
7418 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7419 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7420 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7422 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7423 functor(Head,F,A),
7424 C = F/A,
7425 ( is_stored(C) ->
7426 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7427 ( chr_pp_flag(debugable,on) ->
7428 DebugEvent = 'chr debug_event'(remove(Susp))
7429 ;
7430 DebugEvent = true
7431 ),
7432 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7433 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7434 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7435 detach_constraint_atom(C,Vars,Susp,Detach)
7436 ;
7437 Detach = true
7438 )
7439 ;
7440 SuspDetachment = true
7441 ).
7443 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7445 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7446 %% ____ _ _ _ _
7447 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7448 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7449 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7450 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7451 %% |_| |___/
7452 %% {{{
7454 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7455 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7456 Rule = rule(_Heads,Heads2,Guard,Body),
7458 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7459 get_constraint_mode(F/A,Mode),
7460 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7462 build_head(F,A,Id,HeadVars,ClauseHead),
7464 append(RestHeads,Heads2,Heads),
7465 append(OtherIDs,Heads2IDs,IDs),
7466 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7468 guard_splitting(Rule,GuardList0),
7469 ( is_stored_in_guard(F/A, RuleNb) ->
7470 GuardList = [Hole1|GuardList0]
7471 ;
7472 GuardList = GuardList0
7473 ),
7474 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7476 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7477 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7479 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7481 ( is_stored_in_guard(F/A, RuleNb) ->
7482 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7483 GuardCopyList = [Hole1Copy|_],
7484 Hole1Copy = Attachment
7485 ;
7486 true
7487 ),
7489 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7490 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7491 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7493 ( chr_pp_flag(debugable,on) ->
7494 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7495 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7496 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7497 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7498 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7499 instrument_goal((!),DebugTry,DebugApply,Cut)
7500 ;
7501 Cut = (!)
7502 ),
7504 Clause = ( ClauseHead :-
7505 FirstMatching,
7506 RescheduledTest,
7507 Cut,
7508 SuspsDetachments,
7509 SuspDetachment,
7510 BodyCopy
7511 ),
7512 add_location(Clause,RuleNb,LocatedClause),
7513 L = [LocatedClause | T].
7515 % }}}
7517 split_by_ids([],[],_,[],[]).
7518 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7519 ( memberchk_eq(I,I1s) ->
7520 S1s = [S | R1s],
7521 S2s = R2s
7522 ;
7523 S1s = R1s,
7524 S2s = [S | R2s]
7525 ),
7526 split_by_ids(Is,Ss,I1s,R1s,R2s).
7528 split_by_ids([],[],_,[],[],[],[]).
7529 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7530 ( memberchk_eq(I,I1s) ->
7531 S1s = [S | R1s],
7532 SI1s = [I|RSI1s],
7533 S2s = R2s,
7534 SI2s = RSI2s
7535 ;
7536 S1s = R1s,
7537 SI1s = RSI1s,
7538 S2s = [S | R2s],
7539 SI2s = [I|RSI2s]
7540 ),
7541 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7542 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7545 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7546 %% ____ _ _ _ ____
7547 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7548 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7549 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7550 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7551 %% |_| |___/
7553 %% Genereate prelude + worker predicate
7554 %% prelude calls worker
7555 %% worker iterates over one type of removed constraints
7556 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7557 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7558 Rule = rule(Heads1,_,Guard,Body),
7559 append(Heads1,RestHeads2,Heads),
7560 append(IDs1,RestIDs,IDs),
7561 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7562 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7563 extend_id(Id,Id1),
7564 ( memberchk_eq(NID,IDs2) ->
7565 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7566 ;
7567 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7568 ),
7569 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7570 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7572 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7573 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7574 Heads = [Head|RHeads],
7575 inc_id(Id,Id1),
7576 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7577 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7578 ( memberchk_eq(ID,IDs2) ->
7579 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7580 ;
7581 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7582 ).
7584 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7585 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7586 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7587 build_head(F,A,Id1,VarsSusp,ClauseHead),
7588 get_constraint_mode(F/A,Mode),
7589 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7591 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7593 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7595 extend_id(Id1,DelegateId),
7596 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7597 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7598 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7600 PreludeClause =
7601 ( ClauseHead :-
7602 FirstMatching,
7603 ModConstraintsGoal,
7604 !,
7605 ConstraintAllocationGoal,
7606 Delegate
7607 ),
7608 add_dummy_location(PreludeClause,LocatedPreludeClause),
7609 L = [LocatedPreludeClause|T].
7611 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7612 Term =.. [_|Args],
7613 delegate_variables(Term,Terms,VarDict,Args,Vars).
7615 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7616 term_variables(PrevTerms,PrevVars),
7617 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7619 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7620 term_variables(Term,V1),
7621 term_variables(Terms,V2),
7622 intersect_eq(V1,V2,V3),
7623 list_difference_eq(V3,PrevVars,V4),
7624 translate(V4,VarDict,Vars).
7627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7628 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7629 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7630 Rule = rule(_,_,Guard,Body),
7631 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7633 gen_var(OtherSusp),
7634 gen_var(OtherSusps),
7636 functor(CurrentHead,OtherF,OtherA),
7637 gen_vars(OtherA,OtherVars),
7638 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7639 get_constraint_mode(OtherF/OtherA,Mode),
7640 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7642 delay_phase_end(validate_store_type_assumptions,
7643 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7644 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7645 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7646 )
7647 ),
7648 % create_get_mutable_ref(active,State,GetMutable),
7649 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7650 CurrentSuspTest = (
7651 OtherSusp = OtherSuspension,
7652 GetState,
7653 DiffSuspGoals,
7654 FirstMatching
7655 ),
7657 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7658 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7660 guard_splitting(Rule,GuardList0),
7661 ( is_stored_in_guard(F/A, RuleNb) ->
7662 GuardList = [Hole1|GuardList0]
7663 ;
7664 GuardList = GuardList0
7665 ),
7666 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7668 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7669 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7670 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7672 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7674 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7675 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7676 RecursiveVars2 = [[]|PreVarsAndSusps],
7677 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7679 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7680 ( is_stored_in_guard(F/A, RuleNb) ->
7681 GuardCopyList = [GuardAttachment|_] % once( ) ??
7682 ;
7683 true
7684 ),
7686 ( is_observed(F/A,O) ->
7687 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7688 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7689 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7690 ;
7691 Attachment = true,
7692 ConditionalRecursiveCall = RecursiveCall,
7693 ConditionalRecursiveCall2 = RecursiveCall2
7694 ),
7696 ( chr_pp_flag(debugable,on) ->
7697 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7698 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7699 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7700 ;
7701 DebugTry = true,
7702 DebugApply = true
7703 ),
7705 ( is_stored_in_guard(F/A, RuleNb) ->
7706 GuardAttachment = Attachment,
7707 BodyAttachment = true
7708 ;
7709 GuardAttachment = true,
7710 BodyAttachment = Attachment % will be true if not observed at all
7711 ),
7713 ( member(unique(ID1,UniqueKeys), Pragmas),
7714 check_unique_keys(UniqueKeys,VarDict) ->
7715 Clause =
7716 ( ClauseHead :-
7717 ( CurrentSuspTest ->
7718 ( RescheduledTest,
7719 DebugTry ->
7720 DebugApply,
7721 Susps1Detachments,
7722 BodyAttachment,
7723 BodyCopy,
7724 ConditionalRecursiveCall2
7725 ;
7726 RecursiveCall2
7727 )
7728 ;
7729 RecursiveCall
7730 )
7731 )
7732 ;
7733 Clause =
7734 ( ClauseHead :-
7735 ( CurrentSuspTest,
7736 RescheduledTest,
7737 DebugTry ->
7738 DebugApply,
7739 Susps1Detachments,
7740 BodyAttachment,
7741 BodyCopy,
7742 ConditionalRecursiveCall
7743 ;
7744 RecursiveCall
7745 )
7746 )
7747 ),
7748 add_location(Clause,RuleNb,LocatedClause),
7749 L = [LocatedClause | T].
7751 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7752 ( may_trigger(FA) ->
7753 does_use_field(FA,generation),
7754 delay_phase_end(validate_store_type_assumptions,
7755 ( static_suspension_term(FA,Suspension),
7756 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7757 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7758 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7759 )
7760 )
7761 ;
7762 delay_phase_end(validate_store_type_assumptions,
7763 ( static_suspension_term(FA,Suspension),
7764 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7765 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7766 )
7767 ),
7768 GetGeneration = true
7769 ),
7770 ConditionalCall =
7771 ( Susp = Suspension,
7772 GetState,
7773 GetGeneration ->
7774 UpdateState,
7775 Call
7776 ;
7777 true
7778 ).
7780 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7784 %% ____ _ _
7785 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7786 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7787 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7788 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7789 %% |_| |___/
7791 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7792 ( RestHeads == [] ->
7793 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7794 ;
7795 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7796 ).
7797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7798 %% Single headed propagation
7799 %% everything in a single clause
7800 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7801 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7802 build_head(F,A,Id,VarsSusp,ClauseHead),
7804 inc_id(Id,NextId),
7805 build_head(F,A,NextId,VarsSusp,NextHead),
7807 get_constraint_mode(F/A,Mode),
7808 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7809 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7811 % - recursive call -
7812 RecursiveCall = NextHead,
7814 actual_cut(F/A,O,ActualCut),
7816 Rule = rule(_,_,Guard,Body),
7817 ( chr_pp_flag(debugable,on) ->
7818 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7819 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7820 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7821 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7822 ;
7823 Cut = ActualCut
7824 ),
7825 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7826 use_auxiliary_predicate(novel_production),
7827 use_auxiliary_predicate(extend_history),
7828 does_use_history(F/A,O),
7829 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7831 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7832 ( HistoryIDs == [] ->
7833 empty_named_history_novel_production(HistoryName,NovelProduction),
7834 empty_named_history_extend_history(HistoryName,ExtendHistory)
7835 ;
7836 Tuple = HistoryName
7837 )
7838 ;
7839 Tuple = RuleNb
7840 ),
7842 ( var(NovelProduction) ->
7843 NovelProduction = '$novel_production'(Susp,Tuple),
7844 ExtendHistory = '$extend_history'(Susp,Tuple)
7845 ;
7846 true
7847 ),
7849 ( is_observed(F/A,O) ->
7850 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7851 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7852 ;
7853 Attachment = true,
7854 ConditionalRecursiveCall = RecursiveCall
7855 )
7856 ;
7857 Allocation = true,
7858 NovelProduction = true,
7859 ExtendHistory = true,
7861 ( is_observed(F/A,O) ->
7862 get_allocation_occurrence(F/A,AllocO),
7863 ( O == AllocO ->
7864 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7865 Generation = 0
7866 ; % more room for improvement?
7867 Attachment = (Attachment1, Attachment2),
7868 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7869 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7870 ),
7871 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7872 ;
7873 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7874 ConditionalRecursiveCall = RecursiveCall
7875 )
7876 ),
7878 ( is_stored_in_guard(F/A, RuleNb) ->
7879 GuardAttachment = Attachment,
7880 BodyAttachment = true
7881 ;
7882 GuardAttachment = true,
7883 BodyAttachment = Attachment % will be true if not observed at all
7884 ),
7886 Clause = (
7887 ClauseHead :-
7888 HeadMatching,
7889 Allocation,
7890 NovelProduction,
7891 GuardAttachment,
7892 GuardCopy,
7893 Cut,
7894 ExtendHistory,
7895 BodyAttachment,
7896 BodyCopy,
7897 ConditionalRecursiveCall
7898 ),
7899 add_location(Clause,RuleNb,LocatedClause),
7900 ProgramList = [LocatedClause | ProgramTail].
7902 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7903 %% multi headed propagation
7904 %% prelude + predicates to accumulate the necessary combinations of suspended
7905 %% constraints + predicate to execute the body
7906 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7907 RestHeads = [First|Rest],
7908 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7909 extend_id(Id,ExtendedId),
7910 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7912 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7913 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7914 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7915 build_head(F,A,Id,VarsSusp,PreludeHead),
7916 get_constraint_mode(F/A,Mode),
7917 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7918 Rule = rule(_,_,Guard,Body),
7919 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7921 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7923 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7925 extend_id(Id,NestedId),
7926 append([Susps|VarsSusp],ExtraVars,NestedVars),
7927 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7928 NestedCall = NestedHead,
7930 Prelude = (
7931 PreludeHead :-
7932 FirstMatching,
7933 FirstSuspGoal,
7934 !,
7935 CondAllocation,
7936 NestedCall
7937 ),
7938 add_dummy_location(Prelude,LocatedPrelude),
7939 L = [LocatedPrelude|T].
7941 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7942 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7943 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7944 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7946 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7947 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7948 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7949 inc_id(Id,IncId),
7950 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7952 %check_fd_lookup_condition(_,_,_,_) :- fail.
7953 check_fd_lookup_condition(F,A,_,_) :-
7954 get_store_type(F/A,global_singleton), !.
7955 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7956 \+ may_trigger(F/A),
7957 get_functional_dependency(F/A,1,P,K),
7958 copy_term(P-K,CurrentHead-Key),
7959 term_variables(PreHeads,PreVars),
7960 intersect_eq(Key,PreVars,Key),!.
7962 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7963 Rule = rule(_,H2,Guard,Body),
7964 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7965 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7966 init(AllSusps,RestSusps),
7967 last(AllSusps,Susp),
7968 gen_var(OtherSusp),
7969 gen_var(OtherSusps),
7970 functor(CurrentHead,OtherF,OtherA),
7971 gen_vars(OtherA,OtherVars),
7972 delay_phase_end(validate_store_type_assumptions,
7973 ( static_suspension_term(OtherF/OtherA,Suspension),
7974 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7975 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7976 )
7977 ),
7978 % create_get_mutable_ref(active,State,GetMutable),
7979 CurrentSuspTest = (
7980 OtherSusp = Suspension,
7981 GetState
7982 ),
7983 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7984 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7985 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7986 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7987 RecursiveVars = PreVarsAndSusps1
7988 ;
7989 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7990 PrevId0 = Id
7991 ),
7992 ( PrevId0 = [_] ->
7993 PrevId = PrevId0
7994 ;
7995 PrevId = [O|PrevId0]
7996 ),
7997 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7998 RecursiveCall = RecursiveHead,
7999 CurrentHead =.. [_|OtherArgs],
8000 pairup(OtherArgs,OtherVars,OtherPairs),
8001 get_constraint_mode(OtherF/OtherA,Mode),
8002 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
8004 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
8005 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
8006 get_occurrence(F/A,O,_,ID),
8008 ( is_observed(F/A,O) ->
8009 init(FirstVarsSusp,FirstVars),
8010 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
8011 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
8012 ;
8013 Attachment = true,
8014 ConditionalRecursiveCall = RecursiveCall
8015 ),
8016 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
8017 NovelProduction = true,
8018 ExtendHistory = true
8019 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
8020 NovelProduction = true,
8021 ExtendHistory = true
8022 ;
8023 get_occurrence(F/A,O,_,ID),
8024 use_auxiliary_predicate(novel_production),
8025 use_auxiliary_predicate(extend_history),
8026 does_use_history(F/A,O),
8027 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
8028 ( HistoryIDs == [] ->
8029 empty_named_history_novel_production(HistoryName,NovelProduction),
8030 empty_named_history_extend_history(HistoryName,ExtendHistory)
8031 ;
8032 reverse([OtherSusp|RestSusps],NamedSusps),
8033 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
8034 HistorySusps = [HistorySusp|_],
8036 ( length(HistoryIDs, 1) ->
8037 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
8038 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
8039 ;
8040 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
8041 Tuple =.. [t,HistoryName|HistorySusps]
8042 )
8043 )
8044 ;
8045 HistorySusp = Susp,
8046 maplist(extract_symbol,H2,ConstraintSymbols),
8047 sort([ID|RestIDs],HistoryIDs),
8048 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
8049 Tuple =.. [t,RuleNb|HistorySusps]
8050 ),
8052 ( var(NovelProduction) ->
8053 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
8054 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
8055 NovelProduction = ( TupleVar = Tuple, NovelProductions )
8056 ;
8057 true
8058 )
8059 ),
8062 ( chr_pp_flag(debugable,on) ->
8063 Rule = rule(_,_,Guard,Body),
8064 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
8065 get_occurrence(F/A,O,_,ID),
8066 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
8067 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
8068 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
8069 ;
8070 DebugTry = true,
8071 DebugApply = true
8072 ),
8074 ( is_stored_in_guard(F/A, RuleNb) ->
8075 GuardAttachment = Attachment,
8076 BodyAttachment = true
8077 ;
8078 GuardAttachment = true,
8079 BodyAttachment = Attachment % will be true if not observed at all
8080 ),
8082 Clause = (
8083 ClauseHead :-
8084 ( CurrentSuspTest,
8085 DiffSuspGoals,
8086 Matching,
8087 NovelProduction,
8088 GuardAttachment,
8089 GuardCopy,
8090 DebugTry ->
8091 DebugApply,
8092 ExtendHistory,
8093 BodyAttachment,
8094 BodyCopy,
8095 ConditionalRecursiveCall
8096 ; RecursiveCall
8097 )
8098 ),
8099 add_location(Clause,RuleNb,LocatedClause),
8100 L = [LocatedClause|T].
8102 extract_symbol(Head,F/A) :-
8103 functor(Head,F,A).
8105 novel_production_calls([],[],[],_,_,true).
8106 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
8107 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
8108 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
8109 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
8111 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
8112 reverse(ReversedRestSusps,RestSusps),
8113 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
8115 named_history_susps([],_,_,[]).
8116 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
8117 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
8118 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
8122 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
8123 !,
8124 functor(Head,F,A),
8125 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
8126 get_constraint_mode(F/A,Mode),
8127 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
8128 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
8129 append(VarsSusp,ExtraVars,HeadVars).
8130 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
8131 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
8132 functor(Head,F,A),
8133 gen_var(Susps),
8134 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8135 get_constraint_mode(F/A,Mode),
8136 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8137 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8138 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
8140 % returns
8141 % VarDict for the copies of variables in the original heads
8142 % VarsSuspsList list of lists of arguments for the successive heads
8143 % FirstVarsSusp top level arguments
8144 % SuspList list of all suspensions
8145 % Iterators list of all iterators
8146 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
8147 !,
8148 functor(Head,F,A),
8149 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
8150 get_constraint_mode(F/A,Mode),
8151 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
8152 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
8153 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
8154 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
8155 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
8156 functor(Head,F,A),
8157 gen_var(Susps),
8158 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
8159 get_constraint_mode(F/A,Mode),
8160 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
8161 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
8162 append(HeadVars,[Susp,Susps],Vars).
8164 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
8165 !,
8166 functor(Head,F,A),
8167 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
8168 get_constraint_mode(F/A,Mode),
8169 head_arg_matches(Pairs,Mode,[],_,VarDict),
8170 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
8171 append(VarsSusp,ExtraVars,HeadVars).
8172 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
8173 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8174 functor(Head,F,A),
8175 gen_var(Susps),
8176 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8177 get_constraint_mode(F/A,Mode),
8178 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8179 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8180 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8182 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8184 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8185 %% ____ _ _ _ _
8186 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8187 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8188 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8189 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8190 %%
8191 %% ____ _ _ _
8192 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8193 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8194 %% | _ < __/ |_| | | | __/\ V / (_| | |
8195 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8196 %%
8197 %% ____ _ _
8198 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8199 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8200 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8201 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8202 %% |___/
8204 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8205 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8206 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8207 ;
8208 NRestHeads = RestHeads,
8209 NRestIDs = RestIDs
8210 ).
8212 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8213 term_variables(Head,Vars),
8214 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8215 copy_term_nat(InitialData,InitialDataCopy),
8216 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8217 InitialDataCopy = InitialData,
8218 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8219 reverse(RNRestHeads,NRestHeads),
8220 reverse(RNRestIDs,NRestIDs).
8222 final_data(Entry) :-
8223 Entry = entry(_,_,_,_,[],_).
8225 expand_data(Entry,NEntry,Cost) :-
8226 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8227 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8228 term_variables([Head1|Vars],Vars1),
8229 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8230 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8232 % Assigns score to head based on known variables and heads to lookup
8233 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8234 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8235 functor(Head,F,A),
8236 get_store_type(F/A,StoreType),
8237 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8238 % }}}
8240 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8241 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8242 term_variables(Head,HeadVars0),
8243 term_variables(RestHeads,RestVars),
8244 ground_vars([Head],GroundVars),
8245 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8246 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8247 NScore is min(CScore,Score).
8248 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8249 ( CScore =< 100 ->
8250 Score = CScore
8251 ;
8252 order_score_indexes(Indexes,Head,KnownVars,Score)
8253 ).
8254 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8255 ( CScore =< 100 ->
8256 Score = CScore
8257 ;
8258 order_score_indexes(Indexes,Head,KnownVars,Score)
8259 ).
8260 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8261 term_variables(Head,HeadVars),
8262 term_variables(RestHeads,RestVars),
8263 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8264 Score is Score_ * 200,
8265 NScore is min(CScore,Score).
8266 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8267 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8268 Score = 1. % guaranteed O(1)
8269 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8270 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8271 multi_order_score([],_,_,_,_,_,Score,Score).
8272 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8273 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8274 ; Score1 = Score0
8275 ),
8276 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8278 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8279 Score is min(CScore,10).
8280 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8281 Score is min(CScore,10).
8282 % }}}
8285 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8286 order_score_indexes(Indexes,Head,Vars,Score) :-
8287 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8288 numbervars(VarsCopy,0,_),
8289 order_score_indexes(Indexes,HeadCopy,Score).
8291 order_score_indexes([I|Is],Head,Score) :-
8292 args(I,Head,Args),
8293 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8294 Score = 100
8295 ;
8296 order_score_indexes(Is,Head,Score)
8297 ).
8298 % }}}
8300 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8302 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8303 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8304 ( K-R-O == 0-0-0 ->
8305 Score = 0
8306 ; K > 0 ->
8307 Score is max(10 - K,0)
8308 ; R > 0 ->
8309 Score is max(10 - R,1) * 100
8310 ;
8311 Score is max(10-O,1) * 1000
8312 ).
8313 order_score_count_vars([],_,_,0-0-0).
8314 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8315 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8316 ( memberchk_eq(V,KnownVars) ->
8317 NK is K + 1,
8318 NR = R, NO = O
8319 ; memberchk_eq(V,RestVars) ->
8320 NR is R + 1,
8321 NK = K, NO = O
8322 ;
8323 NO is O + 1,
8324 NK = K, NR = R
8325 ).
8327 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8328 %% ___ _ _ _
8329 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8330 %% | || '_ \| | | '_ \| | '_ \ / _` |
8331 %% | || | | | | | | | | | | | | (_| |
8332 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8333 %% |___/
8335 %% SWI begin
8336 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8337 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8338 %% SWI end
8340 %% SICStus begin
8341 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8342 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8343 %% SICStus end
8345 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8347 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8348 %% _ _ _ _ _ _ _
8349 %% | | | | |_(_) (_) |_ _ _
8350 %% | | | | __| | | | __| | | |
8351 %% | |_| | |_| | | | |_| |_| |
8352 %% \___/ \__|_|_|_|\__|\__, |
8353 %% |___/
8355 % Create a fresh variable.
8356 gen_var(_).
8358 % Create =N= fresh variables.
8359 gen_vars(N,Xs) :-
8360 length(Xs,N).
8362 ast_head_info1(AstHead,Vars,Susp,VarsSusp,HeadPairs) :-
8363 AstHead = chr_constraint(_/A,Args,_),
8364 vars_susp(A,Vars,Susp,VarsSusp),
8365 pairup(Args,Vars,HeadPairs).
8367 head_info1(Head,_/A,Vars,Susp,VarsSusp,HeadPairs) :-
8368 vars_susp(A,Vars,Susp,VarsSusp),
8369 Head =.. [_|Args],
8370 pairup(Args,Vars,HeadPairs).
8372 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8373 vars_susp(A,Vars,Susp,VarsSusp),
8374 Head =.. [_|Args],
8375 pairup(Args,Vars,HeadPairs).
8377 inc_id([N|Ns],[O|Ns]) :-
8378 O is N + 1.
8379 dec_id([N|Ns],[M|Ns]) :-
8380 M is N - 1.
8382 extend_id(Id,[0|Id]).
8384 next_id([_,N|Ns],[O|Ns]) :-
8385 O is N + 1.
8387 % return clause Head
8388 % for F/A constraint symbol, predicate identifier Id and arguments Head
8389 build_head(F/A,Id,Args,Head) :-
8390 build_head(F,A,Id,Args,Head).
8391 build_head(F,A,Id,Args,Head) :-
8392 buildName(F,A,Id,Name),
8393 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8394 ( may_trigger(F/A) ;
8395 get_allocation_occurrence(F/A,AO),
8396 get_max_occurrence(F/A,MO),
8397 MO >= AO ) ) ->
8398 Head =.. [Name|Args]
8399 ;
8400 init(Args,ArgsWOSusp), % XXX not entirely correct!
8401 Head =.. [Name|ArgsWOSusp]
8402 ).
8404 % return predicate name Result
8405 % for Fct/Aty constraint symbol and predicate identifier List
8406 buildName(Fct,Aty,List,Result) :-
8407 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8408 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8409 MO >= AO ) ; List \= [0])) ) ) ->
8410 atom_concat(Fct, '___' ,FctSlash),
8411 atomic_concat(FctSlash,Aty,FctSlashAty),
8412 buildName_(List,FctSlashAty,Result)
8413 ;
8414 Result = Fct
8415 ).
8417 buildName_([],Name,Name).
8418 buildName_([N|Ns],Name,Result) :-
8419 buildName_(Ns,Name,Name1),
8420 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8421 atomic_concat(NameDash,N,Result).
8423 vars_susp(A,Vars,Susp,VarsSusp) :-
8424 length(Vars,A),
8425 append(Vars,[Susp],VarsSusp).
8427 or_pattern(Pos,Pat) :-
8428 Pow is Pos - 1,
8429 Pat is 1 << Pow. % was 2 ** X
8431 and_pattern(Pos,Pat) :-
8432 X is Pos - 1,
8433 Y is 1 << X, % was 2 ** X
8434 Pat is (-1)*(Y + 1).
8436 make_name(Prefix,F/A,Name) :-
8437 atom_concat_list([Prefix,F,'___',A],Name).
8439 %===============================================================================
8440 % Attribute for attributed variables
8442 make_attr(N,Mask,SuspsList,Attr) :-
8443 length(SuspsList,N),
8444 Attr =.. [v,Mask|SuspsList].
8446 get_all_suspensions2(N,Attr,SuspensionsList) :-
8447 chr_pp_flag(dynattr,off), !,
8448 make_attr(N,_,SuspensionsList,Attr).
8450 % NEW
8451 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8452 % writeln(get_all_suspensions2),
8453 length(SuspensionsList,N),
8454 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8457 % NEW
8458 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8459 % writeln(normalize_attr),
8460 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8462 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8463 chr_pp_flag(dynattr,off),
8464 !, % chr_pp_flag(experiment,off), !,
8465 make_attr(N,_,SuspsList,Attr),
8466 nth1(Position,SuspsList,Suspensions).
8468 % get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8469 % chr_pp_flag(dynattr,off),
8470 % chr_pp_flag(experiment,on), !,
8471 % Position1 is Position + 1,
8472 % Goal = arg(Position1,TAttr,Suspensions).
8474 % NEW
8475 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8476 % writeln(get_suspensions),
8477 Goal =
8478 ( memberchk(Position-Suspensions,TAttr) ->
8479 true
8480 ;
8481 Suspensions = []
8482 ).
8484 %-------------------------------------------------------------------------------
8485 % +N: number of constraint symbols
8486 % +Suspension: source-level variable, for suspension
8487 % +Position: constraint symbol number
8488 % -Attr: source-level term, for new attribute
8489 singleton_attr(N,Suspension,Position,Attr) :-
8490 chr_pp_flag(dynattr,off), !,
8491 or_pattern(Position,Pattern),
8492 make_attr(N,Pattern,SuspsList,Attr),
8493 nth1(Position,SuspsList,[Suspension]),
8494 chr_delete(SuspsList,[Suspension],RestSuspsList),
8495 set_elems(RestSuspsList,[]).
8497 % NEW
8498 singleton_attr(N,Suspension,Position,Attr) :-
8499 % writeln(singleton_attr),
8500 Attr = [Position-[Suspension]].
8502 %-------------------------------------------------------------------------------
8503 % +N: number of constraint symbols
8504 % +Suspension: source-level variable, for suspension
8505 % +Position: constraint symbol number
8506 % +TAttr: source-level variable, for old attribute
8507 % -Goal: goal for creating new attribute
8508 % -NTAttr: source-level variable, for new attribute
8509 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8510 chr_pp_flag(dynattr,off), !,
8511 make_attr(N,Mask,SuspsList,Attr),
8512 or_pattern(Position,Pattern),
8513 nth1(Position,SuspsList,Susps),
8514 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8515 make_attr(N,Mask,SuspsList1,NewAttr1),
8516 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8517 make_attr(N,NewMask,SuspsList2,NewAttr2),
8518 Goal = (
8519 TAttr = Attr,
8520 ( Mask /\ Pattern =:= Pattern ->
8521 NTAttr = NewAttr1
8522 ;
8523 NewMask is Mask \/ Pattern,
8524 NTAttr = NewAttr2
8525 )
8526 ), !.
8528 % NEW
8529 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8530 % writeln(add_attr),
8531 Goal =
8532 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8533 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8534 ;
8535 NTAttr = [Position-[Suspension]|TAttr]
8536 ).
8538 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8539 chr_pp_flag(dynattr,off),
8540 chr_pp_flag(experiment,off), !,
8541 or_pattern(Position,Pattern),
8542 and_pattern(Position,DelPattern),
8543 make_attr(N,Mask,SuspsList,Attr),
8544 nth1(Position,SuspsList,Susps),
8545 substitute_eq(Susps,SuspsList,[],SuspsList1),
8546 make_attr(N,NewMask,SuspsList1,Attr1),
8547 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8548 make_attr(N,Mask,SuspsList2,Attr2),
8549 get_target_module(Mod),
8550 Goal = (
8551 TAttr = Attr,
8552 ( Mask /\ Pattern =:= Pattern ->
8553 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8554 ( NewSusps == [] ->
8555 NewMask is Mask /\ DelPattern,
8556 ( NewMask == 0 ->
8557 del_attr(Var,Mod)
8558 ;
8559 put_attr(Var,Mod,Attr1)
8560 )
8561 ;
8562 put_attr(Var,Mod,Attr2)
8563 )
8564 ;
8565 true
8566 )
8567 ), !.
8568 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8569 chr_pp_flag(dynattr,off),
8570 chr_pp_flag(experiment,on), !,
8571 or_pattern(Position,Pattern),
8572 and_pattern(Position,DelPattern),
8573 Position1 is Position + 1,
8574 get_target_module(Mod),
8575 Goal = (
8576 arg(1,TAttr,Mask),
8577 ( Mask /\ Pattern =:= Pattern ->
8578 arg(Position1,TAttr,Susps),
8579 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8580 ( NewSusps == [] ->
8581 NewMask is Mask /\ DelPattern,
8582 ( NewMask == 0 ->
8583 del_attr(Var,Mod)
8584 ;
8585 setarg(1,TAttr,NewMask),
8586 setarg(Position1,TAttr,NewSusps)
8587 )
8588 ;
8589 setarg(Position1,TAttr,NewSusps)
8590 )
8591 ;
8592 true
8593 )
8594 ), !.
8596 % NEW
8597 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8598 % writeln(rem_attr),
8599 get_target_module(Mod),
8600 Goal =
8601 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8602 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8603 ( NSuspensions == [] ->
8604 ( RAttr == [] ->
8605 del_attr(Var,Mod)
8606 ;
8607 put_attr(Var,Mod,RAttr)
8608 )
8609 ;
8610 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8611 )
8612 ;
8613 true
8614 ).
8616 %-------------------------------------------------------------------------------
8617 % +N: number of constraint symbols
8618 % +TAttr1: source-level variable, for attribute
8619 % +TAttr2: source-level variable, for other attribute
8620 % -Goal: goal for merging the two attributes
8621 % -Attr: source-level term, for merged attribute
8622 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8623 chr_pp_flag(dynattr,off), !,
8624 make_attr(N,Mask1,SuspsList1,Attr1),
8625 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8626 Goal = (
8627 TAttr1 = Attr1,
8628 Goal2
8629 ).
8631 % NEW
8632 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8633 % writeln(merge_attributes),
8634 Goal = (
8635 sort(TAttr1,Sorted1),
8636 sort(TAttr2,Sorted2),
8637 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8638 ).
8641 %-------------------------------------------------------------------------------
8642 % +N: number of constraint symbols
8643 % +Mask1: ...
8644 % +SuspsList1: static term, for suspensions list
8645 % +TAttr2: source-level variable, for other attribute
8646 % -Goal: goal for merging the two attributes
8647 % -Attr: source-level term, for merged attribute
8648 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8649 make_attr(N,Mask2,SuspsList2,Attr2),
8650 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8651 list2conj(Gs,SortGoals),
8652 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8653 make_attr(N,Mask,SuspsList,Attr),
8654 Goal = (
8655 TAttr2 = Attr2,
8656 SortGoals,
8657 Mask is Mask1 \/ Mask2
8658 ).
8661 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8662 % Storetype dependent lookup
8664 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8665 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8666 %% -Goal,-SuspensionList) is det.
8667 %
8668 % Create a universal lookup goal for given head.
8669 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8670 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8671 functor(Head,F,A),
8672 get_store_type(F/A,StoreType),
8673 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8675 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8676 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8677 %% -Goal,-SuspensionList) is det.
8678 %
8679 % Create a universal lookup goal for given head.
8680 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8681 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8682 functor(Head,F,A),
8683 get_store_type(F/A,StoreType),
8684 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8686 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8687 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8688 %% +GroundVars,-Goal,-SuspensionList) is det.
8689 %
8690 % Create a universal lookup goal for given head.
8691 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8692 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8693 functor(Head,F,A),
8694 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8695 update_store_type(F/A,default).
8696 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8697 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8698 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8699 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8700 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8701 functor(Head,F,A),
8702 global_ground_store_name(F/A,StoreName),
8703 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8704 update_store_type(F/A,global_ground).
8705 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8706 arg(VarIndex,Head,OVar),
8707 arg(KeyIndex,Head,OKey),
8708 translate([OVar,OKey],VarDict,[Var,Key]),
8709 get_target_module(Module),
8710 Goal = (
8711 get_attr(Var,Module,AssocStore),
8712 lookup_assoc_store(AssocStore,Key,AllSusps)
8713 ).
8714 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8715 functor(Head,F,A),
8716 global_singleton_store_name(F/A,StoreName),
8717 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8718 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8719 update_store_type(F/A,global_singleton).
8720 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8721 once((
8722 member(ST,StoreTypes),
8723 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8724 )).
8725 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8726 functor(Head,F,A),
8727 arg(Index,Head,Var),
8728 translate([Var],VarDict,[KeyVar]),
8729 delay_phase_end(validate_store_type_assumptions,
8730 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8731 ),
8732 update_store_type(F/A,identifier_store(Index)),
8733 get_identifier_index(F/A,Index,_).
8734 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8735 functor(Head,F,A),
8736 arg(Index,Head,Var),
8737 ( var(Var) ->
8738 translate([Var],VarDict,[KeyVar]),
8739 Goal = StructGoal
8740 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8741 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8742 Goal = (LookupGoal,StructGoal)
8743 ),
8744 delay_phase_end(validate_store_type_assumptions,
8745 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8746 ),
8747 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8748 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8750 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8751 get_identifier_size(ISize),
8752 functor(Struct,struct,ISize),
8753 get_identifier_index(C,Index,IIndex),
8754 arg(IIndex,Struct,AllSusps),
8755 Goal = (KeyVar = Struct).
8757 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8758 type_indexed_identifier_structure(IndexType,Struct),
8759 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8760 arg(IIndex,Struct,AllSusps),
8761 Goal = (KeyVar = Struct).
8763 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8764 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8765 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8766 %
8767 % Create a universal hash lookup goal for given head.
8768 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8769 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8770 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8771 ( KeyArgCopies = [KeyCopy] ->
8772 true
8773 ;
8774 KeyCopy =.. [k|KeyArgCopies]
8775 ),
8776 functor(Head,F,A),
8777 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8779 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8780 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8782 Goal = (GroundCheck,LookupGoal),
8784 ( HashType == inthash ->
8785 update_store_type(F/A,multi_inthash([Index]))
8786 ;
8787 update_store_type(F/A,multi_hash([Index]))
8788 ).
8790 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8791 member(Index,Indexes),
8792 args(Index,Head,KeyArgs),
8793 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8794 !.
8796 % check whether we can copy the given terms
8797 % with the given dictionary, and, if so, do so
8798 key_in_scope([],VarDict,[]).
8799 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8800 term_variables(Arg,Vars),
8801 translate(Vars,VarDict,VarCopies),
8802 copy_term(Arg/Vars,ArgCopy/VarCopies),
8803 key_in_scope(Args,VarDict,ArgCopies).
8805 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8806 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8807 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8808 %% +VarArgDict,-NewVarArgDict) is det.
8809 %
8810 % Create existential lookup goal for given head.
8811 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8812 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8813 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8814 sbag_member_call(Susp,AllSusps,Sbag),
8815 functor(Head,F,A),
8816 delay_phase_end(validate_store_type_assumptions,
8817 ( static_suspension_term(F/A,SuspTerm),
8818 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8819 )
8820 ),
8821 Goal = (
8822 UniversalGoal,
8823 Sbag,
8824 Susp = SuspTerm,
8825 GetState
8826 ).
8827 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8828 functor(Head,F,A),
8829 global_singleton_store_name(F/A,StoreName),
8830 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8831 Goal = (
8832 GetStoreGoal, % nb_getval(StoreName,Susp),
8833 Susp \== [],
8834 Susp = SuspTerm
8835 ),
8836 update_store_type(F/A,global_singleton).
8837 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8838 once((
8839 member(ST,StoreTypes),
8840 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8841 )).
8842 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8843 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8844 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8845 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8846 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8847 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8848 hash_index_filter(Pairs,Index,NPairs),
8850 functor(Head,F,A),
8851 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8852 Sbag = (AllSusps = [Susp])
8853 ;
8854 sbag_member_call(Susp,AllSusps,Sbag)
8855 ),
8856 delay_phase_end(validate_store_type_assumptions,
8857 ( static_suspension_term(F/A,SuspTerm),
8858 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8859 )
8860 ),
8861 Goal = (
8862 LookupGoal,
8863 Sbag,
8864 Susp = SuspTerm, % not inlined
8865 GetState
8866 ).
8867 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8868 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8869 hash_index_filter(Pairs,Index,NPairs),
8871 functor(Head,F,A),
8872 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8873 Sbag = (AllSusps = [Susp])
8874 ;
8875 sbag_member_call(Susp,AllSusps,Sbag)
8876 ),
8877 delay_phase_end(validate_store_type_assumptions,
8878 ( static_suspension_term(F/A,SuspTerm),
8879 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8880 )
8881 ),
8882 Goal = (
8883 LookupGoal,
8884 Sbag,
8885 Susp = SuspTerm, % not inlined
8886 GetState
8887 ).
8888 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8889 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8890 sbag_member_call(Susp,Susps,Sbag),
8891 functor(Head,F,A),
8892 delay_phase_end(validate_store_type_assumptions,
8893 ( static_suspension_term(F/A,SuspTerm),
8894 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8895 )
8896 ),
8897 Goal = (
8898 UGoal,
8899 Sbag,
8900 Susp = SuspTerm, % not inlined
8901 GetState
8902 ).
8904 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8905 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8906 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8907 %% +VarArgDict,-NewVarArgDict) is det.
8908 %
8909 % Create existential hash lookup goal for given head.
8910 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8911 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8912 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8914 hash_index_filter(Pairs,Index,NPairs),
8916 functor(Head,F,A),
8917 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8918 Sbag = (AllSusps = [Susp])
8919 ;
8920 sbag_member_call(Susp,AllSusps,Sbag)
8921 ),
8922 delay_phase_end(validate_store_type_assumptions,
8923 ( static_suspension_term(F/A,SuspTerm),
8924 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8925 )
8926 ),
8927 Goal = (
8928 LookupGoal,
8929 Sbag,
8930 Susp = SuspTerm, % not inlined
8931 GetState
8932 ).
8934 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8935 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8936 %
8937 % Filter out pairs already covered by given hash index.
8938 % makes them 'silent'
8939 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8940 hash_index_filter(Pairs,Index,NPairs) :-
8941 hash_index_filter(Pairs,Index,1,NPairs).
8943 hash_index_filter([],_,_,[]).
8944 hash_index_filter([P|Ps],Index,N,NPairs) :-
8945 ( Index = [I|Is] ->
8946 NN is N + 1,
8947 ( I > N ->
8948 NPairs = [P|NPs],
8949 hash_index_filter(Ps,[I|Is],NN,NPs)
8950 ; I == N ->
8951 NPairs = [silent(P)|NPs],
8952 hash_index_filter(Ps,Is,NN,NPs)
8953 )
8954 ;
8955 NPairs = [P|Ps]
8956 ).
8958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8959 %------------------------------------------------------------------------------%
8960 %% assume_constraint_stores(+ConstraintSymbols) is det.
8961 %
8962 % Compute all constraint store types that are possible for the given
8963 % =ConstraintSymbols=.
8964 %------------------------------------------------------------------------------%
8965 assume_constraint_stores([]).
8966 assume_constraint_stores([C|Cs]) :-
8967 ( chr_pp_flag(debugable,off),
8968 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8969 is_stored(C),
8970 get_store_type(C,default) ->
8971 get_indexed_arguments(C,AllIndexedArgs),
8972 get_constraint_mode(C,Modes),
8973 aggregate_all(bag(Index)-count,
8974 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8975 IndexedArgs-NbIndexedArgs),
8976 % Construct Index Combinations
8977 ( NbIndexedArgs > 10 ->
8978 findall([Index],member(Index,IndexedArgs),Indexes)
8979 ;
8980 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8981 predsort(longer_list,UnsortedIndexes,Indexes)
8982 ),
8983 % EXPERIMENTAL HEURISTIC
8984 % findall(Index, (
8985 % member(Arg1,IndexedArgs),
8986 % member(Arg2,IndexedArgs),
8987 % Arg1 =< Arg2,
8988 % sort([Arg1,Arg2], Index)
8989 % ), UnsortedIndexes),
8990 % predsort(longer_list,UnsortedIndexes,Indexes),
8991 % Choose Index Type
8992 ( get_functional_dependency(C,1,Pattern,Key),
8993 all_distinct_var_args(Pattern), Key == [] ->
8994 assumed_store_type(C,global_singleton)
8995 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8996 get_constraint_type_det(C,ArgTypes),
8997 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8999 ( IntHashIndexes = [] ->
9000 Stores = Stores1
9001 ;
9002 Stores = [multi_inthash(IntHashIndexes)|Stores1]
9003 ),
9004 ( HashIndexes = [] ->
9005 Stores1 = Stores2
9006 ;
9007 Stores1 = [multi_hash(HashIndexes)|Stores2]
9008 ),
9009 ( IdentifierIndexes = [] ->
9010 Stores2 = Stores3
9011 ;
9012 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
9013 append(WrappedIdentifierIndexes,Stores3,Stores2)
9014 ),
9015 append(CompoundIdentifierIndexes,Stores4,Stores3),
9016 ( only_ground_indexed_arguments(C)
9017 -> Stores4 = [global_ground]
9018 ; Stores4 = [default]
9019 ),
9020 assumed_store_type(C,multi_store(Stores))
9021 ; true
9022 )
9023 ;
9024 true
9025 ),
9026 assume_constraint_stores(Cs).
9028 %------------------------------------------------------------------------------%
9029 %% partition_indexes(+Indexes,+Types,
9030 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
9031 %------------------------------------------------------------------------------%
9032 partition_indexes([],_,[],[],[],[]).
9033 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
9034 ( Index = [I],
9035 nth1(I,Types,Type),
9036 unalias_type(Type,UnAliasedType),
9037 UnAliasedType == chr_identifier ->
9038 IdentifierIndexes = [I|RIdentifierIndexes],
9039 IntHashIndexes = RIntHashIndexes,
9040 HashIndexes = RHashIndexes,
9041 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9042 ; Index = [I],
9043 nth1(I,Types,Type),
9044 unalias_type(Type,UnAliasedType),
9045 nonvar(UnAliasedType),
9046 UnAliasedType = chr_identifier(IndexType) ->
9047 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
9048 IdentifierIndexes = RIdentifierIndexes,
9049 IntHashIndexes = RIntHashIndexes,
9050 HashIndexes = RHashIndexes
9051 ; Index = [I],
9052 nth1(I,Types,Type),
9053 unalias_type(Type,UnAliasedType),
9054 UnAliasedType == dense_int ->
9055 IntHashIndexes = [Index|RIntHashIndexes],
9056 HashIndexes = RHashIndexes,
9057 IdentifierIndexes = RIdentifierIndexes,
9058 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9059 ; member(I,Index),
9060 nth1(I,Types,Type),
9061 unalias_type(Type,UnAliasedType),
9062 nonvar(UnAliasedType),
9063 UnAliasedType = chr_identifier(_) ->
9064 % don't use chr_identifiers in hash indexes
9065 IntHashIndexes = RIntHashIndexes,
9066 HashIndexes = RHashIndexes,
9067 IdentifierIndexes = RIdentifierIndexes,
9068 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9069 ;
9070 IntHashIndexes = RIntHashIndexes,
9071 HashIndexes = [Index|RHashIndexes],
9072 IdentifierIndexes = RIdentifierIndexes,
9073 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
9074 ),
9075 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
9077 longer_list(R,L1,L2) :-
9078 length(L1,N1),
9079 length(L2,N2),
9080 compare(Rt,N2,N1),
9081 ( Rt == (=) ->
9082 compare(R,L1,L2)
9083 ;
9084 R = Rt
9085 ).
9087 all_distinct_var_args(Term) :-
9088 copy_term_nat(Term,TermCopy),
9089 functor(Term,F,A),
9090 functor(Pattern,F,A),
9091 Pattern =@= TermCopy.
9093 get_indexed_arguments(C,IndexedArgs) :-
9094 C = F/A,
9095 get_indexed_arguments(1,A,C,IndexedArgs).
9097 get_indexed_arguments(I,N,C,L) :-
9098 ( I > N ->
9099 L = []
9100 ; ( is_indexed_argument(C,I) ->
9101 L = [I|T]
9102 ;
9103 L = T
9104 ),
9105 J is I + 1,
9106 get_indexed_arguments(J,N,C,T)
9107 ).
9109 validate_store_type_assumptions([]).
9110 validate_store_type_assumptions([C|Cs]) :-
9111 validate_store_type_assumption(C),
9112 validate_store_type_assumptions(Cs).
9114 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9115 % new code generation
9116 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
9117 Rule = rule(H1,_,Guard,Body),
9118 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9119 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
9120 flatten(VarsAndSuspsList,VarsAndSusps),
9121 Vars = [ [] | VarsAndSusps],
9122 build_head(F,A,[O|Id],Vars,Head),
9123 ( PrevId0 = [_] ->
9124 get_success_continuation_code_id(F/A,O,PredictedPrevId),
9125 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
9126 PrevId = [PredictedPrevId] % PrevId = PrevId0
9127 ;
9128 PrevId = [O|PrevId0]
9129 ),
9130 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9131 Clause = ( Head :- PredecessorCall),
9132 add_dummy_location(Clause,LocatedClause),
9133 L = [LocatedClause | T].
9134 % ( H1 == [],
9135 % functor(CurrentHead,CF,CA),
9136 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
9137 % L = T
9138 % ;
9139 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
9140 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
9141 % flatten(VarsAndSuspsList,VarsAndSusps),
9142 % Vars = [ [] | VarsAndSusps],
9143 % build_head(F,A,Id,Vars,Head),
9144 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
9145 % Clause = ( Head :- PredecessorCall),
9146 % L = [Clause | T]
9147 % ).
9149 % skips back intelligently over global_singleton lookups
9150 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
9151 ( Id = [0|_] ->
9152 % TOM: add partial success continuation optimization here!
9153 next_id(Id,PrevId),
9154 PrevVarsAndSusps = BaseCallArgs
9155 ;
9156 VarsAndSuspsList = [_|AllButFirstList],
9157 dec_id(Id,PrevId1),
9158 ( PrevHeads = [PrevHead|PrevHeads1],
9159 functor(PrevHead,F,A),
9160 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
9161 PrevIterators = [_|PrevIterators1],
9162 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
9163 ;
9164 PrevId = PrevId1,
9165 flatten(AllButFirstList,AllButFirst),
9166 PrevIterators = [PrevIterator|_],
9167 PrevVarsAndSusps = [PrevIterator|AllButFirst]
9168 )
9169 ).
9171 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
9172 Rule = rule(_,_,Guard,Body),
9173 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
9174 init(AllSusps,PreSusps),
9175 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
9176 gen_var(OtherSusps),
9177 functor(CurrentHead,OtherF,OtherA),
9178 gen_vars(OtherA,OtherVars),
9179 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
9180 get_constraint_mode(OtherF/OtherA,Mode),
9181 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
9183 delay_phase_end(validate_store_type_assumptions,
9184 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
9185 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
9186 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
9187 )
9188 ),
9190 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
9191 % create_get_mutable_ref(active,State,GetMutable),
9192 CurrentSuspTest = (
9193 OtherSusp = OtherSuspension,
9194 GetState,
9195 DiffSuspGoals,
9196 FirstMatching
9197 ),
9198 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
9199 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
9200 inc_id(Id,NestedId),
9201 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
9202 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
9203 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
9204 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
9205 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
9207 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
9208 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
9209 RecursiveVars = PreVarsAndSusps1
9210 ;
9211 RecursiveVars = [OtherSusps|PreVarsAndSusps],
9212 PrevId0 = Id
9213 ),
9214 ( PrevId0 = [_] ->
9215 PrevId = PrevId0
9216 ;
9217 PrevId = [O|PrevId0]
9218 ),
9219 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9221 Clause = (
9222 ClauseHead :-
9223 ( CurrentSuspTest,
9224 NextSuspGoal
9225 ->
9226 NestedHead
9227 ; RecursiveHead
9228 )
9229 ),
9230 add_dummy_location(Clause,LocatedClause),
9231 L = [LocatedClause|T].
9233 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9235 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9236 % Observation Analysis
9237 %
9238 % CLASSIFICATION
9239 % Enabled
9240 %
9241 % Analysis based on Abstract Interpretation paper.
9242 %
9243 % TODO:
9244 % stronger analysis domain [research]
9246 :- chr_constraint
9247 initial_call_pattern/1,
9248 call_pattern/1,
9249 call_pattern_worker/1,
9250 final_answer_pattern/2,
9251 abstract_constraints/1,
9252 depends_on/2,
9253 depends_on_ap/4,
9254 depends_on_goal/2,
9255 ai_observed_internal/2,
9256 % ai_observed/2,
9257 ai_not_observed_internal/2,
9258 ai_not_observed/2,
9259 ai_is_observed/2,
9260 depends_on_as/3,
9261 ai_observation_gather_results/0.
9263 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9264 :- chr_type program_point == any.
9266 :- chr_option(mode,initial_call_pattern(+)).
9267 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9269 :- chr_option(mode,call_pattern(+)).
9270 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9272 :- chr_option(mode,call_pattern_worker(+)).
9273 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9275 :- chr_option(mode,final_answer_pattern(+,+)).
9276 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9278 :- chr_option(mode,abstract_constraints(+)).
9279 :- chr_option(type_declaration,abstract_constraints(list)).
9281 :- chr_option(mode,depends_on(+,+)).
9282 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9284 :- chr_option(mode,depends_on_as(+,+,+)).
9285 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9286 :- chr_option(mode,depends_on_goal(+,+)).
9287 :- chr_option(mode,ai_is_observed(+,+)).
9288 :- chr_option(mode,ai_not_observed(+,+)).
9289 % :- chr_option(mode,ai_observed(+,+)).
9290 :- chr_option(mode,ai_not_observed_internal(+,+)).
9291 :- chr_option(mode,ai_observed_internal(+,+)).
9294 abstract_constraints_fd @
9295 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9297 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9298 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9299 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9301 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9302 ai_is_observed(_,_) <=> true.
9304 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9305 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9306 ai_observation_gather_results <=> true.
9308 %------------------------------------------------------------------------------%
9309 % Main Analysis Entry
9310 %------------------------------------------------------------------------------%
9311 ai_observation_analysis(ACs) :-
9312 ( chr_pp_flag(ai_observation_analysis,on),
9313 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9314 list_to_ord_set(ACs,ACSet),
9315 abstract_constraints(ACSet),
9316 ai_observation_schedule_initial_calls(ACSet,ACSet),
9317 ai_observation_gather_results
9318 ;
9319 true
9320 ).
9322 ai_observation_schedule_initial_calls([],_).
9323 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9324 ai_observation_schedule_initial_call(AC,ACs),
9325 ai_observation_schedule_initial_calls(RACs,ACs).
9327 ai_observation_schedule_initial_call(AC,ACs) :-
9328 ai_observation_top(AC,CallPattern),
9329 % ai_observation_bot(AC,ACs,CallPattern),
9330 initial_call_pattern(CallPattern).
9332 ai_observation_schedule_new_calls([],AP).
9333 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9334 AP = odom(_,Set),
9335 initial_call_pattern(odom(AC,Set)),
9336 ai_observation_schedule_new_calls(ACs,AP).
9338 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9339 <=>
9340 ai_observation_leq(AP2,AP1)
9341 |
9342 true.
9344 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9346 initial_call_pattern(CP) ==> call_pattern(CP).
9348 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9349 ==>
9350 ai_observation_schedule_new_calls(ACs,AP)
9351 pragma
9352 passive(ID3).
9354 call_pattern(CP) \ call_pattern(CP) <=> true.
9356 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9357 final_answer_pattern(CP1,AP).
9359 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9361 call_pattern(CP) ==> call_pattern_worker(CP).
9363 %------------------------------------------------------------------------------%
9364 % Abstract Goal
9365 %------------------------------------------------------------------------------%
9367 % AbstractGoala
9368 %call_pattern(odom([],Set)) ==>
9369 % final_answer_pattern(odom([],Set),odom([],Set)).
9371 call_pattern_worker(odom([],Set)) <=>
9372 % writeln(' - AbstractGoal'(odom([],Set))),
9373 final_answer_pattern(odom([],Set),odom([],Set)).
9375 % AbstractGoalb
9376 call_pattern_worker(odom([G|Gs],Set)) <=>
9377 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9378 CP1 = odom(G,Set),
9379 depends_on_goal(odom([G|Gs],Set),CP1),
9380 call_pattern(CP1).
9382 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9383 <=> true pragma passive(ID).
9384 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9385 ==>
9386 CP1 = odom([_|Gs],_),
9387 AP2 = odom([],Set),
9388 CCP = odom(Gs,Set),
9389 call_pattern(CCP),
9390 depends_on(CP1,CCP).
9392 %------------------------------------------------------------------------------%
9393 % Abstract Disjunction
9394 %------------------------------------------------------------------------------%
9396 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9397 CP = odom((AG1;AG2),Set),
9398 InitialAnswerApproximation = odom([],Set),
9399 final_answer_pattern(CP,InitialAnswerApproximation),
9400 CP1 = odom(AG1,Set),
9401 CP2 = odom(AG2,Set),
9402 call_pattern(CP1),
9403 call_pattern(CP2),
9404 depends_on_as(CP,CP1,CP2).
9406 %------------------------------------------------------------------------------%
9407 % Abstract Solve
9408 %------------------------------------------------------------------------------%
9409 call_pattern_worker(odom(builtin,Set)) <=>
9410 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9411 ord_empty(EmptySet),
9412 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9414 %------------------------------------------------------------------------------%
9415 % Abstract Drop
9416 %------------------------------------------------------------------------------%
9417 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9418 <=>
9419 O > MO
9420 |
9421 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9422 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9423 pragma
9424 passive(ID2).
9426 %------------------------------------------------------------------------------%
9427 % Abstract Activate
9428 %------------------------------------------------------------------------------%
9429 call_pattern_worker(odom(AC,Set))
9430 <=>
9431 AC = _ / _
9432 |
9433 % writeln(' - AbstractActivate'(odom(AC,Set))),
9434 CP = odom(occ(AC,1),Set),
9435 call_pattern(CP),
9436 depends_on(odom(AC,Set),CP).
9438 %------------------------------------------------------------------------------%
9439 % Abstract Passive
9440 %------------------------------------------------------------------------------%
9441 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9442 <=>
9443 is_passive(RuleNb,ID)
9444 |
9445 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9446 % DEFAULT
9447 NO is O + 1,
9448 DCP = odom(occ(C,NO),Set),
9449 call_pattern(DCP),
9450 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9451 depends_on(odom(occ(C,O),Set),DCP)
9452 pragma
9453 passive(ID2).
9454 %------------------------------------------------------------------------------%
9455 % Abstract Simplify
9456 %------------------------------------------------------------------------------%
9458 % AbstractSimplify
9459 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9460 <=>
9461 \+ is_passive(RuleNb,ID)
9462 |
9463 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9464 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9465 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9466 ai_observation_memo_abstract_goal(RuleNb,AG),
9467 call_pattern(odom(AG,Set2)),
9468 % DEFAULT
9469 NO is O + 1,
9470 DCP = odom(occ(C,NO),Set),
9471 call_pattern(DCP),
9472 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9473 % DEADLOCK AVOIDANCE
9474 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9475 pragma
9476 passive(ID2).
9478 depends_on_as(CP,CPS,CPD),
9479 final_answer_pattern(CPS,APS),
9480 final_answer_pattern(CPD,APD) ==>
9481 ai_observation_lub(APS,APD,AP),
9482 final_answer_pattern(CP,AP).
9485 :- chr_constraint
9486 ai_observation_memo_simplification_rest_heads/3,
9487 ai_observation_memoed_simplification_rest_heads/3.
9489 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9490 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9492 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9493 <=>
9494 QRH = RH.
9495 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9496 <=>
9497 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9498 once(select2(ID,_,IDs1,H1,_,RestH1)),
9499 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9500 ai_observation_abstract_constraints(H2,ACs,AH2),
9501 append(ARestHeads,AH2,AbstractHeads),
9502 sort(AbstractHeads,QRH),
9503 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9504 pragma
9505 passive(ID1),
9506 passive(ID2),
9507 passive(ID3).
9509 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9511 %------------------------------------------------------------------------------%
9512 % Abstract Propagate
9513 %------------------------------------------------------------------------------%
9516 % AbstractPropagate
9517 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9518 <=>
9519 \+ is_passive(RuleNb,ID)
9520 |
9521 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9522 % observe partners
9523 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9524 ai_observation_observe_set(Set,AHs,Set2),
9525 ord_add_element(Set2,C,Set3),
9526 ai_observation_memo_abstract_goal(RuleNb,AG),
9527 call_pattern(odom(AG,Set3)),
9528 ( ord_memberchk(C,Set2) ->
9529 Delete = no
9530 ;
9531 Delete = yes
9532 ),
9533 % DEFAULT
9534 NO is O + 1,
9535 DCP = odom(occ(C,NO),Set),
9536 call_pattern(DCP),
9537 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9538 pragma
9539 passive(ID2).
9541 :- chr_constraint
9542 ai_observation_memo_propagation_rest_heads/3,
9543 ai_observation_memoed_propagation_rest_heads/3.
9545 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9546 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9548 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9549 <=>
9550 QRH = RH.
9551 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9552 <=>
9553 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9554 once(select2(ID,_,IDs2,H2,_,RestH2)),
9555 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9556 ai_observation_abstract_constraints(H1,ACs,AH1),
9557 append(ARestHeads,AH1,AbstractHeads),
9558 sort(AbstractHeads,QRH),
9559 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9560 pragma
9561 passive(ID1),
9562 passive(ID2),
9563 passive(ID3).
9565 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9567 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9568 final_answer_pattern(CP,APD).
9569 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9570 final_answer_pattern(CPD,APD) ==>
9571 true |
9572 CP = odom(occ(C,O),_),
9573 ( ai_observation_is_observed(APP,C) ->
9574 ai_observed_internal(C,O)
9575 ;
9576 ai_not_observed_internal(C,O)
9577 ),
9578 ( Delete == yes ->
9579 APP = odom([],Set0),
9580 ord_del_element(Set0,C,Set),
9581 NAPP = odom([],Set)
9582 ;
9583 NAPP = APP
9584 ),
9585 ai_observation_lub(NAPP,APD,AP),
9586 final_answer_pattern(CP,AP).
9588 %------------------------------------------------------------------------------%
9589 % Catch All
9590 %------------------------------------------------------------------------------%
9592 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9594 %------------------------------------------------------------------------------%
9595 % Auxiliary Predicates
9596 %------------------------------------------------------------------------------%
9598 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9599 ord_intersection(S1,S2,S3).
9601 ai_observation_bot(AG,AS,odom(AG,AS)).
9603 ai_observation_top(AG,odom(AG,EmptyS)) :-
9604 ord_empty(EmptyS).
9606 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9607 ord_subset(S2,S1).
9609 ai_observation_observe_set(S,ACSet,NS) :-
9610 ord_subtract(S,ACSet,NS).
9612 ai_observation_abstract_constraint(C,ACs,AC) :-
9613 functor(C,F,A),
9614 AC = F/A,
9615 memberchk(AC,ACs).
9617 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9618 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9620 %------------------------------------------------------------------------------%
9621 % Abstraction of Rule Bodies
9622 %------------------------------------------------------------------------------%
9624 :- chr_constraint
9625 ai_observation_memoed_abstract_goal/2,
9626 ai_observation_memo_abstract_goal/2.
9628 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9629 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9631 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9632 <=>
9633 QAG = AG
9634 pragma
9635 passive(ID1).
9637 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9638 <=>
9639 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9640 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9641 QAG = AG,
9642 ai_observation_memoed_abstract_goal(RuleNb,AG)
9643 pragma
9644 passive(ID1),
9645 passive(ID2).
9647 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9648 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9649 term_variables((H1,H2,Guard),HVars),
9650 append(H1,H2,Heads),
9651 % variables that are declared to be ground are safe,
9652 ground_vars(Heads,GroundVars),
9653 % so we remove them from the list of 'dangerous' head variables
9654 list_difference_eq(HVars,GroundVars,HV),
9655 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9656 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9657 % HV are 'dangerous' variables, all others are fresh and safe
9659 ground_vars([],[]).
9660 ground_vars([H|Hs],GroundVars) :-
9661 functor(H,F,A),
9662 get_constraint_mode(F/A,Mode),
9663 % TOM: fix this code!
9664 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9665 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9666 ground_vars(Hs,GroundVars2),
9667 append(GroundVars1,GroundVars2,GroundVars).
9669 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9670 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9671 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9672 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9673 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9674 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9675 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9676 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9677 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9678 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9679 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9680 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9681 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9682 % non-CHR constraint is safe if it only binds fresh variables
9683 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9684 builtin_binds_b(G,Vars),
9685 intersect_eq(Vars,HV,[]),
9686 !.
9687 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9688 AG = builtin. % default case if goal is not recognized/safe
9690 ai_observation_is_observed(odom(_,ACSet),AC) :-
9691 \+ ord_memberchk(AC,ACSet).
9693 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9694 unconditional_occurrence(C,O) :-
9695 get_occurrence(C,O,RuleNb,ID),
9696 get_rule(RuleNb,PRule),
9697 PRule = pragma(ORule,_,_,_,_),
9698 copy_term_nat(ORule,Rule),
9699 Rule = rule(H1,H2,Guard,_),
9700 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9701 once((
9702 H1 = [Head], H2 == []
9703 ;
9704 H2 = [Head], H1 == [], \+ may_trigger(C)
9705 )),
9706 all_distinct_var_args(Head).
9708 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9710 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9711 % Partial wake analysis
9712 %
9713 % In a Var = Var unification do not wake up constraints of both variables,
9714 % but rather only those of one variable.
9715 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9717 :- chr_constraint partial_wake_analysis/0.
9718 :- chr_constraint no_partial_wake/1.
9719 :- chr_option(mode,no_partial_wake(+)).
9720 :- chr_constraint wakes_partially/1.
9721 :- chr_option(mode,wakes_partially(+)).
9723 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9724 ==>
9725 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9726 ( is_passive(RuleNb,ID) ->
9727 true
9728 ; Type == simplification ->
9729 select(H,H1,RestH1),
9730 H =.. [_|Args],
9731 term_variables(Guard,Vars),
9732 partial_wake_args(Args,ArgModes,Vars,FA)
9733 ; % Type == propagation ->
9734 select(H,H2,RestH2),
9735 H =.. [_|Args],
9736 term_variables(Guard,Vars),
9737 partial_wake_args(Args,ArgModes,Vars,FA)
9738 ).
9740 partial_wake_args([],_,_,_).
9741 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9742 ( Mode \== (+) ->
9743 ( nonvar(Arg) ->
9744 no_partial_wake(C)
9745 ; memberchk_eq(Arg,Vars) ->
9746 no_partial_wake(C)
9747 ;
9748 true
9749 )
9750 ;
9751 true
9752 ),
9753 partial_wake_args(Args,Modes,Vars,C).
9755 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9757 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9759 wakes_partially(C) <=> true.
9762 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9763 % Generate rules that implement chr_show_store/1 functionality.
9764 %
9765 % CLASSIFICATION
9766 % Experimental
9767 % Unused
9768 %
9769 % Generates additional rules:
9770 %
9771 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9772 % ...
9773 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9774 % $show <=> true.
9776 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9777 ( chr_pp_flag(show,on) ->
9778 Constraints = ['$show'/0|Constraints0],
9779 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9780 inc_rule_count(RuleNb),
9781 Rule = pragma(
9782 rule(['$show'],[],true,true),
9783 ids([0],[]),
9784 [],
9785 no,
9786 RuleNb
9787 )
9788 ;
9789 Constraints = Constraints0,
9790 Rules = Rules0
9791 ).
9793 generate_show_rules([],Rules,Rules).
9794 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9795 functor(C,F,A),
9796 inc_rule_count(RuleNb),
9797 Rule = pragma(
9798 rule([],['$show',C],true,writeln(C)),
9799 ids([],[0,1]),
9800 [passive(1)],
9801 no,
9802 RuleNb
9803 ),
9804 generate_show_rules(Rest,Tail,Rules).
9806 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9807 % Custom supension term layout
9809 static_suspension_term(F/A,Suspension) :-
9810 suspension_term_base(F/A,Base),
9811 Arity is Base + A,
9812 functor(Suspension,suspension,Arity).
9814 has_suspension_field(FA,Field) :-
9815 suspension_term_base_fields(FA,Fields),
9816 memberchk(Field,Fields).
9818 suspension_term_base(FA,Base) :-
9819 suspension_term_base_fields(FA,Fields),
9820 length(Fields,Base).
9822 suspension_term_base_fields(FA,Fields) :-
9823 ( chr_pp_flag(debugable,on) ->
9824 % 1. ID
9825 % 2. State
9826 % 3. Propagation History
9827 % 4. Generation Number
9828 % 5. Continuation Goal
9829 % 6. Functor
9830 Fields = [id,state,history,generation,continuation,functor]
9831 ;
9832 ( uses_history(FA) ->
9833 Fields = [id,state,history|Fields2]
9834 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9835 Fields = [state|Fields2]
9836 ;
9837 Fields = [id,state|Fields2]
9838 ),
9839 ( only_ground_indexed_arguments(FA) ->
9840 get_store_type(FA,StoreType),
9841 basic_store_types(StoreType,BasicStoreTypes),
9842 ( memberchk(global_ground,BasicStoreTypes) ->
9843 % 1. ID
9844 % 2. State
9845 % 3. Propagation History
9846 % 4. Global List Prev
9847 Fields2 = [global_list_prev|Fields3]
9848 ;
9849 % 1. ID
9850 % 2. State
9851 % 3. Propagation History
9852 Fields2 = Fields3
9853 ),
9854 ( chr_pp_flag(ht_removal,on)
9855 -> ht_prev_fields(BasicStoreTypes,Fields3)
9856 ; Fields3 = []
9857 )
9858 ; may_trigger(FA) ->
9859 % 1. ID
9860 % 2. State
9861 % 3. Propagation History
9862 ( uses_field(FA,generation) ->
9863 % 4. Generation Number
9864 % 5. Global List Prev
9865 Fields2 = [generation,global_list_prev|Fields3]
9866 ;
9867 Fields2 = [global_list_prev|Fields3]
9868 ),
9869 ( chr_pp_flag(mixed_stores,on),
9870 chr_pp_flag(ht_removal,on)
9871 -> get_store_type(FA,StoreType),
9872 basic_store_types(StoreType,BasicStoreTypes),
9873 ht_prev_fields(BasicStoreTypes,Fields3)
9874 ; Fields3 = []
9875 )
9876 ;
9877 % 1. ID
9878 % 2. State
9879 % 3. Propagation History
9880 % 4. Global List Prev
9881 Fields2 = [global_list_prev|Fields3],
9882 ( chr_pp_flag(mixed_stores,on),
9883 chr_pp_flag(ht_removal,on)
9884 -> get_store_type(FA,StoreType),
9885 basic_store_types(StoreType,BasicStoreTypes),
9886 ht_prev_fields(BasicStoreTypes,Fields3)
9887 ; Fields3 = []
9888 )
9889 )
9890 ).
9892 ht_prev_fields(Stores,Prevs) :-
9893 ht_prev_fields_int(Stores,PrevsList),
9894 append(PrevsList,Prevs).
9895 ht_prev_fields_int([],[]).
9896 ht_prev_fields_int([H|T],Fields) :-
9897 ( H = multi_hash(Indexes)
9898 -> maplist(ht_prev_field,Indexes,FH),
9899 Fields = [FH|FT]
9900 ; Fields = FT
9901 ),
9902 ht_prev_fields_int(T,FT).
9904 ht_prev_field(Index,Field) :-
9905 concat_atom(['multi_hash_prev-'|Index],Field).
9907 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9908 suspension_term_base_fields(FA,Fields),
9909 nth1(Index,Fields,FieldName), !,
9910 arg(Index,StaticSuspension,Field).
9911 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9912 suspension_term_base(FA,Base),
9913 StaticSuspension =.. [_|Args],
9914 drop(Base,Args,Field).
9915 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9916 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9919 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9920 suspension_term_base_fields(FA,Fields),
9921 nth1(Index,Fields,FieldName), !,
9922 Goal = arg(Index,DynamicSuspension,Field).
9923 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9924 static_suspension_term(FA,StaticSuspension),
9925 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9926 Goal = (DynamicSuspension = StaticSuspension).
9927 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9928 suspension_term_base(FA,Base),
9929 Index is I + Base,
9930 Goal = arg(Index,DynamicSuspension,Field).
9931 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9932 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9935 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9936 suspension_term_base_fields(FA,Fields),
9937 nth1(Index,Fields,FieldName), !,
9938 Goal = setarg(Index,DynamicSuspension,Field).
9939 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9940 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9942 basic_store_types(multi_store(Types),Types) :- !.
9943 basic_store_types(Type,[Type]).
9945 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9946 %
9948 :- chr_constraint
9949 phase_end/1,
9950 delay_phase_end/2.
9952 :- chr_option(mode,phase_end(+)).
9953 :- chr_option(mode,delay_phase_end(+,?)).
9955 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9956 % phase_end(Phase) <=> true.
9959 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9960 :- chr_constraint
9961 does_use_history/2,
9962 uses_history/1,
9963 novel_production_call/4.
9965 :- chr_option(mode,uses_history(+)).
9966 :- chr_option(mode,does_use_history(+,+)).
9967 :- chr_option(mode,novel_production_call(+,+,?,?)).
9969 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9970 does_use_history(FA,_) \ uses_history(FA) <=> true.
9971 uses_history(_FA) <=> fail.
9973 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9974 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9976 :- chr_constraint
9977 does_use_field/2,
9978 uses_field/2.
9980 :- chr_option(mode,uses_field(+,+)).
9981 :- chr_option(mode,does_use_field(+,+)).
9983 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9984 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9985 uses_field(_FA,_Field) <=> fail.
9987 :- chr_constraint
9988 uses_state/2,
9989 if_used_state/5,
9990 used_states_known/0.
9992 :- chr_option(mode,uses_state(+,+)).
9993 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9996 % states ::= not_stored_yet | passive | active | triggered | removed
9997 %
9998 % allocate CREATES not_stored_yet
9999 % remove CHECKS not_stored_yet
10000 % activate CHECKS not_stored_yet
10001 %
10002 % ==> no allocate THEN no not_stored_yet
10004 % recurs CREATES inactive
10005 % lookup CHECKS inactive
10007 % insert CREATES active
10008 % activate CREATES active
10009 % lookup CHECKS active
10010 % recurs CHECKS active
10012 % runsusp CREATES triggered
10013 % lookup CHECKS triggered
10014 %
10015 % ==> no runsusp THEN no triggered
10017 % remove CREATES removed
10018 % runsusp CHECKS removed
10019 % lookup CHECKS removed
10020 % recurs CHECKS removed
10021 %
10022 % ==> no remove THEN no removed
10024 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
10026 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
10028 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10029 <=> ResultGoal = Used.
10030 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
10031 <=> ResultGoal = NotUsed.
10033 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10034 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
10035 % (Feature for SSS)
10036 %
10037 % 1. Checking
10038 % ~~~~~~~~~~~
10039 %
10040 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10041 %
10042 % :- chr_option(declare_stored_constraints,on).
10043 %
10044 % the compiler will check for the storedness of constraints.
10045 %
10046 % By default, the compiler assumes that the programmer wants his constraints to
10047 % be never-stored. Hence, a warning will be issues when a constraint is actually
10048 % stored.
10049 %
10050 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
10051 % to a constraint declaration, i.e. writes
10052 %
10053 % :- chr_constraint c(...) # stored.
10054 %
10055 % In that case a warning is issued when the constraint is never-stored.
10056 %
10057 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
10058 % constraints are stored anyway.
10059 %
10060 %
10061 % 2. Rule Generation
10062 % ~~~~~~~~~~~~~~~~~~
10063 %
10064 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
10065 %
10066 % :- chr_option(declare_stored_constraints,on).
10067 %
10068 % the compiler will generate default simplification rules for constraints.
10069 %
10070 % By default, no default rule is generated for a constraint. However, if the
10071 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
10072 %
10073 % :- chr_constraint c(...) # default(Goal).
10074 %
10075 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
10076 % the compiler generates a rule:
10077 %
10078 % c(_,...,_) <=> Goal.
10079 %
10080 % at the end of the program. If multiple default rules are generated, for several constraints,
10081 % then the order of the default rules is not specified.
10084 :- chr_constraint stored_assertion/1.
10085 :- chr_option(mode,stored_assertion(+)).
10086 :- chr_option(type_declaration,stored_assertion(constraint)).
10088 :- chr_constraint never_stored_default/2.
10089 :- chr_option(mode,never_stored_default(+,?)).
10090 :- chr_option(type_declaration,never_stored_default(constraint,any)).
10092 % Rule Generation
10093 % ~~~~~~~~~~~~~~~
10095 generate_never_stored_rules(Constraints,Rules) :-
10096 ( chr_pp_flag(declare_stored_constraints,on) ->
10097 never_stored_rules(Constraints,Rules)
10098 ;
10099 Rules = []
10100 ).
10102 :- chr_constraint never_stored_rules/2.
10103 :- chr_option(mode,never_stored_rules(+,?)).
10104 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
10106 never_stored_rules([],Rules) <=> Rules = [].
10107 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
10108 Constraint = F/A,
10109 functor(Head,F,A),
10110 inc_rule_count(RuleNb),
10111 Rule = pragma(
10112 rule([Head],[],true,Goal),
10113 ids([0],[]),
10114 [],
10115 no,
10116 RuleNb
10117 ),
10118 Rules = [Rule|Tail],
10119 never_stored_rules(Constraints,Tail).
10120 never_stored_rules([_|Constraints],Rules) <=>
10121 never_stored_rules(Constraints,Rules).
10123 % Checking
10124 % ~~~~~~~~
10126 check_storedness_assertions(Constraints) :-
10127 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
10128 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
10129 ;
10130 true
10131 ).
10134 :- chr_constraint check_storedness_assertion/1.
10135 :- chr_option(mode,check_storedness_assertion(+)).
10136 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
10138 check_storedness_assertion(Constraint), stored_assertion(Constraint)
10139 <=> ( is_stored(Constraint) ->
10140 true
10141 ;
10142 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
10143 ).
10144 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
10145 <=> ( is_finally_stored(Constraint) ->
10146 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10147 ; is_stored(Constraint) ->
10148 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10149 ;
10150 true
10151 ).
10152 % never-stored, no default goal
10153 check_storedness_assertion(Constraint)
10154 <=> ( is_finally_stored(Constraint) ->
10155 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
10156 ; is_stored(Constraint) ->
10157 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
10158 ;
10159 true
10160 ).
10162 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
10163 % success continuation analysis
10165 % TODO
10166 % also use for forward jumping improvement!
10167 % use Prolog indexing for generated code
10168 %
10169 % EXPORTED
10170 %
10171 % should_skip_to_next_id(C,O)
10172 %
10173 % get_occurrence_code_id(C,O,Id)
10174 %
10175 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
10177 continuation_analysis(ConstraintSymbols) :-
10178 maplist(analyse_continuations,ConstraintSymbols).
10180 analyse_continuations(C) :-
10181 % 1. compute success continuations of the
10182 % occurrences of constraint C
10183 continuation_analysis(C,1),
10184 % 2. determine for which occurrences
10185 % to skip to next code id
10186 get_max_occurrence(C,MO),
10187 LO is MO + 1,
10188 bulk_propagation(C,1,LO),
10189 % 3. determine code id for each occurrence
10190 set_occurrence_code_id(C,1,0).
10192 % 1. Compute the success continuations of constrait C
10193 %-------------------------------------------------------------------------------
10195 continuation_analysis(C,O) :-
10196 get_max_occurrence(C,MO),
10197 ( O > MO ->
10198 true
10199 ; O == MO ->
10200 NextO is O + 1,
10201 continuation_occurrence(C,O,NextO)
10202 ;
10203 constraint_continuation(C,O,MO,NextO),
10204 continuation_occurrence(C,O,NextO),
10205 NO is O + 1,
10206 continuation_analysis(C,NO)
10207 ).
10209 constraint_continuation(C,O,MO,NextO) :-
10210 ( get_occurrence_head(C,O,Head) ->
10211 NO is O + 1,
10212 ( between(NO,MO,NextO),
10213 get_occurrence_head(C,NextO,NextHead),
10214 unifiable(Head,NextHead,_) ->
10215 true
10216 ;
10217 NextO is MO + 1
10218 )
10219 ; % current occurrence is passive
10220 NextO = MO
10221 ).
10223 get_occurrence_head(C,O,Head) :-
10224 get_occurrence(C,O,RuleNb,Id),
10225 \+ is_passive(RuleNb,Id),
10226 get_rule(RuleNb,Rule),
10227 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10228 ( select2(Id,Head,Ids1,H1,_,_) -> true
10229 ; select2(Id,Head,Ids2,H2,_,_)
10230 ).
10232 :- chr_constraint continuation_occurrence/3.
10233 :- chr_option(mode,continuation_occurrence(+,+,+)).
10235 :- chr_constraint get_success_continuation_occurrence/3.
10236 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10238 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10239 <=>
10240 X = NO.
10242 get_success_continuation_occurrence(C,O,X)
10243 <=>
10244 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10246 % 2. figure out when to skip to next code id
10247 %-------------------------------------------------------------------------------
10248 % don't go beyond the last occurrence
10249 % we have to go to next id for storage here
10251 :- chr_constraint skip_to_next_id/2.
10252 :- chr_option(mode,skip_to_next_id(+,+)).
10254 :- chr_constraint should_skip_to_next_id/2.
10255 :- chr_option(mode,should_skip_to_next_id(+,+)).
10257 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10258 <=>
10259 true.
10261 should_skip_to_next_id(_,_)
10262 <=>
10263 fail.
10265 :- chr_constraint bulk_propagation/3.
10266 :- chr_option(mode,bulk_propagation(+,+,+)).
10268 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10269 <=>
10270 O >= MO
10271 |
10272 skip_to_next_id(C,O).
10273 % we have to go to the next id here because
10274 % a predecessor needs it
10275 bulk_propagation(C,O,LO)
10276 <=>
10277 LO =:= O + 1
10278 |
10279 skip_to_next_id(C,O),
10280 get_max_occurrence(C,MO),
10281 NLO is MO + 1,
10282 bulk_propagation(C,LO,NLO).
10283 % we have to go to the next id here because
10284 % we're running into a simplification rule
10285 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10286 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10287 <=>
10288 NO =:= O + 1
10289 |
10290 skip_to_next_id(C,O),
10291 get_max_occurrence(C,MO),
10292 NLO is MO + 1,
10293 bulk_propagation(C,NO,NLO).
10294 % we skip the next id here
10295 % and go to the next occurrence
10296 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10297 <=>
10298 NextO > O + 1
10299 |
10300 NLO is min(LO,NextO),
10301 NO is O + 1,
10302 bulk_propagation(C,NO,NLO).
10303 % default case
10304 % err on the safe side
10305 bulk_propagation(C,O,LO)
10306 <=>
10307 skip_to_next_id(C,O),
10308 get_max_occurrence(C,MO),
10309 NLO is MO + 1,
10310 NO is O + 1,
10311 bulk_propagation(C,NO,NLO).
10313 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10315 % if this occurrence is passive, but has to skip,
10316 % then the previous one must skip instead...
10317 % IMPROVE reasoning is conservative
10318 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10319 ==>
10320 O > 1
10321 |
10322 PO is O - 1,
10323 skip_to_next_id(C,PO).
10325 % 3. determine code id of each occurrence
10326 %-------------------------------------------------------------------------------
10328 :- chr_constraint set_occurrence_code_id/3.
10329 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10331 :- chr_constraint occurrence_code_id/3.
10332 :- chr_option(mode,occurrence_code_id(+,+,+)).
10334 % stop at the end
10335 set_occurrence_code_id(C,O,IdNb)
10336 <=>
10337 get_max_occurrence(C,MO),
10338 O > MO
10339 |
10340 occurrence_code_id(C,O,IdNb).
10342 % passive occurrences don't change the code id
10343 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10344 <=>
10345 occurrence_code_id(C,O,IdNb),
10346 NO is O + 1,
10347 set_occurrence_code_id(C,NO,IdNb).
10349 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10350 <=>
10351 occurrence_code_id(C,O,IdNb),
10352 NO is O + 1,
10353 set_occurrence_code_id(C,NO,IdNb).
10355 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10356 <=>
10357 occurrence_code_id(C,O,IdNb),
10358 NO is O + 1,
10359 NIdNb is IdNb + 1,
10360 set_occurrence_code_id(C,NO,NIdNb).
10362 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10363 <=>
10364 occurrence_code_id(C,O,IdNb),
10365 NO is O + 1,
10366 set_occurrence_code_id(C,NO,IdNb).
10368 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10370 :- chr_constraint get_occurrence_code_id/3.
10371 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10373 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10374 <=>
10375 X = IdNb.
10377 get_occurrence_code_id(C,O,X)
10378 <=>
10379 ( O == 0 ->
10380 true % X = 0
10381 ;
10382 format('no occurrence code for ~w!\n',[C:O])
10383 ).
10385 get_success_continuation_code_id(C,O,NextId) :-
10386 get_success_continuation_occurrence(C,O,NextO),
10387 get_occurrence_code_id(C,NextO,NextId).
10389 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10390 % COLLECT CONSTANTS FOR INLINING
10391 %
10392 % for SSS
10394 %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS
10396 % collect_constants(+rules,+ast_rules,+constraint_symbols,+clauses) {{{
10397 collect_constants(Rules,AstRules,Constraints,Clauses0) :-
10398 ( not_restarted, chr_pp_flag(experiment,on) ->
10399 ( chr_pp_flag(sss,on) ->
10400 Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no],
10401 copy_term_nat(Clauses0,Clauses),
10402 flatten_clauses(Clauses,Dictionary,FlatClauses),
10403 install_new_declarations_and_restart(FlatClauses)
10404 ;
10405 maplist(collect_rule_constants(Constraints),AstRules),
10406 ( chr_pp_flag(verbose,on) ->
10407 print_chr_constants
10408 ;
10409 true
10410 ),
10411 ( chr_pp_flag(experiment,on) ->
10412 flattening_dictionary(Constraints,Dictionary),
10413 copy_term_nat(Clauses0,Clauses),
10414 flatten_clauses(Clauses,Dictionary,FlatClauses),
10415 install_new_declarations_and_restart(FlatClauses)
10416 ;
10417 true
10418 )
10419 )
10420 ;
10421 true
10422 ).
10424 :- chr_constraint chr_constants/1.
10425 :- chr_option(mode,chr_constants(+)).
10427 :- chr_constraint get_chr_constants/1.
10429 chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants.
10431 get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10433 % collect_rule_constants(+constraint_symbols,+ast_rule) {{{
10434 collect_rule_constants(Constraints,AstRule) :-
10435 AstRule = ast_rule(AstHead,_,_,AstBody,_),
10436 collect_head_constants(AstHead),
10437 collect_body_constants(AstBody,Constraints).
10439 collect_head_constants(simplification(H1)) :-
10440 maplist(collect_constraint_constants,H1).
10441 collect_head_constants(propagation(H2)) :-
10442 maplist(collect_constraint_constants,H2).
10443 collect_head_constants(simpagation(H1,H2)) :-
10444 maplist(collect_constraint_constants,H1),
10445 maplist(collect_constraint_constants,H2).
10447 collect_body_constants(AstBody,Constraints) :-
10448 maplist(collect_goal_constants(Constraints),AstBody).
10450 collect_goal_constants(Constraints,Goal) :-
10451 ( ast_nonvar(Goal) ->
10452 ast_symbol(Goal,Symbol),
10453 ( memberchk(Symbol,Constraints) ->
10454 ast_term_to_term(Goal,Term),
10455 ast_args(Goal,Arguments),
10456 collect_constraint_constants(chr_constraint(Symbol,Arguments,Term))
10457 ; Symbol == (:)/2,
10458 ast_args(Goal,[Arg1,Goal2]),
10459 Arg1 = atomic(Mod),
10460 get_target_module(Module),
10461 Mod == Module,
10462 ast_nonvar(Goal2),
10463 ast_symbol(Goal2,Symbol2),
10464 memberchk(Symbol2,Constraints) ->
10465 ast_term_to_term(Goal2,Term2),
10466 ast_args(Goal2,Arguments2),
10467 collect_constraint_constants(chr_constraint(Symbol2,Arguments2,Term2))
10468 ;
10469 true
10470 )
10471 ;
10472 true
10473 ).
10475 collect_constraint_constants(Head) :-
10476 Head = chr_constraint(Symbol,Arguments,_),
10477 get_constraint_type_det(Symbol,Types),
10478 collect_all_arg_constants(Arguments,Types,[]).
10480 collect_all_arg_constants([],[],Constants) :-
10481 ( Constants \== [] ->
10482 add_chr_constants(Constants)
10483 ;
10484 true
10485 ).
10486 collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :-
10487 unalias_type(Type,NormalizedType),
10488 ( is_chr_constants_type(NormalizedType,Key,_) ->
10489 ( ast_ground(Arg) ->
10490 ast_term_to_term(Arg,Term),
10491 collect_all_arg_constants(Args,Types,[Key-Term|Constants0])
10492 ; % no useful information here
10493 true
10494 )
10495 ;
10496 collect_all_arg_constants(Args,Types,Constants0)
10497 ).
10499 add_chr_constants(Pairs) :-
10500 keysort(Pairs,SortedPairs),
10501 add_chr_constants_(SortedPairs).
10503 :- chr_constraint add_chr_constants_/1.
10504 :- chr_option(mode,add_chr_constants_(+)).
10506 add_chr_constants_(Constants), chr_constants(MoreConstants) <=>
10507 sort([Constants|MoreConstants],NConstants),
10508 chr_constants(NConstants).
10510 add_chr_constants_(Constants) <=>
10511 chr_constants([Constants]).
10513 % }}}
10515 :- chr_constraint print_chr_constants/0. % {{{
10517 print_chr_constants, chr_constants(Constants) # Id ==>
10518 format('\t* chr_constants : ~w.\n',[Constants])
10519 pragma passive(Id).
10521 print_chr_constants <=>
10522 true.
10524 % }}}
10526 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10527 flattening_dictionary([],[]).
10528 flattening_dictionary([CS|CSs],Dictionary) :-
10529 ( flattening_dictionary_entry(CS,Entry) ->
10530 Dictionary = [Entry|Rest]
10531 ;
10532 Dictionary = Rest
10533 ),
10534 flattening_dictionary(CSs,Rest).
10536 flattening_dictionary_entry(CS,Entry) :-
10537 get_constraint_type_det(CS,Types),
10538 constant_positions(Types,1,Positions,Keys,Handler,MaybeEnum),
10539 ( Positions \== [] -> % there are chr_constant arguments
10540 pairup(Keys,Constants,Pairs0),
10541 keysort(Pairs0,Pairs),
10542 Entry = CS-Positions-Specs-Handler,
10543 get_chr_constants(ConstantsList),
10544 findall(Spec,
10545 ( member(Pairs,ConstantsList)
10546 , flat_spec(CS,Positions,Constants,Spec)
10547 ),
10548 Specs)
10549 ; MaybeEnum == yes ->
10550 enum_positions(Types,1,EnumPositions,ConstantsLists,EnumHandler),
10551 Entry = CS-EnumPositions-Specs-EnumHandler,
10552 findall(Spec,
10553 ( cartesian_product(Terms,ConstantsLists)
10554 , flat_spec(CS,EnumPositions,Terms,Spec)
10555 ),
10556 Specs)
10557 ).
10559 constant_positions([],_,[],[],no,no).
10560 constant_positions([Type|Types],I,Positions,Keys,Handler,MaybeEnum) :-
10561 unalias_type(Type,NormalizedType),
10562 ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) ->
10563 compose_error_handlers(ErrorHandler,NHandler,Handler),
10564 Positions = [I|NPositions],
10565 Keys = [Key|NKeys],
10566 MaybeEnum = NMaybeEnum
10567 ;
10568 ( is_chr_enum_type(NormalizedType,_,_) ->
10569 MaybeEnum = yes
10570 ;
10571 MaybeEnum = NMaybeEnum
10572 ),
10573 NPositions = Positions,
10574 NKeys = Keys,
10575 NHandler = Handler
10576 ),
10577 J is I + 1,
10578 constant_positions(Types,J,NPositions,NKeys,NHandler,NMaybeEnum).
10580 compose_error_handlers(no,Handler,Handler).
10581 compose_error_handlers(yes(Handler),_,yes(Handler)).
10583 enum_positions([],_,[],[],no).
10584 enum_positions([Type|Types],I,Positions,ConstantsLists,Handler) :-
10585 unalias_type(Type,NormalizedType),
10586 ( is_chr_enum_type(NormalizedType,Constants,ErrorHandler) ->
10587 compose_error_handlers(ErrorHandler,NHandler,Handler),
10588 Positions = [I|NPositions],
10589 ConstantsLists = [Constants|NConstantsLists]
10590 ; Positions = NPositions,
10591 ConstantsLists = NConstantsLists,
10592 Handler = NHandler
10593 ),
10594 J is I + 1,
10595 enum_positions(Types,J,NPositions,NConstantsLists,NHandler).
10597 cartesian_product([],[]).
10598 cartesian_product([E|Es],[L|Ls]) :-
10599 member(E,L),
10600 cartesian_product(Es,Ls).
10602 flat_spec(C/N,Positions,Terms,Spec) :-
10603 Spec = Terms - Functor,
10604 term_to_atom(Terms,TermsAtom),
10605 term_to_atom(Positions,PositionsAtom),
10606 atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor).
10608 % }}}
10610 % }}}
10611 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10612 % RESTART AFTER FLATTENING {{{
10614 restart_after_flattening(Declarations,Declarations) :-
10615 nb_setval('$chr_restart_after_flattening',started).
10616 restart_after_flattening(_,Declarations) :-
10617 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10618 nb_setval('$chr_restart_after_flattening',restarted).
10620 not_restarted :-
10621 nb_getval('$chr_restart_after_flattening',started).
10623 install_new_declarations_and_restart(Declarations) :-
10624 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10625 fail. /* fails to choicepoint of restart_after_flattening */
10626 % }}}
10627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10628 % FLATTENING {{{
10630 % DONE
10631 % -) generate dictionary from collected chr_constants
10632 % enable with :- chr_option(experiment,on).
10633 % -) issue constraint declarations for constraints not present in
10634 % dictionary
10635 % -) integrate with CHR compiler
10636 % -) pass Mike's test code (full syntactic support for current CHR code)
10637 % -) rewrite the body using the inliner
10638 %
10639 % TODO:
10640 % -) refined semantics correctness issue
10641 % -) incorporate chr_enum into dictionary generation
10642 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10644 flatten_clauses(Clauses,Dict,NClauses) :-
10645 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10646 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10648 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10649 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10650 dispatching_rules(Dict,NClauses1),
10651 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10652 flatten_rules(Clauses,Dict,NClauses3),
10653 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10655 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10656 % Declarations for non-flattened constraints
10658 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10659 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10660 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10661 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10662 flatten(DeclarationsList,Declarations).
10664 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10665 [(:- chr_constraint ConstraintSymbol),
10666 (:- chr_option(mode,ModeDeclPattern)),
10667 (:- chr_option(type_declaration,TypeDeclPattern))
10668 ]) :-
10669 ConstraintSymbol = Functor / Arity,
10670 % print optional mode declaration
10671 functor(ModeDeclPattern,Functor,Arity),
10672 ( memberchk(ModeDeclPattern,ModeDecls) ->
10673 true
10674 ;
10675 replicate(Arity,(?),Modes),
10676 ModeDeclPattern =.. [_|Modes]
10677 ),
10678 % print optional type declaration
10679 functor(TypeDeclPattern,Functor,Arity),
10680 ( memberchk(TypeDeclPattern,TypeDecls) ->
10681 true
10682 ;
10683 replicate(Arity,any,Types),
10684 TypeDeclPattern =.. [_|Types]
10685 ).
10686 % }}}
10687 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10688 % read clauses from file
10689 % CHR are returned
10690 % declared constaints are returned
10691 % type definitions are returned and printed
10692 % mode declarations are returned
10693 % other clauses are returned
10695 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10696 flatten_readcontent([],[],[],[],[],[],[]).
10697 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10698 % read(Clause),
10699 ( Clause == end_of_file ->
10700 Rules = [],
10701 ConstraintSymbols = [],
10702 ModeDecls = [],
10703 TypeDecls = [],
10704 TypeDefs = [],
10705 RestClauses = []
10706 ; crude_is_rule(Clause) ->
10707 Rules = [Clause|RestRules],
10708 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10709 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10710 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10711 append(SomeModeDecls,RestModeDecls,ModeDecls),
10712 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10713 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10714 ; is_mode_declaration(Clause,ModeDecl) ->
10715 ModeDecls = [ModeDecl|RestModeDecls],
10716 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10717 ; is_type_declaration(Clause,TypeDecl) ->
10718 TypeDecls = [TypeDecl|RestTypeDecls],
10719 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10720 ; is_type_definition(Clause,TypeDef) ->
10721 RestClauses = [Clause|NRestClauses],
10722 TypeDefs = [TypeDef|RestTypeDefs],
10723 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10724 ; ( Clause = (:- op(A,B,C)) ->
10725 % assert operators in order to read and print them out properly
10726 op(A,B,C)
10727 ;
10728 true
10729 ),
10730 RestClauses = [Clause|NRestClauses],
10731 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10732 ).
10734 crude_is_rule(_ @ _).
10735 crude_is_rule(_ pragma _).
10736 crude_is_rule(_ ==> _).
10737 crude_is_rule(_ <=> _).
10739 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10740 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10741 conj2list(Cs,Constraints0),
10742 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10744 pure_extract_type_mode([],[],[],[]).
10745 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10746 pure_extract_type_mode(R,R2,Modes,Types).
10747 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10748 functor(C,F,A),
10749 ConstraintSymbol = F/A,
10750 C =.. [_|Args],
10751 extract_types_and_modes(Args,ArgTypes,ArgModes),
10752 Mode =.. [F|ArgModes],
10753 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10754 Types = RTypes
10755 ;
10756 Types = [Type|RTypes],
10757 Type =.. [F|ArgTypes]
10758 ),
10759 pure_extract_type_mode(R,R2,Modes,RTypes).
10761 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10763 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10764 % }}}
10765 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10766 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10767 % including mode and type declarations
10769 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10770 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10771 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10772 flatten(ConstraintSpecs0,ConstraintSpecs).
10774 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10775 [(:- chr_constraint ConstraintSpec),
10776 (:- chr_option(mode,NewModeDecl)),
10777 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10778 member(C/N-I-SFs-_,Dict),
10779 arg_modes(C,N,ModeDecls,Modes),
10780 specialize_modes(Modes,I,SpecializedModes),
10781 arg_types(C,N,TypeDecls,Types),
10782 specialize_types(Types,I,SpecializedTypes),
10783 length(I,IndexSize),
10784 AN is N - IndexSize,
10785 member(_Term-F,SFs),
10786 ConstraintSpec = F/AN,
10787 NewModeDecl =.. [F|SpecializedModes],
10788 NewTypeDecl =.. [F|SpecializedTypes].
10790 arg_modes(C,N,ModeDecls,ArgModes) :-
10791 functor(ConstraintPattern,C,N),
10792 ( memberchk(ConstraintPattern,ModeDecls) ->
10793 ConstraintPattern =.. [_|ArgModes]
10794 ;
10795 replicate(N,?,ArgModes)
10796 ).
10798 specialize_modes(Modes,I,SpecializedModes) :-
10799 split_args(I,Modes,_,SpecializedModes).
10801 arg_types(C,N,TypeDecls,ArgTypes) :-
10802 functor(ConstraintPattern,C,N),
10803 ( memberchk(ConstraintPattern,TypeDecls) ->
10804 ConstraintPattern =.. [_|ArgTypes]
10805 ;
10806 replicate(N,any,ArgTypes)
10807 ).
10809 specialize_types(Types,I,SpecializedTypes) :-
10810 split_args(I,Types,_,SpecializedTypes).
10811 % }}}
10812 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10813 % DISPATCHING RULES
10814 %
10815 % dispatching_rules(+dict,-newrules)
10818 % {{{
10820 % This code generates a decision tree for calling the appropriate specialized
10821 % constraint based on the particular value of the argument the constraint
10822 % is being specialized on.
10823 %
10824 % In case an error handler is provided, the handler is called with the
10825 % unexpected constraint.
10827 dispatching_rules([],[]).
10828 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10829 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10830 dispatching_rules(Dict,RestDispatchingRules).
10832 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10833 ( increasing_numbers(I,1) ->
10834 /* index on first arguments */
10835 Rules0 = Rules,
10836 NCN = C/N
10837 ;
10838 /* reorder arguments for 1st argument indexing */
10839 functor(Head,C,N),
10840 Head =.. [_|Args],
10841 split_args(I,Args,GroundArgs,OtherArgs),
10842 append(GroundArgs,OtherArgs,ShuffledArgs),
10843 atom_concat(C,'_$shuffled',NC),
10844 Body =.. [NC|ShuffledArgs],
10845 [(Head :- Body)|Rules0] = Rules,
10846 NCN = NC / N
10847 ),
10848 Context = swap(C,I),
10849 dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10851 increasing_numbers([],_).
10852 increasing_numbers([X|Ys],X) :-
10853 Y is X + 1,
10854 increasing_numbers(Ys,Y).
10856 dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10857 length(I,IndexLength),
10858 once(pairup(TermLists,Functors,SFs)),
10859 maplist(head_tail,TermLists,Heads,Tails),
10860 Payload is N - IndexLength,
10861 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10862 dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10864 dispatching_action(Functor,PayloadArgs,Goal) :-
10865 Goal =.. [Functor|PayloadArgs].
10867 dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10868 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10870 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10871 % length MorePatterns == length Patterns == length Results
10872 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10873 MorePatterns = [List|_],
10874 length(List,N),
10875 aggregate_all(set(F/A),
10876 ( member(Pattern,Patterns),
10877 functor(Pattern,F,A)
10878 ),
10879 FAs),
10880 N1 is N + 1,
10881 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10883 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10884 ( MaybeErrorHandler = yes(ErrorHandler) ->
10885 Clauses0 = [ErrorClause|Clauses],
10886 ErrorClause = (Head :- Body),
10887 Arity is N + Payload,
10888 functor(Head,Symbol,Arity),
10889 reconstruct_original_term(Context,Head,Term),
10890 Body =.. [ErrorHandler,Term]
10891 ;
10892 Clauses0 = Clauses
10893 ).
10894 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10895 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10896 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10898 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10899 Clause = (Head :- Cut, Body),
10900 ( MaybeErrorHandler = yes(_) ->
10901 Cut = (!)
10902 ;
10903 Cut = true
10904 ),
10905 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10906 N1 is N + Payload,
10907 functor(Head,Symbol,N1),
10908 arg(1,Head,IndexPattern),
10909 Head =.. [_,_|RestArgs],
10910 length(PayloadArgs,Payload),
10911 once(append(Vs,PayloadArgs,RestArgs)),
10912 /* IndexPattern = F(...) */
10913 functor(IndexPattern,F,A),
10914 Context1 = index_functor(F,A,Context0),
10915 IndexPattern =.. [_|Args],
10916 append(Args,RestArgs,RecArgs),
10917 ( RecArgs == PayloadArgs ->
10918 /* nothing more to match on */
10919 List = Tail,
10920 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10921 MoreActions = [Action],
10922 call(Action,PayloadArgs,Body)
10923 ; /* more things to match on */
10924 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10925 ( MoreActions = [OneMoreAction] ->
10926 /* only one more thing to match on */
10927 MoreCases = [OneMoreCase],
10928 append([Cases,OneMoreCase,PayloadArgs],RecArgs),
10929 List = Tail,
10930 call(OneMoreAction,PayloadArgs,Body)
10931 ;
10932 /* more than one thing to match on */
10933 /* [ x1,..., xn]
10934 [xs1,...,xsn]
10935 */
10936 pairup(Cases,MoreCases,CasePairs),
10937 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10938 append(Args,Vs,[First|Rest]),
10939 First-Rest = CommonPatternPair,
10940 Context2 = gct([First|Rest],Context1),
10941 gensym(Prefix,RSymbol),
10942 append(DiffVars,PayloadArgs,RecCallVars),
10943 Body =.. [RSymbol|RecCallVars],
10944 findall(CH-CT,member([CH|CT],Differences),CPairs),
10945 once(pairup(CHs,CTs,CPairs)),
10946 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10947 )
10948 ).
10951 % split(list,int,before,at,after).
10953 split([X|Xs],I,Before,At,After) :-
10954 ( I == 1 ->
10955 Before = [],
10956 At = X,
10957 After = Xs
10958 ;
10959 J is I - 1,
10960 Before = [X|RBefore],
10961 split(Xs,J,RBefore,At,After)
10962 ).
10964 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10965 %
10966 % context ::= swap(functor,positions)
10967 % | index_functor(functor,arity,context)
10968 % | gct(Pattern,Context)
10970 reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :-
10971 functor(Term,_,Arity),
10972 functor(OriginalTerm,Functor,Arity),
10973 OriginalTerm =.. [_|OriginalArgs],
10974 split_args(Positions,OriginalArgs,IndexArgs,OtherArgs),
10975 Term =.. [_|Args],
10976 append(IndexArgs,OtherArgs,Args).
10977 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10978 Term0 =.. [Predicate|Args],
10979 split_at(Arity,Args,IndexArgs,RestArgs),
10980 Index =.. [Functor|IndexArgs],
10981 Term1 =.. [Predicate,Index|RestArgs],
10982 reconstruct_original_term(Context,Term1,OriginalTerm).
10983 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10984 copy_term_nat(PatternList,IndexTerms),
10985 term_variables(IndexTerms,Variables),
10986 Term0 =.. [Predicate|Args0],
10987 append(Variables,RestArgs,Args0),
10988 append(IndexTerms,RestArgs,Args1),
10989 Term1 =.. [Predicate|Args1],
10990 reconstruct_original_term(Context,Term1,OriginalTerm).
10991 % }}}
10993 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10994 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10995 %
10996 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10997 %
10998 % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler))
11000 % {{{
11001 flatten_rules(Rules,Dict,FlatRules) :-
11002 flatten_rules1(Rules,Dict,FlatRulesList),
11003 flatten(FlatRulesList,FlatRules).
11005 flatten_rules1([],_,[]).
11006 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
11007 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
11008 flatten_rules1(Rules,Dict,FlatRulesList).
11010 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
11011 flatten_rule(Rule,Dict,NRule).
11012 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
11013 flatten_rule(Rule,Dict,NRule).
11014 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
11015 flatten_heads(H,Dict,NH),
11016 flatten_body(B,Dict,NB).
11017 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
11018 flatten_heads((H1,H2),Dict,(NH1,NH2)),
11019 flatten_body(B,Dict,NB).
11020 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
11021 flatten_heads(H,Dict,NH),
11022 flatten_body(B,Dict,NB).
11024 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
11025 flatten_heads(H1,Dict,NH1),
11026 flatten_heads(H2,Dict,NH2).
11027 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
11028 flatten_heads(H,Dict,NH).
11029 flatten_heads(H,Dict,NH) :-
11030 ( functor(H,C,N),
11031 memberchk(C/N-ArgPositions-SFs-_,Dict) ->
11032 H =.. [_|AllArgs],
11033 split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs),
11034 member(GroundArgs-Name,SFs),
11035 NH =.. [Name|OtherArgs]
11036 ;
11037 NH = H
11038 ).
11040 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
11041 conj2list(Guard,Guards),
11042 maplist(flatten_goal(Dict),Guards,NGuards),
11043 list2conj(NGuards,NGuard),
11044 conj2list(Body,Goals),
11045 maplist(flatten_goal(Dict),Goals,NGoals),
11046 list2conj(NGoals,NBody).
11047 flatten_body(Body,Dict,NBody) :-
11048 conj2list(Body,Goals),
11049 maplist(flatten_goal(Dict),Goals,NGoals),
11050 list2conj(NGoals,NBody).
11052 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
11053 flatten_goal(Dict,Goal,NGoal) :-
11054 ( is_specializable_goal(Goal,Dict,ArgPositions)
11055 ->
11056 specialize_goal(Goal,ArgPositions,NGoal)
11057 ; Goal = Mod : TheGoal,
11058 get_target_module(Module),
11059 Mod == Module,
11060 nonvar(TheGoal),
11061 is_specializable_goal(TheGoal,Dict,ArgPositions)
11062 ->
11063 specialize_goal(TheGoal,ArgPositions,NTheGoal),
11064 NGoal = Mod : NTheGoal
11065 ; partial_eval(Goal,NGoal)
11066 ->
11067 true
11068 ;
11069 NGoal = Goal
11070 ).
11072 %-------------------------------------------------------------------------------%
11073 % Specialize body/guard goal
11074 %-------------------------------------------------------------------------------%
11075 is_specializable_goal(Goal,Dict,ArgPositions) :-
11076 functor(Goal,C,N),
11077 memberchk(C/N-ArgPositions-_-_,Dict),
11078 args(ArgPositions,Goal,Args),
11079 ground(Args).
11081 specialize_goal(Goal,ArgPositions,NGoal) :-
11082 functor(Goal,C,N),
11083 Goal =.. [_|Args],
11084 split_args(ArgPositions,Args,GroundTerms,Others),
11085 flat_spec(C/N,ArgPositions,GroundTerms,_-Functor),
11086 NGoal =.. [Functor|Others].
11088 %-------------------------------------------------------------------------------%
11089 % Partially evaluate predicates
11090 %-------------------------------------------------------------------------------%
11092 % append([],Y,Z) >--> Y = Z
11093 % append(X,[],Z) >--> X = Z
11094 partial_eval(append(L1,L2,L3),NGoal) :-
11095 ( L1 == [] ->
11096 NGoal = (L3 = L2)
11097 ; L2 == [] ->
11098 NGoal = (L3 = L1)
11100 ).
11101 % flatten_path(L1,L2) >--> flatten_path(L1',L2)
11102 % where flatten(L1,L1')
11103 partial_eval(flatten_path(L1,L2),NGoal) :-
11104 nonvar(L1),
11105 flatten(L1,FlatterL1),
11106 FlatterL1 \== L1 ->
11107 NGoal = flatten_path(FlatterL1,L2).
11110 % }}}
11112 % }}}
11113 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11114 dump_code(Clauses) :-
11115 ( chr_pp_flag(dump,on) ->
11116 maplist(portray_clause,Clauses)
11117 ;
11118 true
11119 ).
11121 chr_banner :-
11122 chr_info(banner,'\tThe K.U.Leuven CHR System\n\t\tMain Developer:\tTom Schrijvers\n\t\tContributors:\tJon Sneyers, Bart Demoen, Jan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]).
11124 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11125 % LOCKING {{{
11127 chr_none_locked(Vars,Goal) :-
11128 chr_pp_flag(guard_locks,Flag),
11129 ( Flag == off ->
11130 Goal = true
11131 ; Flag == on ->
11132 Goal = 'chr none_locked'( Vars)
11133 ; Flag == error ->
11134 Goal = 'chr none_error_locked'( Vars)
11135 ).
11137 chr_not_locked(Var,Goal) :-
11138 chr_pp_flag(guard_locks,Flag),
11139 ( Flag == off ->
11140 Goal = true
11141 ; Flag == on ->
11142 Goal = 'chr not_locked'( Var)
11143 ; Flag == error ->
11144 Goal = 'chr not_error_locked'( Var)
11145 ).
11147 chr_lock(Var,Goal) :-
11148 chr_pp_flag(guard_locks,Flag),
11149 ( Flag == off ->
11150 Goal = true
11151 ; Flag == on ->
11152 Goal = 'chr lock'( Var)
11153 ; Flag == error ->
11154 Goal = 'chr error_lock'( Var)
11155 ).
11157 chr_unlock(Var,Goal) :-
11158 chr_pp_flag(guard_locks,Flag),
11159 ( Flag == off ->
11160 Goal = true
11161 ; Flag == on ->
11162 Goal = 'chr unlock'( Var)
11163 ; Flag == error ->
11164 Goal = 'chr unerror_lock'( Var)
11165 ).
11166 % }}}
11167 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11168 % AST representation
11169 % each AST representation caches the original term
11170 %
11171 % ast_term ::= atomic(Term)
11172 % | compound(Functor,Arity,list(ast_term),Term)
11173 % | var(int,Term)
11174 % -- unique integer identifier
11176 % Conversion Predicate {{{
11177 :- chr_type var_id == natural.
11179 term_to_ast_term(Term,AstTerm,VarEnv,NVarEnv) :-
11180 ( atomic(Term) ->
11181 AstTerm = atomic(Term),
11182 NVarEnv = VarEnv
11183 ; compound(Term) ->
11184 functor(Term,Functor,Arity),
11185 AstTerm = compound(Functor,Arity,AstTerms,Term),
11186 Term =.. [_|Args],
11187 maplist_dcg(chr_translate:term_to_ast_term,Args,AstTerms,VarEnv,NVarEnv)
11188 ; var(Term) ->
11189 var_to_ast_term(Term,VarEnv,AstTerm,NVarEnv)
11190 ).
11192 var_to_ast_term(Var,Env,AstTerm,NVarEnv) :-
11193 Env = VarDict - VarId,
11194 ( lookup_eq(VarDict,Var,AstTerm) ->
11195 NVarEnv = Env
11196 ;
11197 AstTerm = var(VarId,Var),
11198 NVarId is VarId + 1,
11199 NVarDict = [Var - AstTerm|VarDict],
11200 NVarEnv = NVarDict - NVarId
11201 ).
11203 % ast_constraint ::= chr_constraint(Symbol,Arguments,Constraint)
11204 chr_constraint_to_ast_constraint(CHRConstraint,AstConstraint,VarEnv,NVarEnv) :-
11205 AstConstraint = chr_constraint(Functor/Arity,AstTerms,CHRConstraint),
11206 functor(CHRConstraint,Functor,Arity),
11207 CHRConstraint =.. [_|Arguments],
11208 maplist_dcg(chr_translate:term_to_ast_term,Arguments,AstTerms,VarEnv,NVarEnv).
11210 % ast_head ::= simplification(list(chr_constraint))
11211 % | propagation(list(chr_constraint))
11212 % | simpagation(list(chr_constraint),list(chr_constraint))
11214 % head_id ::= int
11216 % ast_guard ::= list(ast_term)
11217 % ast_body ::= list(ast_term)
11219 % ast_rule ::= ast_rule(ast_head,ast_guard,guard,ast_body,body)
11221 rule_to_ast_rule(Rule,AstRule) :-
11222 AstRule = ast_rule(Head,AstGuard,Guard,AstBody,Body),
11223 Rule = rule(H1,H2,Guard,Body),
11224 EmptyVarEnv = []-1,
11225 ( H1 == [] ->
11226 Head = propagation(AstConstraints),
11227 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,AstConstraints,EmptyVarEnv,VarEnv1)
11228 ; H2 == [] ->
11229 Head = simplification(AstConstraints),
11230 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,AstConstraints,EmptyVarEnv,VarEnv1)
11231 ;
11232 Head = simpagation(RemovedAstConstraints,KeptAstConstraints),
11233 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,RemovedAstConstraints,EmptyVarEnv,VarEnv0),
11234 maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,KeptAstConstraints,VarEnv0,VarEnv1)
11235 ),
11236 conj2list(Guard,GuardList),
11237 maplist_dcg(chr_translate:term_to_ast_term,GuardList,AstGuard,VarEnv1,VarEnv2),
11238 conj2list(Body,BodyList),
11239 maplist_dcg(chr_translate:term_to_ast_term,BodyList,AstBody,VarEnv2,_).
11241 pragma_rule_to_ast_rule(pragma(Rule,_,_,_,_),AstRule) :-
11242 rule_to_ast_rule(Rule,AstRule).
11244 check_rule_to_ast_rule(Rule) :-
11245 ( rule_to_ast_rule(Rule,AstRule) ->
11246 writeln(AstRule)
11247 ;
11248 writeln(failed(rule_to_ast_rule(Rule,AstRule)))
11249 ).
11251 % }}}
11253 % AST Utility Predicates {{{
11254 ast_term_to_term(var(_,Var),Var).
11255 ast_term_to_term(atomic(Atom),Atom).
11256 ast_term_to_term(compound(_,_,_,Compound),Compound).
11258 ast_nonvar(atomic(_)).
11259 ast_nonvar(compound(_,_,_,_)).
11261 ast_ground(atomic(_)).
11262 ast_ground(compound(_,_,Arguments,_)) :-
11263 maplist(ast_ground,Arguments).
11265 %------------------------------------------------------------------------------%
11266 % Check whether a term is ground, given a set of variables that are ground.
11267 %------------------------------------------------------------------------------%
11268 ast_is_ground(VarSet,AstTerm) :-
11269 ast_is_ground_(AstTerm,VarSet).
11271 ast_is_ground_(var(VarId,_),VarSet) :-
11272 tree_set_memberchk(VarId,VarSet).
11273 ast_is_ground_(atomic(_),_).
11274 ast_is_ground_(compound(_,_,Arguments,_),VarSet) :-
11275 maplist(ast_is_ground(VarSet),Arguments).
11276 %------------------------------------------------------------------------------%
11278 ast_functor(atomic(Atom),Atom,0).
11279 ast_functor(compound(Functor,Arity,_,_),Functor,Arity).
11281 ast_symbol(atomic(Atom),Atom/0).
11282 ast_symbol(compound(Functor,Arity,_,_),Functor/Arity).
11284 ast_args(atomic(_),[]).
11285 ast_args(compound(_,_,Arguments,_),Arguments).
11287 %------------------------------------------------------------------------------%
11288 % Add variables in a term to a given set.
11289 %------------------------------------------------------------------------------%
11290 ast_term_variables(atomic(_),Set,Set).
11291 ast_term_variables(compound(_,_,Args,_),Set,NSet) :-
11292 ast_term_list_variables(Args,Set,NSet).
11293 ast_term_variables(var(VarId,_),Set,NSet) :-
11294 tree_set_add(Set,VarId,NSet).
11296 ast_term_list_variables(Terms,Set,NSet) :-
11297 fold(Terms,chr_translate:ast_term_variables,Set,NSet).
11298 %------------------------------------------------------------------------------%
11300 ast_constraint_variables(chr_constraint(_,Args,_),Set,NSet) :-
11301 ast_term_list_variables(Args,Set,NSet).
11303 ast_constraint_list_variables(Constraints,Set,NSet) :-
11304 fold(Constraints,chr_translate:ast_constraint_variables,Set,NSet).
11306 ast_head_variables(simplification(H1),Set,NSet) :-
11307 ast_constraint_list_variables(H1,Set,NSet).
11308 ast_head_variables(propagation(H2),Set,NSet) :-
11309 ast_constraint_list_variables(H2,Set,NSet).
11310 ast_head_variables(simpagation(H1,H2),Set,NSet) :-
11311 ast_constraint_list_variables(H1,Set,Set1),
11312 ast_constraint_list_variables(H2,Set1,NSet).
11314 ast_var_memberchk(var(VarId,_),Set) :-
11315 tree_set_memberchk(VarId,Set).
11317 %------------------------------------------------------------------------------%
11318 % Return term based on AST-term with variables mapped.
11319 %------------------------------------------------------------------------------%
11320 ast_instantiate(Map,AstTerm,Term) :-
11321 ast_instantiate_(AstTerm,Map,Term).
11323 ast_instantiate_(var(VarId,_),Map,Term) :-
11324 get_assoc(VarId,Map,Term).
11325 ast_instantiate_(atomic(Atom),_,Atom).
11326 ast_instantiate_(compound(Functor,Arity,Arguments,_),Map,Term) :-
11327 functor(Term,Functor,Arity),
11328 Term =.. [_|Terms],
11329 maplist(ast_instantiate(Map),Arguments,Terms).
11330 %------------------------------------------------------------------------------%
11331 % }}}
11333 %------------------------------------------------------------------------------%
11334 % ast_head_arg_matches_(list(silent_pair(ast_term,var)
11335 % ,modes
11336 % ,map(var_id,...)
11337 % ,set(variables)
11338 % ,list(goal)
11339 % ,vardict
11340 % ,set(variables)
11341 % )
11342 %------------------------------------------------------------------------------%
11344 ast_head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
11345 ast_head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
11346 ( Mode == (+) ->
11347 ast_term_variables(Arg,GroundVars0,GroundVars),
11348 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
11349 ;
11350 ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
11351 ).
11352 ast_head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
11353 ( Arg = var(VarId,_) ->
11354 ( get_assoc(VarId,VarDict,OtherVar) ->
11355 ( Mode = (+) ->
11356 ( tree_set_memberchk(VarId,GroundVars) ->
11357 GoalList = [Var = OtherVar | RestGoalList],
11358 GroundVars1 = GroundVars
11359 ;
11360 GoalList = [Var == OtherVar | RestGoalList],
11361 tree_set_add(GroundVars,VarId,GroundVars1)
11362 )
11363 ;
11364 GoalList = [Var == OtherVar | RestGoalList],
11365 GroundVars1 = GroundVars
11366 ),
11367 VarDict1 = VarDict
11368 ;
11369 put_assoc(VarId,VarDict,Var,VarDict1),
11370 GoalList = RestGoalList,
11371 ( Mode = (+) ->
11373 tree_set_add(GroundVars,VarId,GroundVars1)
11374 ;
11375 GroundVars1 = GroundVars
11376 )
11377 ),
11378 Pairs = Rest,
11379 RestModes = Modes
11380 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> % TODO
11381 identifier_label_atom(IndexType,Var,ActualArg,Goal),
11382 GoalList = [Goal|RestGoalList],
11383 VarDict = VarDict1,
11384 GroundVars1 = GroundVars,
11385 Pairs = Rest,
11386 RestModes = Modes
11387 ; Arg = atomic(Atom) ->
11388 ( Mode = (+) ->
11389 GoalList = [ Var = Atom | RestGoalList]
11390 ;
11391 GoalList = [ Var == Atom | RestGoalList]
11392 ),
11393 VarDict = VarDict1,
11394 GroundVars1 = GroundVars,
11395 Pairs = Rest,
11396 RestModes = Modes
11397 ; Mode == (+), ast_is_ground(GroundVars,Arg) ->
11398 ast_instantiate(VarDict,Arg,ArgInst),
11399 GoalList = [ Var = ArgInst | RestGoalList],
11400 VarDict = VarDict1,
11401 GroundVars1 = GroundVars,
11402 Pairs = Rest,
11403 RestModes = Modes
11404 ; Mode == (?), ast_is_ground(GroundVars,Arg) ->
11405 ast_instantiate(VarDict,Arg,ArgInst),
11406 GoalList = [ Var == ArgInst | RestGoalList],
11407 VarDict = VarDict1,
11408 GroundVars1 = GroundVars,
11409 Pairs = Rest,
11410 RestModes = Modes
11411 ; Arg = compound(Functor,Arity,Arguments,_),
11412 functor(Term,Functor,Arity),
11413 Term =.. [_|Vars],
11414 ( Mode = (+) ->
11415 GoalList = [ Var = Term | RestGoalList ]
11416 ;
11417 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
11418 ),
11419 pairup(Arguments,Vars,NewPairs),
11420 append(NewPairs,Rest,Pairs),
11421 replicate(N,Mode,NewModes),
11422 append(NewModes,Modes,RestModes),
11423 VarDict1 = VarDict,
11424 GroundVars1 = GroundVars
11425 ),
11426 ast_head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).