| blob | e4596d54ae0fb99111d19a6db814a1662d5a1af0 |
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(1130, xfx, --->).
160 :- op(980, fx, (+)).
161 :- op(980, fx, (-)).
162 :- op(980, fx, (?)).
163 :- op(1150, fx, constraints).
164 :- op(1150, fx, chr_constraint).
165 % }}}
167 :- chr_option(debug,off).
168 :- chr_option(optimize,full).
169 :- chr_option(check_guard_bindings,off).
171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
172 % Type Declarations {{{
173 :- chr_type list(T) ---> [] ; [T|list(T)].
175 :- chr_type list == list(any).
177 :- chr_type mode ---> (+) ; (-) ; (?).
179 :- chr_type maybe(T) ---> yes(T) ; no.
181 :- chr_type constraint ---> any / any.
183 :- chr_type module_name == any.
185 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
186 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
187 :- chr_type idspair ---> ids(list(id),list(id)).
189 :- chr_type pragma_type ---> passive(id)
190 ; mpassive(list(id))
191 ; already_in_heads
192 ; already_in_heads(id)
193 ; no_history
194 ; history(history_name,list(id)).
195 :- chr_type history_name== any.
197 :- chr_type rule_name == any.
198 :- chr_type rule_nb == natural.
199 :- chr_type id == natural.
200 :- chr_type occurrence == int.
202 :- chr_type goal == any.
204 :- chr_type store_type ---> default
205 ; multi_store(list(store_type))
206 ; multi_hash(list(list(int)))
207 ; multi_inthash(list(list(int)))
208 ; global_singleton
209 ; global_ground
210 % EXPERIMENTAL STORES
211 ; atomic_constants(list(int),list(any),coverage)
212 ; ground_constants(list(int),list(any),coverage)
213 ; var_assoc_store(int,list(int))
214 ; identifier_store(int)
215 ; type_indexed_identifier_store(int,any).
216 :- chr_type coverage ---> complete ; incomplete.
217 % }}}
218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
220 %------------------------------------------------------------------------------%
221 :- chr_constraint chr_source_file/1.
222 :- chr_option(mode,chr_source_file(+)).
223 :- chr_option(type_declaration,chr_source_file(module_name)).
224 %------------------------------------------------------------------------------%
225 chr_source_file(_) \ chr_source_file(_) <=> true.
227 %------------------------------------------------------------------------------%
228 :- chr_constraint get_chr_source_file/1.
229 :- chr_option(mode,get_chr_source_file(-)).
230 :- chr_option(type_declaration,get_chr_source_file(module_name)).
231 %------------------------------------------------------------------------------%
232 chr_source_file(Mod) \ get_chr_source_file(Query)
233 <=> Query = Mod .
234 get_chr_source_file(Query)
235 <=> Query = user.
238 %------------------------------------------------------------------------------%
239 :- chr_constraint target_module/1.
240 :- chr_option(mode,target_module(+)).
241 :- chr_option(type_declaration,target_module(module_name)).
242 %------------------------------------------------------------------------------%
243 target_module(_) \ target_module(_) <=> true.
245 %------------------------------------------------------------------------------%
246 :- chr_constraint get_target_module/1.
247 :- chr_option(mode,get_target_module(-)).
248 :- chr_option(type_declaration,get_target_module(module_name)).
249 %------------------------------------------------------------------------------%
250 target_module(Mod) \ get_target_module(Query)
251 <=> Query = Mod .
252 get_target_module(Query)
253 <=> Query = user.
255 %------------------------------------------------------------------------------%
256 :- chr_constraint line_number/2.
257 :- chr_option(mode,line_number(+,+)).
258 :- chr_option(type_declaration,line_number(rule_nb,int)).
259 %------------------------------------------------------------------------------%
260 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
262 %------------------------------------------------------------------------------%
263 :- chr_constraint get_line_number/2.
264 :- chr_option(mode,get_line_number(+,-)).
265 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
266 %------------------------------------------------------------------------------%
267 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
268 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
270 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
271 :- chr_option(mode,indexed_argument(+,+)).
272 :- chr_option(type_declaration,indexed_argument(constraint,int)).
274 :- chr_constraint is_indexed_argument/2.
275 :- chr_option(mode,is_indexed_argument(+,+)).
276 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
278 :- chr_constraint constraint_mode/2.
279 :- chr_option(mode,constraint_mode(+,+)).
280 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
282 :- chr_constraint get_constraint_mode/2.
283 :- chr_option(mode,get_constraint_mode(+,-)).
284 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
286 :- chr_constraint may_trigger/1.
287 :- chr_option(mode,may_trigger(+)).
288 :- chr_option(type_declaration,may_trigger(constraint)).
290 :- chr_constraint only_ground_indexed_arguments/1.
291 :- chr_option(mode,only_ground_indexed_arguments(+)).
292 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
294 :- chr_constraint none_suspended_on_variables/0.
296 :- chr_constraint are_none_suspended_on_variables/0.
298 :- chr_constraint store_type/2.
299 :- chr_option(mode,store_type(+,+)).
300 :- chr_option(type_declaration,store_type(constraint,store_type)).
302 :- chr_constraint get_store_type/2.
303 :- chr_option(mode,get_store_type(+,?)).
304 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
306 :- chr_constraint update_store_type/2.
307 :- chr_option(mode,update_store_type(+,+)).
308 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
310 :- chr_constraint actual_store_types/2.
311 :- chr_option(mode,actual_store_types(+,+)).
312 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
314 :- chr_constraint assumed_store_type/2.
315 :- chr_option(mode,assumed_store_type(+,+)).
316 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
318 :- chr_constraint validate_store_type_assumption/1.
319 :- chr_option(mode,validate_store_type_assumption(+)).
320 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
322 :- chr_constraint rule_count/1.
323 :- chr_option(mode,rule_count(+)).
324 :- chr_option(type_declaration,rule_count(natural)).
326 :- chr_constraint inc_rule_count/1.
327 :- chr_option(mode,inc_rule_count(-)).
328 :- chr_option(type_declaration,inc_rule_count(natural)).
330 rule_count(_) \ rule_count(_)
331 <=> true.
332 rule_count(C), inc_rule_count(NC)
333 <=> NC is C + 1, rule_count(NC).
334 inc_rule_count(NC)
335 <=> NC = 1, rule_count(NC).
337 :- chr_constraint passive/2.
338 :- chr_option(mode,passive(+,+)).
340 :- chr_constraint is_passive/2.
341 :- chr_option(mode,is_passive(+,+)).
343 :- chr_constraint any_passive_head/1.
344 :- chr_option(mode,any_passive_head(+)).
346 :- chr_constraint new_occurrence/4.
347 :- chr_option(mode,new_occurrence(+,+,+,+)).
349 :- chr_constraint occurrence/5.
350 :- chr_option(mode,occurrence(+,+,+,+,+)).
351 :- chr_type occurrence_type ---> simplification ; propagation.
352 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
354 :- chr_constraint get_occurrence/4.
355 :- chr_option(mode,get_occurrence(+,+,-,-)).
357 :- chr_constraint get_occurrence_from_id/4.
358 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
360 :- chr_constraint max_occurrence/2.
361 :- chr_option(mode,max_occurrence(+,+)).
363 :- chr_constraint get_max_occurrence/2.
364 :- chr_option(mode,get_max_occurrence(+,-)).
366 :- chr_constraint allocation_occurrence/2.
367 :- chr_option(mode,allocation_occurrence(+,+)).
369 :- chr_constraint get_allocation_occurrence/2.
370 :- chr_option(mode,get_allocation_occurrence(+,-)).
372 :- chr_constraint rule/2.
373 :- chr_option(mode,rule(+,+)).
374 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
376 :- chr_constraint get_rule/2.
377 :- chr_option(mode,get_rule(+,-)).
378 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
380 :- chr_constraint least_occurrence/2.
381 :- chr_option(mode,least_occurrence(+,+)).
382 :- chr_option(type_declaration,least_occurrence(any,list)).
384 :- chr_constraint is_least_occurrence/1.
385 :- chr_option(mode,is_least_occurrence(+)).
388 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
389 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
390 is_indexed_argument(_,_) <=> fail.
392 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
394 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
395 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
396 Q = Mode.
397 get_constraint_mode(FA,Q) <=>
398 FA = _ / N,
399 replicate(N,(?),Q).
401 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
403 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
404 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
405 nth1(I,Mode,M),
406 M \== (+) |
407 is_stored(FA).
408 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
410 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
411 <=>
412 nth1(I,Mode,M),
413 M \== (+)
414 |
415 fail.
416 only_ground_indexed_arguments(_) <=>
417 true.
419 none_suspended_on_variables \ none_suspended_on_variables <=> true.
420 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
421 are_none_suspended_on_variables <=> fail.
422 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
423 % STORE TYPES
424 %
425 % The functionality for inspecting and deciding on the different types of constraint
426 % store / indexes for constraints.
428 store_type(FA,StoreType)
429 ==> chr_pp_flag(verbose,on)
430 |
431 format('The indexes for ~w are:\n',[FA]),
432 format_storetype(StoreType).
433 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
435 format_storetype(multi_store(StoreTypes)) :- !,
436 maplist(format_storetype,StoreTypes).
437 format_storetype(atomic_constants(Index,Constants,_)) :-
438 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
439 format_storetype(ground_constants(Index,Constants,_)) :-
440 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
441 format_storetype(StoreType) :-
442 format('\t* ~w\n',[StoreType]).
445 % 1. Inspection
446 % ~~~~~~~~~~~~~
447 %
448 %
450 get_store_type_normal @
451 store_type(FA,Store) \ get_store_type(FA,Query)
452 <=> Query = Store.
454 get_store_type_assumed @
455 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
456 <=> Query = Store.
458 get_store_type_default @
459 get_store_type(_,Query)
460 <=> Query = default.
462 % 2. Store type registration
463 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
465 actual_store_types(C,STs) \ update_store_type(C,ST)
466 <=> memberchk(ST,STs) | true.
467 update_store_type(C,ST), actual_store_types(C,STs)
468 <=>
469 actual_store_types(C,[ST|STs]).
470 update_store_type(C,ST)
471 <=>
472 actual_store_types(C,[ST]).
474 % 3. Final decision on store types
475 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
477 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
478 <=>
479 true % chr_pp_flag(experiment,on)
480 |
481 delete(STs,multi_hash([Index]),STs0),
482 Index = [IndexPos],
483 ( get_constraint_arg_type(C,IndexPos,Type),
484 enumerated_atomic_type(Type,Atoms) ->
485 /* use the type constants rather than the collected keys */
486 Constants = Atoms,
487 Completeness = complete
488 ;
489 Constants = Keys,
490 Completeness = incomplete
491 ),
492 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
493 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
494 <=>
495 true % chr_pp_flag(experiment,on)
496 |
497 ( Index = [IndexPos],
498 get_constraint_arg_type(C,IndexPos,Type),
499 ( Type = chr_constants(Key) -> get_chr_constants(Key,Constants)
500 ; Type = chr_enum(Constants) -> true
501 )
502 ->
503 Completeness = complete
504 ;
505 Constants = Constants0,
506 Completeness = incomplete
507 ),
508 delete(STs,multi_hash([Index]),STs0),
509 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
511 get_constraint_arg_type(C,Pos,Type) :-
512 get_constraint_type(C,Types),
513 nth1(Pos,Types,Type0),
514 unalias_type(Type0,Type).
516 validate_store_type_assumption(C) \ actual_store_types(C,STs)
517 <=>
518 % chr_pp_flag(experiment,on),
519 memberchk(multi_hash([[Index]]),STs),
520 get_constraint_type(C,Types),
521 nth1(Index,Types,Type),
522 enumerated_atomic_type(Type,Atoms)
523 |
524 delete(STs,multi_hash([[Index]]),STs0),
525 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
526 validate_store_type_assumption(C) \ actual_store_types(C,STs)
527 <=>
528 memberchk(multi_hash([[Index]]),STs),
529 get_constraint_arg_type(C,Index,Type),
530 ( Type = chr_enum(Constants) -> true
531 ; Type = chr_constants(Key) -> get_chr_constants(Key,Constants)
532 )
533 |
534 delete(STs,multi_hash([[Index]]),STs0),
535 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
536 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
537 <=>
538 ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) ->
539 Stores = [global_ground|STs]
540 ;
541 Stores = STs
542 ),
543 store_type(C,multi_store(Stores)).
544 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
545 <=>
546 store_type(C,multi_store(STs)).
547 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
548 <=>
549 chr_pp_flag(debugable,on)
550 |
551 store_type(C,default).
552 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
553 <=> store_type(C,global_ground).
554 validate_store_type_assumption(C)
555 <=> true.
557 partial_store(ground_constants(_,_,incomplete)).
558 partial_store(atomic_constants(_,_,incomplete)).
560 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
561 passive(R,ID) \ passive(R,ID) <=> true.
563 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
564 is_passive(_,_) <=> fail.
566 passive(RuleNb,_) \ any_passive_head(RuleNb)
567 <=> true.
568 any_passive_head(_)
569 <=> fail.
570 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
572 max_occurrence(C,N) \ max_occurrence(C,M)
573 <=> N >= M | true.
575 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
576 NO is MO + 1,
577 occurrence(C,NO,RuleNb,ID,Type),
578 max_occurrence(C,NO).
579 new_occurrence(C,RuleNb,ID,_) <=>
580 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
582 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
583 <=> Q = MON.
584 get_max_occurrence(C,Q)
585 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
587 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
588 <=> Rule = QRule, ID = QID.
589 get_occurrence(C,O,_,_)
590 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
592 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
593 <=> QC = C, QON = ON.
594 get_occurrence_from_id(C,O,_,_)
595 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
597 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
598 % Late allocation
600 late_allocation_analysis(Cs) :-
601 ( chr_pp_flag(late_allocation,on) ->
602 maplist(late_allocation, Cs)
603 ;
604 true
605 ).
607 late_allocation(C) :- late_allocation(C,0).
608 late_allocation(C,O) :- allocation_occurrence(C,O), !.
609 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
611 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
613 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
615 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
616 \+ is_passive(RuleNb,Id),
617 Type == propagation,
618 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
619 true
620 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
621 is_observed(C,O)
622 ; is_least_occurrence(RuleNb) -> % propagation rule
623 is_observed(C,O)
624 ;
625 true
626 ).
628 stored_in_guard_before_next_kept_occurrence(C,O) :-
629 chr_pp_flag(store_in_guards, on),
630 NO is O + 1,
631 stored_in_guard_lookahead(C,NO).
633 :- chr_constraint stored_in_guard_lookahead/2.
634 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
636 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
637 NO is O + 1, stored_in_guard_lookahead(C,NO).
638 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
639 Type == simplification,
640 ( is_stored_in_guard(C,RuleNb) ->
641 true
642 ;
643 NO is O + 1, stored_in_guard_lookahead(C,NO)
644 ).
645 stored_in_guard_lookahead(_,_) <=> fail.
648 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
649 \ least_occurrence(RuleNb,[ID|IDs])
650 <=> AO >= O, \+ may_trigger(C) |
651 least_occurrence(RuleNb,IDs).
652 rule(RuleNb,Rule), passive(RuleNb,ID)
653 \ least_occurrence(RuleNb,[ID|IDs])
654 <=> least_occurrence(RuleNb,IDs).
656 rule(RuleNb,Rule)
657 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
658 least_occurrence(RuleNb,IDs).
660 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
661 <=> true.
662 is_least_occurrence(_)
663 <=> fail.
665 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
666 <=> Q = O.
667 get_allocation_occurrence(_,Q)
668 <=> chr_pp_flag(late_allocation,off), Q=0.
669 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
671 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
672 <=> Q = Rule.
673 get_rule(_,_)
674 <=> fail.
676 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
678 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
679 %
680 % Default store constraint index assignment.
682 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
683 :- chr_option(mode,constraint_index(+,+)).
684 :- chr_option(type_declaration,constraint_index(constraint,int)).
686 :- chr_constraint get_constraint_index/2.
687 :- chr_option(mode,get_constraint_index(+,-)).
688 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
690 :- chr_constraint get_indexed_constraint/2.
691 :- chr_option(mode,get_indexed_constraint(+,-)).
692 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
694 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
695 :- chr_option(mode,max_constraint_index(+)).
696 :- chr_option(type_declaration,max_constraint_index(int)).
698 :- chr_constraint get_max_constraint_index/1.
699 :- chr_option(mode,get_max_constraint_index(-)).
700 :- chr_option(type_declaration,get_max_constraint_index(int)).
702 constraint_index(C,Index) \ get_constraint_index(C,Query)
703 <=> Query = Index.
704 get_constraint_index(C,Query)
705 <=> fail.
707 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
708 <=> Q = C.
709 get_indexed_constraint(Index,Q)
710 <=> fail.
712 max_constraint_index(Index) \ get_max_constraint_index(Query)
713 <=> Query = Index.
714 get_max_constraint_index(Query)
715 <=> Query = 0.
717 set_constraint_indices(Constraints) :-
718 set_constraint_indices(Constraints,1).
719 set_constraint_indices([],M) :-
720 N is M - 1,
721 max_constraint_index(N).
722 set_constraint_indices([C|Cs],N) :-
723 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
724 ; get_store_type(C,var_assoc_store(_,_))) ->
725 constraint_index(C,N),
726 M is N + 1,
727 set_constraint_indices(Cs,M)
728 ;
729 set_constraint_indices(Cs,N)
730 ).
732 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
733 % Identifier Indexes
735 :- chr_constraint identifier_size/1.
736 :- chr_option(mode,identifier_size(+)).
737 :- chr_option(type_declaration,identifier_size(natural)).
739 identifier_size(_) \ identifier_size(_)
740 <=>
741 true.
743 :- chr_constraint get_identifier_size/1.
744 :- chr_option(mode,get_identifier_size(-)).
745 :- chr_option(type_declaration,get_identifier_size(natural)).
747 identifier_size(Size) \ get_identifier_size(Q)
748 <=>
749 Q = Size.
751 get_identifier_size(Q)
752 <=>
753 Q = 1.
755 :- chr_constraint identifier_index/3.
756 :- chr_option(mode,identifier_index(+,+,+)).
757 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
759 identifier_index(C,I,_) \ identifier_index(C,I,_)
760 <=>
761 true.
763 :- chr_constraint get_identifier_index/3.
764 :- chr_option(mode,get_identifier_index(+,+,-)).
765 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
767 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
768 <=>
769 Q = II.
770 identifier_size(Size), get_identifier_index(C,I,Q)
771 <=>
772 NSize is Size + 1,
773 identifier_index(C,I,NSize),
774 identifier_size(NSize),
775 Q = NSize.
776 get_identifier_index(C,I,Q)
777 <=>
778 identifier_index(C,I,2),
779 identifier_size(2),
780 Q = 2.
782 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
783 % Type Indexed Identifier Indexes
785 :- chr_constraint type_indexed_identifier_size/2.
786 :- chr_option(mode,type_indexed_identifier_size(+,+)).
787 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
789 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
790 <=>
791 true.
793 :- chr_constraint get_type_indexed_identifier_size/2.
794 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
795 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
797 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
798 <=>
799 Q = Size.
801 get_type_indexed_identifier_size(IndexType,Q)
802 <=>
803 Q = 1.
805 :- chr_constraint type_indexed_identifier_index/4.
806 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
807 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
809 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
810 <=>
811 true.
813 :- chr_constraint get_type_indexed_identifier_index/4.
814 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
815 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
817 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
818 <=>
819 Q = II.
820 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
821 <=>
822 NSize is Size + 1,
823 type_indexed_identifier_index(IndexType,C,I,NSize),
824 type_indexed_identifier_size(IndexType,NSize),
825 Q = NSize.
826 get_type_indexed_identifier_index(IndexType,C,I,Q)
827 <=>
828 type_indexed_identifier_index(IndexType,C,I,2),
829 type_indexed_identifier_size(IndexType,2),
830 Q = 2.
832 type_indexed_identifier_structure(IndexType,Structure) :-
833 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
834 get_type_indexed_identifier_size(IndexType,Arity),
835 functor(Structure,Functor,Arity).
836 type_indexed_identifier_name(IndexType,Prefix,Name) :-
837 ( atom(IndexType) ->
838 IndexTypeName = IndexType
839 ;
840 term_to_atom(IndexType,IndexTypeName)
841 ),
842 atom_concat_list([Prefix,'_',IndexTypeName],Name).
844 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
849 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
850 %%
851 %% Translation
853 chr_translate(Declarations,NewDeclarations) :-
854 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
856 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
857 chr_banner,
858 restart_after_flattening(Declarations0,Declarations),
859 init_chr_pp_flags,
860 chr_source_file(File),
861 /* sort out the interesting stuff from the input */
862 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
863 chr_compiler_options:sanity_check,
865 dump_code(Declarations),
867 check_declared_constraints(Constraints0),
868 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
869 add_constraints(Constraints),
870 add_rules(Rules1),
871 generate_never_stored_rules(Constraints,NewRules),
872 add_rules(NewRules),
873 append(Rules1,NewRules,Rules),
874 chr_analysis(Rules,Constraints,Declarations),
875 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
876 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
877 phase_end(validate_store_type_assumptions),
878 used_states_known,
879 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
880 insert_declarations(OtherClauses, Clauses0),
881 chr_module_declaration(CHRModuleDeclaration),
882 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
883 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
884 append([Clauses0,GeneratedClauses], NewDeclarations),
885 dump_code(NewDeclarations),
886 !. /* cut choicepoint of restart_after_flattening */
888 chr_analysis(Rules,Constraints,Declarations) :-
889 check_rules(Rules,Constraints),
890 time('type checking',chr_translate:static_type_check),
891 /* constants */
892 collect_constants(Rules,Constraints,Declarations),
893 add_occurrences(Rules),
894 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
895 time('set semantics',chr_translate:set_semantics_rules(Rules)),
896 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
897 time('guard simplification',chr_translate:guard_simplification),
898 time('late storage',chr_translate:storage_analysis(Constraints)),
899 time('observation',chr_translate:observation_analysis(Constraints)),
900 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
901 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
902 partial_wake_analysis,
903 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
904 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
905 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
906 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
908 store_management_preds(Constraints,Clauses) :-
909 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
910 generate_attr_unify_hook(AttrUnifyHookClauses),
911 generate_attach_increment(AttachIncrementClauses),
912 generate_extra_clauses(Constraints,ExtraClauses),
913 generate_insert_delete_constraints(Constraints,DeleteClauses),
914 generate_attach_code(Constraints,StoreClauses),
915 generate_counter_code(CounterClauses),
916 generate_dynamic_type_check_clauses(TypeCheckClauses),
917 append([AttachAConstraintClauses
918 ,AttachIncrementClauses
919 ,AttrUnifyHookClauses
920 ,ExtraClauses
921 ,DeleteClauses
922 ,StoreClauses
923 ,CounterClauses
924 ,TypeCheckClauses
925 ]
926 ,Clauses).
929 insert_declarations(Clauses0, Clauses) :-
930 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
931 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
933 auxiliary_module(chr_hashtable_store).
934 auxiliary_module(chr_integertable_store).
935 auxiliary_module(chr_assoc_store).
937 generate_counter_code(Clauses) :-
938 ( chr_pp_flag(store_counter,on) ->
939 Clauses = [
940 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
941 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
942 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
943 (:- '$counter_init'('$insert_counter')),
944 (:- '$counter_init'('$delete_counter')),
945 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
946 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
947 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
948 ]
949 ;
950 Clauses = []
951 ).
953 % for systems with multifile declaration
954 chr_module_declaration(CHRModuleDeclaration) :-
955 get_target_module(Mod),
956 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
957 CHRModuleDeclaration = [
958 (:- multifile chr:'$chr_module'/1),
959 chr:'$chr_module'(Mod)
960 ]
961 ;
962 CHRModuleDeclaration = []
963 ).
966 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
967 %%
968 %% Partitioning of clauses into constraint declarations, chr rules and other
969 %% clauses
971 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
972 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
973 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
974 partition_clauses([],[],[],[]).
975 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
976 ( parse_rule(Clause,Rule) ->
977 ConstraintDeclarations = RestConstraintDeclarations,
978 Rules = [Rule|RestRules],
979 OtherClauses = RestOtherClauses
980 ; is_declaration(Clause,ConstraintDeclaration) ->
981 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
982 Rules = RestRules,
983 OtherClauses = RestOtherClauses
984 ; is_module_declaration(Clause,Mod) ->
985 target_module(Mod),
986 ConstraintDeclarations = RestConstraintDeclarations,
987 Rules = RestRules,
988 OtherClauses = [Clause|RestOtherClauses]
989 ; is_type_definition(Clause) ->
990 ConstraintDeclarations = RestConstraintDeclarations,
991 Rules = RestRules,
992 OtherClauses = RestOtherClauses
993 ; Clause = (handler _) ->
994 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
995 ConstraintDeclarations = RestConstraintDeclarations,
996 Rules = RestRules,
997 OtherClauses = RestOtherClauses
998 ; Clause = (rules _) ->
999 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1000 ConstraintDeclarations = RestConstraintDeclarations,
1001 Rules = RestRules,
1002 OtherClauses = RestOtherClauses
1003 ; Clause = option(OptionName,OptionValue) ->
1004 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1005 handle_option(OptionName,OptionValue),
1006 ConstraintDeclarations = RestConstraintDeclarations,
1007 Rules = RestRules,
1008 OtherClauses = RestOtherClauses
1009 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1010 handle_option(OptionName,OptionValue),
1011 ConstraintDeclarations = RestConstraintDeclarations,
1012 Rules = RestRules,
1013 OtherClauses = RestOtherClauses
1014 ; Clause = ('$chr_compiled_with_version'(_)) ->
1015 ConstraintDeclarations = RestConstraintDeclarations,
1016 Rules = RestRules,
1017 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1018 ; ConstraintDeclarations = RestConstraintDeclarations,
1019 Rules = RestRules,
1020 OtherClauses = [Clause|RestOtherClauses]
1021 ),
1022 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1024 '$chr_compiled_with_version'(2).
1026 is_declaration(D, Constraints) :- %% constraint declaration
1027 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1028 conj2list(Cs,Constraints0)
1029 ;
1030 ( D = (:- Decl) ->
1031 Decl =.. [constraints,Cs]
1032 ;
1033 D =.. [constraints,Cs]
1034 ),
1035 conj2list(Cs,Constraints0),
1036 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1037 ),
1038 extract_type_mode(Constraints0,Constraints).
1040 extract_type_mode([],[]).
1041 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1042 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1043 ( C0 = C # Annotation ->
1044 functor(C,F,A),
1045 extract_annotation(Annotation,F/A)
1046 ;
1047 C0 = C,
1048 functor(C,F,A)
1049 ),
1050 ConstraintSymbol = F/A,
1051 C =.. [_|Args],
1052 extract_types_and_modes(Args,ArgTypes,ArgModes),
1053 assert_constraint_type(ConstraintSymbol,ArgTypes),
1054 constraint_mode(ConstraintSymbol,ArgModes),
1055 extract_type_mode(R,R2).
1057 extract_annotation(stored,Symbol) :-
1058 stored_assertion(Symbol).
1059 extract_annotation(default(Goal),Symbol) :-
1060 never_stored_default(Symbol,Goal).
1062 extract_types_and_modes([],[],[]).
1063 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1064 extract_type_and_mode(X,T,M),
1065 extract_types_and_modes(R,R2,R3).
1067 extract_type_and_mode(+(T),T,(+)) :- !.
1068 extract_type_and_mode(?(T),T,(?)) :- !.
1069 extract_type_and_mode(-(T),T,(-)) :- !.
1070 extract_type_and_mode((+),any,(+)) :- !.
1071 extract_type_and_mode((?),any,(?)) :- !.
1072 extract_type_and_mode((-),any,(-)) :- !.
1073 extract_type_and_mode(Illegal,_,_) :-
1074 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1076 is_type_definition(Declaration) :-
1077 is_type_definition(Declaration,Result),
1078 assert_type_definition(Result).
1080 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1081 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1083 is_type_definition(Declaration,Result) :-
1084 ( Declaration = (:- TDef) ->
1085 true
1086 ;
1087 Declaration = TDef
1088 ),
1089 TDef =.. [chr_type,TypeDef],
1090 ( TypeDef = (Name ---> Def) ->
1091 tdisj2list(Def,DefList),
1092 Result = typedef(Name,DefList)
1093 ; TypeDef = (Alias == Name) ->
1094 Result = alias(Alias,Name)
1095 ;
1096 Result = typedef(TypeDef,[]),
1097 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1098 ).
1100 %% tdisj2list(+Goal,-ListOfGoals) is det.
1101 %
1102 % no removal of fails, e.g. :- type bool ---> true ; fail.
1103 tdisj2list(Conj,L) :-
1104 tdisj2list(Conj,L,[]).
1106 tdisj2list(Conj,L,T) :-
1107 Conj = (G1;G2), !,
1108 tdisj2list(G1,L,T1),
1109 tdisj2list(G2,T1,T).
1110 tdisj2list(G,[G | T],T).
1113 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1114 %% parse_rule(+term,-pragma_rule) is semidet.
1115 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1116 parse_rule(RI,R) :- %% name @ rule
1117 RI = (Name @ RI2), !,
1118 rule(RI2,yes(Name),R).
1119 parse_rule(RI,R) :-
1120 rule(RI,no,R).
1122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1123 %% parse_rule(+term,-pragma_rule) is semidet.
1124 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1125 rule(RI,Name,R) :-
1126 RI = (RI2 pragma P), !, %% pragmas
1127 ( var(P) ->
1128 Ps = [_] % intercept variable
1129 ;
1130 conj2list(P,Ps)
1131 ),
1132 inc_rule_count(RuleCount),
1133 R = pragma(R1,IDs,Ps,Name,RuleCount),
1134 is_rule(RI2,R1,IDs,R).
1135 rule(RI,Name,R) :-
1136 inc_rule_count(RuleCount),
1137 R = pragma(R1,IDs,[],Name,RuleCount),
1138 is_rule(RI,R1,IDs,R).
1140 is_rule(RI,R,IDs,RC) :- %% propagation rule
1141 RI = (H ==> B), !,
1142 conj2list(H,Head2i),
1143 get_ids(Head2i,IDs2,Head2,RC),
1144 IDs = ids([],IDs2),
1145 ( B = (G | RB) ->
1146 R = rule([],Head2,G,RB)
1147 ;
1148 R = rule([],Head2,true,B)
1149 ).
1150 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1151 RI = (H <=> B), !,
1152 ( B = (G | RB) ->
1153 Guard = G,
1154 Body = RB
1155 ; Guard = true,
1156 Body = B
1157 ),
1158 ( H = (H1 \ H2) ->
1159 conj2list(H1,Head2i),
1160 conj2list(H2,Head1i),
1161 get_ids(Head2i,IDs2,Head2,0,N,RC),
1162 get_ids(Head1i,IDs1,Head1,N,_,RC),
1163 IDs = ids(IDs1,IDs2)
1164 ; conj2list(H,Head1i),
1165 Head2 = [],
1166 get_ids(Head1i,IDs1,Head1,RC),
1167 IDs = ids(IDs1,[])
1168 ),
1169 R = rule(Head1,Head2,Guard,Body).
1171 get_ids(Cs,IDs,NCs,RC) :-
1172 get_ids(Cs,IDs,NCs,0,_,RC).
1174 get_ids([],[],[],N,N,_).
1175 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1176 ( C = (NC # N1) ->
1177 ( var(N1) ->
1178 N1 = N
1179 ;
1180 check_direct_pragma(N1,N,RC)
1181 )
1182 ;
1183 NC = C
1184 ),
1185 M is N + 1,
1186 get_ids(Cs,IDs,NCs, M,NN,RC).
1188 check_direct_pragma(passive,Id,PragmaRule) :- !,
1189 PragmaRule = pragma(_,_,_,_,RuleNb),
1190 passive(RuleNb,Id).
1191 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1192 ( direct_pragma(FullPragma),
1193 atom_concat(Abbrev,Remainder,FullPragma) ->
1194 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1195 ;
1196 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1197 ).
1199 direct_pragma(passive).
1201 is_module_declaration((:- module(Mod)),Mod).
1202 is_module_declaration((:- module(Mod,_)),Mod).
1204 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1206 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1207 % Add constraints
1208 add_constraints([]).
1209 add_constraints([C|Cs]) :-
1210 max_occurrence(C,0),
1211 C = _/A,
1212 length(Mode,A),
1213 set_elems(Mode,?),
1214 constraint_mode(C,Mode),
1215 add_constraints(Cs).
1217 % Add rules
1218 add_rules([]).
1219 add_rules([Rule|Rules]) :-
1220 Rule = pragma(_,_,_,_,RuleNb),
1221 rule(RuleNb,Rule),
1222 add_rules(Rules).
1224 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1226 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1227 %% Some input verification:
1229 check_declared_constraints(Constraints) :-
1230 tree_set_empty(Acc),
1231 check_declared_constraints(Constraints,Acc).
1233 check_declared_constraints([],_).
1234 check_declared_constraints([C|Cs],Acc) :-
1235 ( tree_set_memberchk(C,Acc) ->
1236 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1237 ;
1238 true
1239 ),
1240 tree_set_add(Acc,C,NAcc),
1241 check_declared_constraints(Cs,NAcc).
1243 %% - all constraints in heads are declared constraints
1244 %% - all passive pragmas refer to actual head constraints
1246 check_rules([],_).
1247 check_rules([PragmaRule|Rest],Decls) :-
1248 check_rule(PragmaRule,Decls),
1249 check_rules(Rest,Decls).
1251 check_rule(PragmaRule,Decls) :-
1252 check_rule_indexing(PragmaRule),
1253 check_trivial_propagation_rule(PragmaRule),
1254 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1255 Rule = rule(H1,H2,_,_),
1256 append(H1,H2,HeadConstraints),
1257 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1258 check_pragmas(Pragmas,PragmaRule).
1260 % Make all heads passive in trivial propagation rule
1261 % ... ==> ... | true.
1262 check_trivial_propagation_rule(PragmaRule) :-
1263 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1264 ( Rule = rule([],_,_,true) ->
1265 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1266 set_all_passive(RuleNb)
1267 ;
1268 true
1269 ).
1271 check_head_constraints([],_,_).
1272 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1273 functor(Constr,F,A),
1274 ( memberchk(F/A,Decls) ->
1275 check_head_constraints(Rest,Decls,PragmaRule)
1276 ;
1277 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1278 ).
1280 check_pragmas([],_).
1281 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1282 check_pragma(Pragma,PragmaRule),
1283 check_pragmas(Pragmas,PragmaRule).
1285 check_pragma(Pragma,PragmaRule) :-
1286 var(Pragma), !,
1287 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1288 check_pragma(passive(ID), PragmaRule) :-
1289 !,
1290 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1291 ( memberchk_eq(ID,IDs1) ->
1292 true
1293 ; memberchk_eq(ID,IDs2) ->
1294 true
1295 ;
1296 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1297 ),
1298 passive(RuleNb,ID).
1300 check_pragma(mpassive(IDs), PragmaRule) :-
1301 !,
1302 PragmaRule = pragma(_,_,_,_,RuleNb),
1303 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1304 maplist(passive(RuleNb),IDs).
1306 check_pragma(Pragma, PragmaRule) :-
1307 Pragma = already_in_heads,
1308 !,
1309 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1311 check_pragma(Pragma, PragmaRule) :-
1312 Pragma = already_in_head(_),
1313 !,
1314 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1316 check_pragma(Pragma, PragmaRule) :-
1317 Pragma = no_history,
1318 !,
1319 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1320 PragmaRule = pragma(_,_,_,_,N),
1321 no_history(N).
1323 check_pragma(Pragma, PragmaRule) :-
1324 Pragma = history(HistoryName,IDs),
1325 !,
1326 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1327 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1328 ( IDs1 \== [] ->
1329 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1330 ; \+ atom(HistoryName) ->
1331 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1332 ; \+ is_set(IDs) ->
1333 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1334 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1335 history(RuleNb,HistoryName,IDs)
1336 ;
1337 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1338 ).
1339 check_pragma(Pragma,PragmaRule) :-
1340 Pragma = line_number(LineNumber),
1341 !,
1342 PragmaRule = pragma(_,_,_,_,RuleNb),
1343 line_number(RuleNb,LineNumber).
1345 check_history_pragma_ids([], _, _).
1346 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1347 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1348 check_history_pragma_ids(IDs,IDs1,IDs2).
1350 check_pragma(Pragma,PragmaRule) :-
1351 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1353 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1354 %% no_history(+RuleNb) is det.
1355 :- chr_constraint no_history/1.
1356 :- chr_option(mode,no_history(+)).
1357 :- chr_option(type_declaration,no_history(int)).
1359 %% has_no_history(+RuleNb) is semidet.
1360 :- chr_constraint has_no_history/1.
1361 :- chr_option(mode,has_no_history(+)).
1362 :- chr_option(type_declaration,has_no_history(int)).
1364 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1365 has_no_history(_) <=> fail.
1367 :- chr_constraint history/3.
1368 :- chr_option(mode,history(+,+,+)).
1369 :- chr_option(type_declaration,history(any,any,list)).
1371 :- chr_constraint named_history/3.
1373 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1374 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1376 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1377 length(IDs1,L1), length(IDs2,L2),
1378 ( L1 \== L2 ->
1379 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1380 ;
1381 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1382 ).
1384 test_named_history_id_pairs(_, [], _, []).
1385 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1386 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1387 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1389 :- chr_constraint test_named_history_id_pair/4.
1390 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1392 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1393 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1394 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1395 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1397 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1398 named_history(_,_,_) <=> fail.
1400 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1403 format_rule(PragmaRule) :-
1404 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1405 ( MaybeName = yes(Name) ->
1406 write('rule '), write(Name)
1407 ;
1408 write('rule number '), write(RuleNumber)
1409 ),
1410 get_line_number(RuleNumber,LineNumber),
1411 write(' (line '),
1412 write(LineNumber),
1413 write(')').
1415 check_rule_indexing(PragmaRule) :-
1416 PragmaRule = pragma(Rule,_,_,_,_),
1417 Rule = rule(H1,H2,G,_),
1418 term_variables(H1-H2,HeadVars),
1419 remove_anti_monotonic_guards(G,HeadVars,NG),
1420 check_indexing(H1,NG-H2),
1421 check_indexing(H2,NG-H1),
1422 % EXPERIMENT
1423 ( chr_pp_flag(term_indexing,on) ->
1424 term_variables(NG,GuardVariables),
1425 append(H1,H2,Heads),
1426 check_specs_indexing(Heads,GuardVariables,Specs)
1427 ;
1428 true
1429 ).
1431 :- chr_constraint indexing_spec/2.
1432 :- chr_option(mode,indexing_spec(+,+)).
1434 :- chr_constraint get_indexing_spec/2.
1435 :- chr_option(mode,get_indexing_spec(+,-)).
1438 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1439 get_indexing_spec(_,Spec) <=> Spec = [].
1441 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1442 <=>
1443 append(Specs1,Specs2,Specs),
1444 indexing_spec(FA,Specs).
1446 remove_anti_monotonic_guards(G,Vars,NG) :-
1447 conj2list(G,GL),
1448 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1449 list2conj(NGL,NG).
1451 remove_anti_monotonic_guard_list([],_,[]).
1452 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1453 ( G = var(X), memberchk_eq(X,Vars) ->
1454 NGs = RGs
1455 % TODO: this is not correct
1456 % ; G = functor(Term,Functor,Arity), % isotonic
1457 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1458 % NGs = RGs
1459 ;
1460 NGs = [G|RGs]
1461 ),
1462 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1464 check_indexing([],_).
1465 check_indexing([Head|Heads],Other) :-
1466 functor(Head,F,A),
1467 Head =.. [_|Args],
1468 term_variables(Heads-Other,OtherVars),
1469 check_indexing(Args,1,F/A,OtherVars),
1470 check_indexing(Heads,[Head|Other]).
1472 check_indexing([],_,_,_).
1473 check_indexing([Arg|Args],I,FA,OtherVars) :-
1474 ( is_indexed_argument(FA,I) ->
1475 true
1476 ; nonvar(Arg) ->
1477 indexed_argument(FA,I)
1478 ; % var(Arg) ->
1479 term_variables(Args,ArgsVars),
1480 append(ArgsVars,OtherVars,RestVars),
1481 ( memberchk_eq(Arg,RestVars) ->
1482 indexed_argument(FA,I)
1483 ;
1484 true
1485 )
1486 ),
1487 J is I + 1,
1488 term_variables(Arg,NVars),
1489 append(NVars,OtherVars,NOtherVars),
1490 check_indexing(Args,J,FA,NOtherVars).
1492 check_specs_indexing([],_,[]).
1493 check_specs_indexing([Head|Heads],Variables,Specs) :-
1494 Specs = [Spec|RSpecs],
1495 term_variables(Heads,OtherVariables,Variables),
1496 check_spec_indexing(Head,OtherVariables,Spec),
1497 term_variables(Head,NVariables,Variables),
1498 check_specs_indexing(Heads,NVariables,RSpecs).
1500 check_spec_indexing(Head,OtherVariables,Spec) :-
1501 functor(Head,F,A),
1502 Spec = spec(F,A,ArgSpecs),
1503 Head =.. [_|Args],
1504 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1505 indexing_spec(F/A,[ArgSpecs]).
1507 check_args_spec_indexing([],_,_,[]).
1508 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1509 term_variables(Args,Variables,OtherVariables),
1510 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1511 ArgSpecs = [ArgSpec|RArgSpecs]
1512 ;
1513 ArgSpecs = RArgSpecs
1514 ),
1515 J is I + 1,
1516 term_variables(Arg,NOtherVariables,OtherVariables),
1517 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1519 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1520 ( var(Arg) ->
1521 memberchk_eq(Arg,Variables),
1522 ArgSpec = specinfo(I,any,[])
1523 ;
1524 functor(Arg,F,A),
1525 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1526 Arg =.. [_|Args],
1527 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1528 ).
1530 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1532 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1533 % Occurrences
1535 add_occurrences([]).
1536 add_occurrences([Rule|Rules]) :-
1537 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1538 add_occurrences(H1,IDs1,simplification,Nb),
1539 add_occurrences(H2,IDs2,propagation,Nb),
1540 add_occurrences(Rules).
1542 add_occurrences([],[],_,_).
1543 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1544 functor(H,F,A),
1545 FA = F/A,
1546 new_occurrence(FA,RuleNb,ID,Type),
1547 add_occurrences(Hs,IDs,Type,RuleNb).
1549 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1551 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1552 % Observation Analysis
1553 %
1554 % CLASSIFICATION
1555 %
1556 %
1557 %
1558 %
1559 %
1560 %
1562 :- chr_constraint observation_analysis/1.
1563 :- chr_option(mode, observation_analysis(+)).
1565 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1566 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1567 ( chr_pp_flag(store_in_guards, on) ->
1568 observation_analysis(RuleNb, Guard, guard, Cs)
1569 ;
1570 true
1571 ),
1572 observation_analysis(RuleNb, Body, body, Cs)
1574 pragma passive(Id).
1575 observation_analysis(_) <=> true.
1577 observation_analysis(RuleNb, Term, GB, Cs) :-
1578 ( all_spawned(RuleNb,GB) ->
1579 true
1580 ; var(Term) ->
1581 spawns_all(RuleNb,GB)
1582 ; Term = true ->
1583 true
1584 ; Term = fail ->
1585 true
1586 ; Term = '!' ->
1587 true
1588 ; Term = (T1,T2) ->
1589 observation_analysis(RuleNb,T1,GB,Cs),
1590 observation_analysis(RuleNb,T2,GB,Cs)
1591 ; Term = (T1;T2) ->
1592 observation_analysis(RuleNb,T1,GB,Cs),
1593 observation_analysis(RuleNb,T2,GB,Cs)
1594 ; Term = (T1->T2) ->
1595 observation_analysis(RuleNb,T1,GB,Cs),
1596 observation_analysis(RuleNb,T2,GB,Cs)
1597 ; Term = (\+ T) ->
1598 observation_analysis(RuleNb,T,GB,Cs)
1599 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1600 spawns(RuleNb,GB,F/A)
1601 ; Term = (_ = _) ->
1602 spawns_all_triggers(RuleNb,GB)
1603 ; Term = (_ is _) ->
1604 spawns_all_triggers(RuleNb,GB)
1605 ; builtin_binds_b(Term,Vars) ->
1606 ( Vars == [] ->
1607 true
1608 ;
1609 spawns_all_triggers(RuleNb,GB)
1610 )
1611 ;
1612 spawns_all(RuleNb,GB)
1613 ).
1615 :- chr_constraint spawns/3.
1616 :- chr_option(mode, spawns(+,+,+)).
1617 :- chr_type spawns_type ---> guard ; body.
1618 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1620 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1621 :- chr_option(mode, spawns_all(+,+)).
1622 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1623 :- chr_option(mode, spawns_all_triggers(+,+)).
1624 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1626 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1627 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1628 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1629 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1630 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1631 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1633 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1634 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1635 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1636 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1638 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1639 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1641 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1642 \
1643 spawns(RuleNb1,GB,C1)
1644 <=>
1645 \+ is_passive(RuleNb2,O)
1646 |
1647 spawns_all(RuleNb1,GB)
1648 pragma
1649 passive(Id).
1651 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1652 ==>
1653 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1654 \+ is_passive(RuleNb2,O), may_trigger(C1)
1655 |
1656 spawns_all_triggers_implies_spawns_all
1657 pragma
1658 passive(Id).
1660 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1661 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1662 spawns_all_triggers_implies_spawns_all \
1663 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1665 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1666 \
1667 spawns(RuleNb1,GB,C1)
1668 <=>
1669 may_trigger(C1),
1670 \+ is_passive(RuleNb2,O)
1671 |
1672 spawns_all_triggers(RuleNb1,GB)
1673 pragma
1674 passive(Id).
1676 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1677 spawns(RuleNb1,GB,C1)
1678 ==>
1679 \+ may_trigger(C1),
1680 \+ is_passive(RuleNb2,O)
1681 |
1682 spawns_all_triggers(RuleNb1,GB)
1683 pragma
1684 passive(Id).
1686 % a bit dangerous this rule: could start propagating too much too soon?
1687 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1688 spawns(RuleNb1,GB,C1)
1689 ==>
1690 RuleNb1 \== RuleNb2, C1 \== C2,
1691 \+ is_passive(RuleNb2,O)
1692 |
1693 spawns(RuleNb1,GB,C2)
1694 pragma
1695 passive(Id).
1697 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1698 spawns_all_triggers(RuleNb1,GB)
1699 ==>
1700 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1701 |
1702 spawns(RuleNb1,GB,C2)
1703 pragma
1704 passive(Id).
1707 :- chr_constraint all_spawned/2.
1708 :- chr_option(mode, all_spawned(+,+)).
1709 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1710 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1711 all_spawned(RuleNb,GB) <=> fail.
1714 % Overview of the supported queries:
1715 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1716 % only succeeds if the occurrence is observed by the
1717 % guard resp. body (depending on the last argument) of its rule
1718 % is_observed(+functor/artiy, +occurrence_number, -)
1719 % succeeds if the occurrence is observed by either the guard or
1720 % the body of its rule
1721 % NOTE: the last argument is NOT bound by this query
1722 %
1723 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1724 % succeeds if the given constraint is observed by the given
1725 % guard resp. body
1726 % do_is_observed(+functor/artiy,+rule_number)
1727 % succeeds if the given constraint is observed by the given
1728 % rule (either its guard or its body)
1731 is_observed(C,O) :-
1732 is_observed(C,O,_),
1733 ai_is_observed(C,O).
1735 is_stored_in_guard(C,RuleNb) :-
1736 chr_pp_flag(store_in_guards, on),
1737 do_is_observed(C,RuleNb,guard).
1739 :- chr_constraint is_observed/3.
1740 :- chr_option(mode, is_observed(+,+,+)).
1741 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1742 is_observed(_,_,_) <=> fail. % this will not happen in practice
1745 :- chr_constraint do_is_observed/3.
1746 :- chr_option(mode, do_is_observed(+,+,+)).
1747 :- chr_constraint do_is_observed/2.
1748 :- chr_option(mode, do_is_observed(+,+)).
1750 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1752 % (1) spawns_all
1753 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1754 % and some non-passive occurrence of some (possibly other) constraint
1755 % exists in a rule (could be same rule) with at least one occurrence of C
1757 spawns_all(RuleNb,GB),
1758 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1759 \
1760 do_is_observed(C,RuleNb,GB)
1761 <=>
1762 \+ is_passive(RuleNb2,O)
1763 |
1764 true.
1766 spawns_all(RuleNb,_),
1767 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1768 \
1769 do_is_observed(C,RuleNb)
1770 <=>
1771 \+ is_passive(RuleNb2,O)
1772 |
1773 true.
1775 % (2) spawns
1776 % a constraint C is observed if the GB of the rule it occurs in spawns a
1777 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1778 % as an occurrence of C
1780 spawns(RuleNb,GB,C2),
1781 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1782 \
1783 do_is_observed(C,RuleNb,GB)
1784 <=>
1785 \+ is_passive(RuleNb2,O)
1786 |
1787 true.
1789 spawns(RuleNb,_,C2),
1790 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1791 \
1792 do_is_observed(C,RuleNb)
1793 <=>
1794 \+ is_passive(RuleNb2,O)
1795 |
1796 true.
1798 % (3) spawns_all_triggers
1799 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1800 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1801 % exists in a rule (could be same rule) with at least one occurrence of C
1803 spawns_all_triggers(RuleNb,GB),
1804 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1805 \
1806 do_is_observed(C,RuleNb,GB)
1807 <=>
1808 \+ is_passive(RuleNb2,O), may_trigger(C2)
1809 |
1810 true.
1812 spawns_all_triggers(RuleNb,_),
1813 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1814 \
1815 do_is_observed(C,RuleNb)
1816 <=>
1817 \+ is_passive(RuleNb2,O), may_trigger(C2)
1818 |
1819 true.
1821 % (4) conservativeness
1822 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1823 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1826 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1828 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1830 %%
1831 %% Generated predicates
1832 %% attach_$CONSTRAINT
1833 %% attach_increment
1834 %% detach_$CONSTRAINT
1835 %% attr_unify_hook
1837 %% attach_$CONSTRAINT
1838 generate_attach_detach_a_constraint_all([],[]).
1839 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1840 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1841 generate_attach_a_constraint(Constraint,Clauses1),
1842 generate_detach_a_constraint(Constraint,Clauses2)
1843 ;
1844 Clauses1 = [],
1845 Clauses2 = []
1846 ),
1847 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1848 append([Clauses1,Clauses2,Clauses3],Clauses).
1850 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1851 generate_attach_a_constraint_nil(Constraint,Clause1),
1852 generate_attach_a_constraint_cons(Constraint,Clause2).
1854 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1855 make_name('attach_',FA,Name),
1856 Atom =.. [Name,Vars,Susp].
1858 generate_attach_a_constraint_nil(FA,Clause) :-
1859 Clause = (Head :- true),
1860 attach_constraint_atom(FA,[],_,Head).
1862 generate_attach_a_constraint_cons(FA,Clause) :-
1863 Clause = (Head :- Body),
1864 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1865 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1866 Body = ( AttachBody, Subscribe, RecursiveCall ),
1867 get_max_constraint_index(N),
1868 ( N == 1 ->
1869 generate_attach_body_1(FA,Var,Susp,AttachBody)
1870 ;
1871 generate_attach_body_n(FA,Var,Susp,AttachBody)
1872 ),
1873 % SWI-Prolog specific code
1874 chr_pp_flag(solver_events,NMod),
1875 ( NMod \== none ->
1876 Args = [[Var|_],Susp],
1877 get_target_module(Mod),
1878 use_auxiliary_predicate(run_suspensions),
1879 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1880 ;
1881 Subscribe = true
1882 ).
1884 generate_attach_body_1(FA,Var,Susp,Body) :-
1885 get_target_module(Mod),
1886 Body =
1887 ( get_attr(Var, Mod, Susps) ->
1888 put_attr(Var, Mod, [Susp|Susps])
1889 ;
1890 put_attr(Var, Mod, [Susp])
1891 ).
1893 generate_attach_body_n(F/A,Var,Susp,Body) :-
1894 get_constraint_index(F/A,Position),
1895 get_max_constraint_index(Total),
1896 get_target_module(Mod),
1897 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1898 singleton_attr(Total,Susp,Position,NewAttr3),
1899 Body =
1900 ( get_attr(Var,Mod,TAttr) ->
1901 AddGoal,
1902 put_attr(Var,Mod,NTAttr)
1903 ;
1904 put_attr(Var,Mod,NewAttr3)
1905 ), !.
1907 %% detach_$CONSTRAINT
1908 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1909 generate_detach_a_constraint_nil(Constraint,Clause1),
1910 generate_detach_a_constraint_cons(Constraint,Clause2).
1912 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1913 make_name('detach_',FA,Name),
1914 Atom =.. [Name,Vars,Susp].
1916 generate_detach_a_constraint_nil(FA,Clause) :-
1917 Clause = ( Head :- true),
1918 detach_constraint_atom(FA,[],_,Head).
1920 generate_detach_a_constraint_cons(FA,Clause) :-
1921 Clause = (Head :- Body),
1922 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1923 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1924 Body = ( DetachBody, RecursiveCall ),
1925 get_max_constraint_index(N),
1926 ( N == 1 ->
1927 generate_detach_body_1(FA,Var,Susp,DetachBody)
1928 ;
1929 generate_detach_body_n(FA,Var,Susp,DetachBody)
1930 ).
1932 generate_detach_body_1(FA,Var,Susp,Body) :-
1933 get_target_module(Mod),
1934 Body =
1935 ( get_attr(Var,Mod,Susps) ->
1936 'chr sbag_del_element'(Susps,Susp,NewSusps),
1937 ( NewSusps == [] ->
1938 del_attr(Var,Mod)
1939 ;
1940 put_attr(Var,Mod,NewSusps)
1941 )
1942 ;
1943 true
1944 ).
1946 generate_detach_body_n(F/A,Var,Susp,Body) :-
1947 get_constraint_index(F/A,Position),
1948 get_max_constraint_index(Total),
1949 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1950 get_target_module(Mod),
1951 Body =
1952 ( get_attr(Var,Mod,TAttr) ->
1953 RemGoal
1954 ;
1955 true
1956 ), !.
1958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1959 %-------------------------------------------------------------------------------
1960 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1961 :- chr_constraint generate_indexed_variables_body/4.
1962 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1963 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1964 %-------------------------------------------------------------------------------
1965 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1966 get_indexing_spec(F/A,Specs),
1967 ( chr_pp_flag(term_indexing,on) ->
1968 spectermvars(Specs,Args,F,A,Body,Vars)
1969 ;
1970 get_constraint_type_det(F/A,ArgTypes),
1971 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1972 ( MaybeBody == empty ->
1973 Body = true,
1974 Vars = []
1975 ; N == 0 ->
1976 ( Args = [Term] ->
1977 true
1978 ;
1979 Term =.. [term|Args]
1980 ),
1981 Body = term_variables(Term,Vars)
1982 ;
1983 MaybeBody = Body
1984 )
1985 ).
1986 generate_indexed_variables_body(FA,_,_,_) <=>
1987 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1988 %===============================================================================
1990 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1991 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1992 J is I + 1,
1993 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1994 ( Mode == (?),
1995 is_indexed_argument(FA,I) ->
1996 ( atomic_type(Type) ->
1997 Body =
1998 (
1999 ( var(V) ->
2000 Vars = [V|Tail]
2001 ;
2002 Vars = Tail
2003 ),
2004 Continuation
2005 ),
2006 ( RBody == empty ->
2007 Continuation = true, Tail = []
2008 ;
2009 Continuation = RBody
2010 )
2011 ;
2012 ( RBody == empty ->
2013 Body = term_variables(V,Vars)
2014 ;
2015 Body = (term_variables(V,Vars,Tail),RBody)
2016 )
2017 ),
2018 N = M
2019 ; Mode == (-), is_indexed_argument(FA,I) ->
2020 ( RBody == empty ->
2021 Body = (Vars = [V])
2022 ;
2023 Body = (Vars = [V|Tail],RBody)
2024 ),
2025 N is M + 1
2026 ;
2027 Vars = Tail,
2028 Body = RBody,
2029 N is M + 1
2030 ).
2031 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2032 % EXPERIMENTAL
2033 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2034 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2036 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2037 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2038 Goal = (ArgGoal,RGoal),
2039 argspecs(Specs,I,TempArgSpecs,RSpecs),
2040 merge_argspecs(TempArgSpecs,ArgSpecs),
2041 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2042 J is I + 1,
2043 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2045 argspecs([],_,[],[]).
2046 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2047 argspecs(Rest,I,ArgSpecs,RestSpecs).
2048 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2049 ( I == J ->
2050 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2051 ( Specs = [] ->
2052 RRestSpecs = RestSpecs
2053 ;
2054 RestSpecs = [Specs|RRestSpecs]
2055 )
2056 ;
2057 ArgSpecs = RArgSpecs,
2058 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2059 ),
2060 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2062 merge_argspecs(In,Out) :-
2063 sort(In,Sorted),
2064 merge_argspecs_(Sorted,Out).
2066 merge_argspecs_([],[]).
2067 merge_argspecs_([X],R) :- !, R = [X].
2068 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2069 ( (F1 == any ; F2 == any) ->
2070 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2071 ; F1 == F2 ->
2072 append(A1,A2,A),
2073 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2074 ;
2075 R = [specinfo(I,F1,A1)|RR],
2076 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2077 ).
2079 arggoal(List,Arg,Goal,L,T) :-
2080 ( List == [] ->
2081 L = T,
2082 Goal = true
2083 ; List = [specinfo(_,any,_)] ->
2084 Goal = term_variables(Arg,L,T)
2085 ;
2086 Goal =
2087 ( var(Arg) ->
2088 L = [Arg|T]
2089 ;
2090 Cases
2091 ),
2092 arggoal_cases(List,Arg,L,T,Cases)
2093 ).
2095 arggoal_cases([],_,L,T,L=T).
2096 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2097 ( ArgSpecs == [] ->
2098 Cases = RCases
2099 ; ArgSpecs == [[]] ->
2100 Cases = RCases
2101 ; FA = F/A ->
2102 Cases = (Case ; RCases),
2103 functor(Term,F,A),
2104 Term =.. [_|Args],
2105 Case = (Arg = Term -> ArgsGoal),
2106 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2107 ),
2108 arggoal_cases(Rest,Arg,L,T,RCases).
2109 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2111 generate_extra_clauses(Constraints,List) :-
2112 generate_activate_clauses(Constraints,List,Tail0),
2113 generate_remove_clauses(Constraints,Tail0,Tail1),
2114 generate_allocate_clauses(Constraints,Tail1,Tail2),
2115 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2116 generate_novel_production(Tail3,Tail4),
2117 generate_extend_history(Tail4,Tail5),
2118 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2119 generate_empty_named_history_initialisations(Tail6,Tail7),
2120 Tail7 = [].
2122 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2123 % remove_constraint_internal/[1/3]
2125 generate_remove_clauses([],List,List).
2126 generate_remove_clauses([C|Cs],List,Tail) :-
2127 generate_remove_clause(C,List,List1),
2128 generate_remove_clauses(Cs,List1,Tail).
2130 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2131 uses_state(Constraint,removed),
2132 ( chr_pp_flag(inline_insertremove,off) ->
2133 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2134 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2135 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2136 ;
2137 delay_phase_end(validate_store_type_assumptions,
2138 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2139 )
2140 ).
2142 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2143 make_name('$remove_constraint_internal_',Constraint,Name),
2144 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2145 Goal =.. [Name, Susp,Delete]
2146 ;
2147 Goal =.. [Name,Susp,Agenda,Delete]
2148 ).
2150 generate_remove_clause(Constraint,List,Tail) :-
2151 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2152 List = [RemoveClause|Tail],
2153 RemoveClause = (Head :- RemoveBody),
2154 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2155 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2156 ;
2157 List = Tail
2158 ).
2160 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2161 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2162 ( Role == active ->
2163 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2164 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2165 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2166 ; Role == partner ->
2167 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2168 GetStateValue = true,
2169 MaybeDelete = DeleteYes
2170 ),
2171 RemoveBody =
2172 (
2173 GetState,
2174 GetStateValue,
2175 UpdateState,
2176 MaybeDelete
2177 )
2178 ;
2179 static_suspension_term(Constraint,Susp2),
2180 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2181 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2182 ( chr_pp_flag(debugable,on) ->
2183 Constraint = Functor / _,
2184 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2185 ;
2186 true
2187 ),
2188 ( Role == active ->
2189 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2190 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2191 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2192 ; Role == partner ->
2193 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2194 GetStateValue = true,
2195 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2196 ),
2197 RemoveBody =
2198 (
2199 Susp = Susp2,
2200 GetStateValue,
2201 UpdateState,
2202 MaybeDelete
2203 )
2204 ).
2206 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2207 % activate_constraint/4
2209 generate_activate_clauses([],List,List).
2210 generate_activate_clauses([C|Cs],List,Tail) :-
2211 generate_activate_clause(C,List,List1),
2212 generate_activate_clauses(Cs,List1,Tail).
2214 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2215 ( chr_pp_flag(inline_insertremove,off) ->
2216 use_auxiliary_predicate(activate_constraint,Constraint),
2217 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2218 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2219 ;
2220 delay_phase_end(validate_store_type_assumptions,
2221 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2222 )
2223 ).
2225 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2226 make_name('$activate_constraint_',Constraint,Name),
2227 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2228 Goal =.. [Name,Store, Susp]
2229 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2230 Goal =.. [Name,Store, Susp, Generation]
2231 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2232 Goal =.. [Name,Store, Vars, Susp, Generation]
2233 ;
2234 Goal =.. [Name,Store, Vars, Susp]
2235 ).
2237 generate_activate_clause(Constraint,List,Tail) :-
2238 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2239 List = [Clause|Tail],
2240 Clause = (Head :- Body),
2241 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2242 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2243 ;
2244 List = Tail
2245 ).
2247 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2248 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2249 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2250 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2251 ;
2252 GenerationHandling = true
2253 ),
2254 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2255 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2256 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2257 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2258 ;
2259 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2260 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2261 ( chr_pp_flag(guard_locks,off) ->
2262 NoneLocked = true
2263 ;
2264 NoneLocked = 'chr none_locked'( Vars)
2265 ),
2266 if_used_state(Constraint,not_stored_yet,
2267 ( State == not_stored_yet ->
2268 ArgumentsGoal,
2269 IndexedVariablesBody,
2270 NoneLocked,
2271 StoreYes
2272 ;
2273 % Vars = [],
2274 StoreNo
2275 ),
2276 % (Vars = [],StoreNo),StoreVarsGoal)
2277 StoreNo,StoreVarsGoal)
2278 ),
2279 Body =
2280 (
2281 GetState,
2282 GetStateValue,
2283 UpdateState,
2284 GenerationHandling,
2285 StoreVarsGoal
2286 ).
2287 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2288 % allocate_constraint/4
2290 generate_allocate_clauses([],List,List).
2291 generate_allocate_clauses([C|Cs],List,Tail) :-
2292 generate_allocate_clause(C,List,List1),
2293 generate_allocate_clauses(Cs,List1,Tail).
2295 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2296 uses_state(Constraint,not_stored_yet),
2297 ( chr_pp_flag(inline_insertremove,off) ->
2298 use_auxiliary_predicate(allocate_constraint,Constraint),
2299 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2300 ;
2301 Goal = (Susp = Suspension, Goal0),
2302 delay_phase_end(validate_store_type_assumptions,
2303 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2304 )
2305 ).
2307 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2308 make_name('$allocate_constraint_',Constraint,Name),
2309 Goal =.. [Name,Susp|Args].
2311 generate_allocate_clause(Constraint,List,Tail) :-
2312 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2313 List = [Clause|Tail],
2314 Clause = (Head :- Body),
2315 Constraint = _/A,
2316 length(Args,A),
2317 allocate_constraint_atom(Constraint,Susp,Args,Head),
2318 allocate_constraint_body(Constraint,Susp,Args,Body)
2319 ;
2320 List = Tail
2321 ).
2323 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2324 static_suspension_term(Constraint,Suspension),
2325 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2326 ( chr_pp_flag(debugable,on) ->
2327 Constraint = Functor / _,
2328 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2329 ;
2330 true
2331 ),
2332 ( chr_pp_flag(debugable,on) ->
2333 ( may_trigger(Constraint) ->
2334 append(Args,[Susp],VarsSusp),
2335 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2336 get_target_module(Mod),
2337 Continuation = Mod : ContinuationGoal
2338 ;
2339 Continuation = true
2340 ),
2341 Init = (Susp = Suspension),
2342 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2343 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2344 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2345 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2346 Susp = Suspension, Init = true, CreateContinuation = true
2347 ;
2348 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2349 ),
2350 ( uses_history(Constraint) ->
2351 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2352 ;
2353 CreateHistory = true
2354 ),
2355 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2356 ( has_suspension_field(Constraint,id) ->
2357 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2358 gen_id(Id,GenID)
2359 ;
2360 GenID = true
2361 ),
2362 Body =
2363 (
2364 Init,
2365 CreateContinuation,
2366 CreateGeneration,
2367 CreateHistory,
2368 CreateState,
2369 GenID
2370 ).
2372 gen_id(Id,'chr gen_id'(Id)).
2373 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2374 % insert_constraint_internal
2376 generate_insert_constraint_internal_clauses([],List,List).
2377 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2378 generate_insert_constraint_internal_clause(C,List,List1),
2379 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2381 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2382 ( chr_pp_flag(inline_insertremove,off) ->
2383 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2384 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2385 ;
2386 delay_phase_end(validate_store_type_assumptions,
2387 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2388 )
2389 ).
2392 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2393 insert_constraint_internal_constraint_name(Constraint,Name),
2394 ( chr_pp_flag(debugable,on) ->
2395 Goal =.. [Name, Vars, Self, Closure | Args]
2396 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2397 Goal =.. [Name,Self | Args]
2398 ;
2399 Goal =.. [Name,Vars, Self | Args]
2400 ).
2402 insert_constraint_internal_constraint_name(Constraint,Name) :-
2403 make_name('$insert_constraint_internal_',Constraint,Name).
2405 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2406 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2407 List = [Clause|Tail],
2408 Clause = (Head :- Body),
2409 Constraint = _/A,
2410 length(Args,A),
2411 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2412 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2413 ;
2414 List = Tail
2415 ).
2418 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2419 static_suspension_term(Constraint,Suspension),
2420 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2421 ( chr_pp_flag(debugable,on) ->
2422 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2423 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2424 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2425 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2426 ;
2427 CreateGeneration = true
2428 ),
2429 ( chr_pp_flag(debugable,on) ->
2430 Constraint = Functor / _,
2431 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2432 ;
2433 true
2434 ),
2435 ( uses_history(Constraint) ->
2436 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2437 ;
2438 CreateHistory = true
2439 ),
2440 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2441 List = [Clause|Tail],
2442 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2443 suspension_term_base_fields(Constraint,BaseFields),
2444 ( has_suspension_field(Constraint,id) ->
2445 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2446 gen_id(Id,GenID)
2447 ;
2448 GenID = true
2449 ),
2450 Body =
2451 (
2452 Susp = Suspension,
2453 CreateState,
2454 CreateGeneration,
2455 CreateHistory,
2456 GenID
2457 )
2458 ;
2459 ( has_suspension_field(Constraint,id) ->
2460 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2461 gen_id(Id,GenID)
2462 ;
2463 GenID = true
2464 ),
2465 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2466 ( chr_pp_flag(guard_locks,off) ->
2467 NoneLocked = true
2468 ;
2469 NoneLocked = 'chr none_locked'( Vars)
2470 ),
2471 Body =
2472 (
2473 Susp = Suspension,
2474 IndexedVariablesBody,
2475 NoneLocked,
2476 CreateState,
2477 CreateGeneration,
2478 CreateHistory,
2479 GenID
2480 )
2481 ).
2483 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2484 % novel_production/2
2486 generate_novel_production(List,Tail) :-
2487 ( is_used_auxiliary_predicate(novel_production) ->
2488 List = [Clause|Tail],
2489 Clause =
2490 (
2491 '$novel_production'( Self, Tuple) :-
2492 % arg( 3, Self, Ref), % ARGXXX
2493 % 'chr get_mutable'( History, Ref),
2494 arg( 3, Self, History), % ARGXXX
2495 ( hprolog:get_ds( Tuple, History, _) ->
2496 fail
2497 ;
2498 true
2499 )
2500 )
2501 ;
2502 List = Tail
2503 ).
2505 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2506 % extend_history/2
2508 generate_extend_history(List,Tail) :-
2509 ( is_used_auxiliary_predicate(extend_history) ->
2510 List = [Clause|Tail],
2511 Clause =
2512 (
2513 '$extend_history'( Self, Tuple) :-
2514 % arg( 3, Self, Ref), % ARGXXX
2515 % 'chr get_mutable'( History, Ref),
2516 arg( 3, Self, History), % ARGXXX
2517 hprolog:put_ds( Tuple, History, x, NewHistory),
2518 setarg( 3, Self, NewHistory) % ARGXXX
2519 )
2520 ;
2521 List = Tail
2522 ).
2524 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2525 %
2526 :- chr_constraint
2527 empty_named_history_initialisations/2,
2528 generate_empty_named_history_initialisation/1,
2529 find_empty_named_histories/0.
2531 generate_empty_named_history_initialisations(List, Tail) :-
2532 empty_named_history_initialisations(List, Tail),
2533 find_empty_named_histories.
2535 find_empty_named_histories, history(_, Name, []) ==>
2536 generate_empty_named_history_initialisation(Name).
2538 generate_empty_named_history_initialisation(Name) \
2539 generate_empty_named_history_initialisation(Name) <=> true.
2540 generate_empty_named_history_initialisation(Name) \
2541 empty_named_history_initialisations(List, Tail) # Passive
2542 <=>
2543 empty_named_history_global_variable(Name, GlobalVariable),
2544 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2545 empty_named_history_initialisations(Rest, Tail)
2546 pragma passive(Passive).
2548 find_empty_named_histories \
2549 generate_empty_named_history_initialisation(_) # Passive <=> true
2550 pragma passive(Passive).
2552 find_empty_named_histories,
2553 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2554 pragma passive(Passive).
2556 find_empty_named_histories <=>
2557 chr_error(internal, 'find_empty_named_histories was not removed', []).
2560 empty_named_history_global_variable(Name, GlobalVariable) :-
2561 atom_concat('chr empty named history ', Name, GlobalVariable).
2563 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2564 empty_named_history_global_variable(Name, GlobalVariable).
2566 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2567 empty_named_history_global_variable(Name, GlobalVariable).
2570 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2571 % run_suspensions/2
2573 generate_run_suspensions_clauses([],List,List).
2574 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2575 generate_run_suspensions_clause(C,List,List1),
2576 generate_run_suspensions_clauses(Cs,List1,Tail).
2578 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2579 make_name('$run_suspensions_',Constraint,Name),
2580 Goal =.. [Name,Suspensions].
2582 generate_run_suspensions_clause(Constraint,List,Tail) :-
2583 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2584 List = [Clause1,Clause2|Tail],
2585 run_suspensions_goal(Constraint,[],Clause1),
2586 ( chr_pp_flag(debugable,on) ->
2587 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2588 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2589 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2590 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2591 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2592 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2593 Clause2 =
2594 (
2595 Clause2Head :-
2596 GetState,
2597 GetStateValue,
2598 ( State==active ->
2599 UpdateState,
2600 GetGeneration,
2601 GetGenerationValue,
2602 Generation is Gen+1,
2603 UpdateGeneration,
2604 GetContinuation,
2605 (
2606 'chr debug_event'(wake(Suspension)),
2607 call(Continuation)
2608 ;
2609 'chr debug_event'(fail(Suspension)), !,
2610 fail
2611 ),
2612 (
2613 'chr debug_event'(exit(Suspension))
2614 ;
2615 'chr debug_event'(redo(Suspension)),
2616 fail
2617 ),
2618 GetPost,
2619 GetPostValue,
2620 ( Post==triggered ->
2621 UpdatePost % catching constraints that did not do anything
2622 ;
2623 true
2624 )
2625 ;
2626 true
2627 ),
2628 Clause2Recursion
2629 )
2630 ;
2631 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2632 static_suspension_term(Constraint,SuspensionTerm),
2633 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2634 append(Arguments,[Suspension],VarsSusp),
2635 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2636 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2637 ( uses_field(Constraint,generation) ->
2638 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2639 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2640 ;
2641 GenerationHandling = true
2642 ),
2643 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2644 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2645 if_used_state(Constraint,removed,
2646 ( GetState,
2647 ( State==active
2648 -> ReactivateConstraint
2649 ; true)
2650 ),ReactivateConstraint,CondReactivate),
2651 ReactivateConstraint =
2652 (
2653 UpdateState,
2654 GenerationHandling,
2655 Continuation,
2656 GetPostState,
2657 ( Post==triggered ->
2658 UpdatePostState % catching constraints that did not do anything
2659 ;
2660 true
2661 )
2662 ),
2663 Clause2 =
2664 (
2665 Clause2Head :-
2666 Suspension = SuspensionTerm,
2667 CondReactivate,
2668 Clause2Recursion
2669 )
2670 )
2671 ;
2672 List = Tail
2673 ).
2675 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2678 generate_attach_increment(Clauses) :-
2679 get_max_constraint_index(N),
2680 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2681 Clauses = [Clause1,Clause2],
2682 generate_attach_increment_empty(Clause1),
2683 ( N == 1 ->
2684 generate_attach_increment_one(Clause2)
2685 ;
2686 generate_attach_increment_many(N,Clause2)
2687 )
2688 ;
2689 Clauses = []
2690 ).
2692 generate_attach_increment_empty((attach_increment([],_) :- true)).
2694 generate_attach_increment_one(Clause) :-
2695 Head = attach_increment([Var|Vars],Susps),
2696 get_target_module(Mod),
2697 ( chr_pp_flag(guard_locks,off) ->
2698 NotLocked = true
2699 ;
2700 NotLocked = 'chr not_locked'( Var)
2701 ),
2702 Body =
2703 (
2704 NotLocked,
2705 ( get_attr(Var,Mod,VarSusps) ->
2706 sort(VarSusps,SortedVarSusps),
2707 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2708 put_attr(Var,Mod,MergedSusps)
2709 ;
2710 put_attr(Var,Mod,Susps)
2711 ),
2712 attach_increment(Vars,Susps)
2713 ),
2714 Clause = (Head :- Body).
2716 generate_attach_increment_many(N,Clause) :-
2717 Head = attach_increment([Var|Vars],TAttr1),
2718 % writeln(merge_attributes_1_before),
2719 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2720 % writeln(merge_attributes_1_after),
2721 get_target_module(Mod),
2722 ( chr_pp_flag(guard_locks,off) ->
2723 NotLocked = true
2724 ;
2725 NotLocked = 'chr not_locked'( Var)
2726 ),
2727 Body =
2728 (
2729 NotLocked,
2730 ( get_attr(Var,Mod,TAttr2) ->
2731 MergeGoal,
2732 put_attr(Var,Mod,Attr)
2733 ;
2734 put_attr(Var,Mod,TAttr1)
2735 ),
2736 attach_increment(Vars,TAttr1)
2737 ),
2738 Clause = (Head :- Body).
2740 %% attr_unify_hook
2741 generate_attr_unify_hook(Clauses) :-
2742 get_max_constraint_index(N),
2743 ( N == 0 ->
2744 Clauses = []
2745 ;
2746 ( N == 1 ->
2747 generate_attr_unify_hook_one(Clauses)
2748 ;
2749 generate_attr_unify_hook_many(N,Clauses)
2750 )
2751 ).
2753 generate_attr_unify_hook_one([Clause]) :-
2754 Head = attr_unify_hook(Susps,Other),
2755 get_target_module(Mod),
2756 get_indexed_constraint(1,C),
2757 ( get_store_type(C,ST),
2758 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2759 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2760 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2761 ( atomic_types_suspended_constraint(C) ->
2762 SortGoal1 = true,
2763 SortedSusps = Susps,
2764 SortGoal2 = true,
2765 SortedOtherSusps = OtherSusps,
2766 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2767 NonvarBody = true
2768 ;
2769 SortGoal1 = sort(Susps, SortedSusps),
2770 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2771 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2772 use_auxiliary_predicate(attach_increment),
2773 NonvarBody =
2774 ( compound(Other) ->
2775 term_variables(Other,OtherVars),
2776 attach_increment(OtherVars, SortedSusps)
2777 ;
2778 true
2779 )
2780 ),
2781 Body =
2782 (
2783 SortGoal1,
2784 ( var(Other) ->
2785 ( get_attr(Other,Mod,OtherSusps) ->
2786 SortGoal2,
2787 MergeGoal,
2788 put_attr(Other,Mod,NewSusps),
2789 WakeNewSusps
2790 ;
2791 put_attr(Other,Mod,SortedSusps),
2792 WakeSusps
2793 )
2794 ;
2795 NonvarBody,
2796 WakeSusps
2797 )
2798 ),
2799 Clause = (Head :- Body)
2800 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2801 make_run_suspensions(List,List,WakeNewSusps),
2802 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2803 Body =
2804 ( get_attr(Other,Mod,OtherSusps) ->
2805 MergeGoal,
2806 WakeNewSusps
2807 ;
2808 put_attr(Other,Mod,Susps)
2809 ),
2810 Clause = (Head :- Body)
2811 ).
2814 generate_attr_unify_hook_many(N,[Clause]) :-
2815 chr_pp_flag(dynattr,off), !,
2816 Head = attr_unify_hook(Attr,Other),
2817 get_target_module(Mod),
2818 make_attr(N,Mask,SuspsList,Attr),
2819 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2820 list2conj(SortGoalList,SortGoals),
2821 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2822 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2823 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2824 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2825 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2826 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2827 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2828 NonvarBody = true
2829 ;
2830 use_auxiliary_predicate(attach_increment),
2831 NonvarBody =
2832 ( compound(Other) ->
2833 term_variables(Other,OtherVars),
2834 attach_increment(OtherVars,SortedAttr)
2835 ;
2836 true
2837 )
2838 ),
2839 Body =
2840 (
2841 SortGoals,
2842 ( var(Other) ->
2843 ( get_attr(Other,Mod,TOtherAttr) ->
2844 MergeGoal,
2845 put_attr(Other,Mod,MergedAttr),
2846 WakeMergedSusps
2847 ;
2848 put_attr(Other,Mod,SortedAttr),
2849 WakeSortedSusps
2850 )
2851 ;
2852 NonvarBody,
2853 WakeSortedSusps
2854 )
2855 ),
2856 Clause = (Head :- Body).
2858 % NEW
2859 generate_attr_unify_hook_many(N,Clauses) :-
2860 Head = attr_unify_hook(Attr,Other),
2861 get_target_module(Mod),
2862 normalize_attr(Attr,NormalGoal,NormalAttr),
2863 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2864 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2865 make_run_suspensions(N),
2866 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2867 NonvarBody = true
2868 ;
2869 use_auxiliary_predicate(attach_increment),
2870 NonvarBody =
2871 ( compound(Other) ->
2872 term_variables(Other,OtherVars),
2873 attach_increment(OtherVars,NormalAttr)
2874 ;
2875 true
2876 )
2877 ),
2878 Body =
2879 (
2880 NormalGoal,
2881 ( var(Other) ->
2882 ( get_attr(Other,Mod,OtherAttr) ->
2883 NormalOtherGoal,
2884 MergeGoal,
2885 put_attr(Other,Mod,MergedAttr),
2886 '$dispatch_run_suspensions'(MergedAttr)
2887 ;
2888 put_attr(Other,Mod,NormalAttr),
2889 '$dispatch_run_suspensions'(NormalAttr)
2890 )
2891 ;
2892 NonvarBody,
2893 '$dispatch_run_suspensions'(NormalAttr)
2894 )
2895 ),
2896 Clause = (Head :- Body),
2897 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2898 DispatchList1 = ('$dispatch_run_suspensions'([])),
2899 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2900 run_suspensions_dispatchers(N,[],Dispatchers).
2902 % NEW
2903 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2904 ( N > 0 ->
2905 get_indexed_constraint(N,C),
2906 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2907 ( may_trigger(C) ->
2908 run_suspensions_goal(C,List,Body)
2909 ;
2910 Body = true
2911 ),
2912 M is N - 1,
2913 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2914 ;
2915 Dispatchers = Acc
2916 ).
2918 % NEW
2919 make_run_suspensions(N) :-
2920 ( N > 0 ->
2921 ( get_indexed_constraint(N,C),
2922 may_trigger(C) ->
2923 use_auxiliary_predicate(run_suspensions,C)
2924 ;
2925 true
2926 ),
2927 M is N - 1,
2928 make_run_suspensions(M)
2929 ;
2930 true
2931 ).
2933 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2934 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2936 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2937 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2938 use_auxiliary_predicate(run_suspensions,C),
2939 ( wakes_partially(C) ->
2940 run_suspensions_goal(C,OneSusps,Goal)
2941 ;
2942 run_suspensions_goal(C,AllSusps,Goal)
2943 )
2944 ;
2945 Goal = true
2946 ).
2948 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2949 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2951 make_run_suspensions_loop([],[],_,true).
2952 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2953 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2954 J is I + 1,
2955 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2957 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2958 % $insert_in_store_F/A
2959 % $delete_from_store_F/A
2961 generate_insert_delete_constraints([],[]).
2962 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2963 ( is_stored(FA) ->
2964 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2965 ;
2966 Clauses = RestClauses
2967 ),
2968 generate_insert_delete_constraints(Rest,RestClauses).
2970 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2971 insert_constraint_clause(FA,Clauses,RestClauses1),
2972 delete_constraint_clause(FA,RestClauses1,RestClauses).
2974 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2975 % insert_in_store
2977 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2978 ( chr_pp_flag(inline_insertremove,off) ->
2979 use_auxiliary_predicate(insert_in_store,FA),
2980 insert_constraint_atom(FA,Susp,Goal)
2981 ;
2982 delay_phase_end(validate_store_type_assumptions,
2983 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2984 insert_constraint_direct_used_vars(UsedVars,Vars)
2985 )
2986 )
2987 ).
2989 insert_constraint_direct_used_vars([],_).
2990 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2991 nth1(Index,Vars,Var),
2992 insert_constraint_direct_used_vars(Rest,Vars).
2994 insert_constraint_atom(FA,Susp,Call) :-
2995 make_name('$insert_in_store_',FA,Functor),
2996 Call =.. [Functor,Susp].
2998 insert_constraint_clause(C,Clauses,RestClauses) :-
2999 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3000 Clauses = [Clause|RestClauses],
3001 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3002 insert_constraint_atom(C,Susp,Head),
3003 insert_constraint_body(C,Susp,UsedVars,Body),
3004 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3005 ( chr_pp_flag(store_counter,on) ->
3006 InsertCounterInc = '$insert_counter_inc'
3007 ;
3008 InsertCounterInc = true
3009 )
3010 ;
3011 Clauses = RestClauses
3012 ).
3014 insert_constraint_used_vars([],_,_,true).
3015 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3016 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3017 insert_constraint_used_vars(Rest,C,Susp,Goals).
3019 insert_constraint_body(C,Susp,UsedVars,Body) :-
3020 get_store_type(C,StoreType),
3021 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3023 insert_constraint_body(default,C,Susp,[],Body) :-
3024 global_list_store_name(C,StoreName),
3025 make_get_store_goal(StoreName,Store,GetStoreGoal),
3026 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3027 ( chr_pp_flag(debugable,on) ->
3028 Cell = [Susp|Store],
3029 Body =
3030 (
3031 GetStoreGoal,
3032 UpdateStoreGoal
3033 )
3034 ;
3035 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3036 Body =
3037 (
3038 GetStoreGoal,
3039 Cell = [Susp|Store],
3040 UpdateStoreGoal,
3041 ( Store = [NextSusp|_] ->
3042 SetGoal
3043 ;
3044 true
3045 )
3046 )
3047 ).
3048 % get_target_module(Mod),
3049 % get_max_constraint_index(Total),
3050 % ( Total == 1 ->
3051 % generate_attach_body_1(C,Store,Susp,AttachBody)
3052 % ;
3053 % generate_attach_body_n(C,Store,Susp,AttachBody)
3054 % ),
3055 % Body =
3056 % (
3057 % 'chr default_store'(Store),
3058 % AttachBody
3059 % ).
3060 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3061 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3062 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3063 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3064 sort_out_used_vars(MixedUsedVars,UsedVars).
3065 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3066 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3067 constants_store_index_name(C,Index,IndexName),
3068 IndexLookup =.. [IndexName,Key,StoreName],
3069 Body =
3070 ( IndexLookup ->
3071 nb_getval(StoreName,Store),
3072 b_setval(StoreName,[Susp|Store])
3073 ;
3074 true
3075 ).
3076 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3077 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3078 constants_store_index_name(C,Index,IndexName),
3079 IndexLookup =.. [IndexName,Key,StoreName],
3080 Body =
3081 ( IndexLookup ->
3082 nb_getval(StoreName,Store),
3083 b_setval(StoreName,[Susp|Store])
3084 ;
3085 true
3086 ).
3087 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3088 global_ground_store_name(C,StoreName),
3089 make_get_store_goal(StoreName,Store,GetStoreGoal),
3090 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3091 ( chr_pp_flag(debugable,on) ->
3092 Cell = [Susp|Store],
3093 Body =
3094 (
3095 GetStoreGoal,
3096 UpdateStoreGoal
3097 )
3098 ;
3099 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3100 Body =
3101 (
3102 GetStoreGoal,
3103 Cell = [Susp|Store],
3104 UpdateStoreGoal,
3105 ( Store = [NextSusp|_] ->
3106 SetGoal
3107 ;
3108 true
3109 )
3110 )
3111 ).
3112 % global_ground_store_name(C,StoreName),
3113 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3114 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3115 % Body =
3116 % (
3117 % GetStoreGoal, % nb_getval(StoreName,Store),
3118 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3119 % ).
3120 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3121 % TODO: generalize to more than one !!!
3122 get_target_module(Module),
3123 Body = ( get_attr(Variable,Module,AssocStore) ->
3124 insert_assoc_store(AssocStore,Key,Susp)
3125 ;
3126 new_assoc_store(AssocStore),
3127 put_attr(Variable,Module,AssocStore),
3128 insert_assoc_store(AssocStore,Key,Susp)
3129 ).
3131 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3132 global_singleton_store_name(C,StoreName),
3133 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3134 Body =
3135 (
3136 UpdateStoreGoal
3137 ).
3138 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3139 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3140 list2conj(Bodies,Body),
3141 sort_out_used_vars(NestedUsedVars,UsedVars).
3142 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3143 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3144 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3145 UsedVars = [Index-Var],
3146 get_identifier_size(ISize),
3147 functor(Struct,struct,ISize),
3148 get_identifier_index(C,Index,IIndex),
3149 arg(IIndex,Struct,Susps),
3150 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3151 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3152 UsedVars = [Index-Var],
3153 type_indexed_identifier_structure(IndexType,Struct),
3154 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3155 arg(IIndex,Struct,Susps),
3156 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3158 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3159 flatten(NestedUsedVars,FlatUsedVars),
3160 sort(FlatUsedVars,SortedFlatUsedVars),
3161 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3163 sort_out_used_vars1([],[]).
3164 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3165 sort_out_used_vars1([I-X,J-Y|R],L) :-
3166 ( I == J ->
3167 X = Y,
3168 sort_out_used_vars1([I-X|R],L)
3169 ;
3170 L = [I-X|T],
3171 sort_out_used_vars1([J-Y|R],T)
3172 ).
3174 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3175 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3176 multi_hash_store_name(FA,Index,StoreName),
3177 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3178 Body =
3179 (
3180 KeyBody,
3181 nb_getval(StoreName,Store),
3182 insert_iht(Store,Key,Susp)
3183 ),
3184 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3186 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3187 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3188 multi_hash_store_name(FA,Index,StoreName),
3189 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3190 make_get_store_goal(StoreName,Store,GetStoreGoal),
3191 ( chr_pp_flag(ht_removal,on)
3192 -> ht_prev_field(Index,PrevField),
3193 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3194 SetGoal),
3195 Body =
3196 (
3197 GetStoreGoal,
3198 insert_ht(Store,Key,Susp,Result),
3199 ( Result = [_,NextSusp|_]
3200 -> SetGoal
3201 ; true
3202 )
3203 )
3204 ; Body =
3205 (
3206 GetStoreGoal,
3207 insert_ht(Store,Key,Susp)
3208 )
3209 ),
3210 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3212 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3213 % Delete
3215 delete_constraint_clause(C,Clauses,RestClauses) :-
3216 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3217 Clauses = [Clause|RestClauses],
3218 Clause = (Head :- Body),
3219 delete_constraint_atom(C,Susp,Head),
3220 C = F/A,
3221 functor(Head,F,A),
3222 delete_constraint_body(C,Head,Susp,[],Body)
3223 ;
3224 Clauses = RestClauses
3225 ).
3227 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3228 functor(Head,F,A),
3229 C = F/A,
3230 ( chr_pp_flag(inline_insertremove,off) ->
3231 use_auxiliary_predicate(delete_from_store,C),
3232 delete_constraint_atom(C,Susp,Goal)
3233 ;
3234 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3235 ).
3237 delete_constraint_atom(C,Susp,Atom) :-
3238 make_name('$delete_from_store_',C,Functor),
3239 Atom =.. [Functor,Susp].
3242 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3243 Body = (CounterBody,DeleteBody),
3244 ( chr_pp_flag(store_counter,on) ->
3245 CounterBody = '$delete_counter_inc'
3246 ;
3247 CounterBody = true
3248 ),
3249 get_store_type(C,StoreType),
3250 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3252 delete_constraint_body(default,C,_,Susp,_,Body) :-
3253 ( chr_pp_flag(debugable,on) ->
3254 global_list_store_name(C,StoreName),
3255 make_get_store_goal(StoreName,Store,GetStoreGoal),
3256 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3257 Body =
3258 (
3259 GetStoreGoal, % nb_getval(StoreName,Store),
3260 'chr sbag_del_element'(Store,Susp,NStore),
3261 UpdateStoreGoal % b_setval(StoreName,NStore)
3262 )
3263 ;
3264 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3265 global_list_store_name(C,StoreName),
3266 make_get_store_goal(StoreName,Store,GetStoreGoal),
3267 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3268 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3269 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3270 Body =
3271 (
3272 GetGoal,
3273 ( var(PredCell) ->
3274 GetStoreGoal, % nb_getval(StoreName,Store),
3275 Store = [_|Tail],
3276 UpdateStoreGoal,
3277 ( Tail = [NextSusp|_] ->
3278 SetGoal1
3279 ;
3280 true
3281 )
3282 ;
3283 PredCell = [_,_|Tail],
3284 setarg(2,PredCell,Tail),
3285 ( Tail = [NextSusp|_] ->
3286 SetGoal2
3287 ;
3288 true
3289 )
3290 )
3291 )
3292 ).
3293 % get_target_module(Mod),
3294 % get_max_constraint_index(Total),
3295 % ( Total == 1 ->
3296 % generate_detach_body_1(C,Store,Susp,DetachBody),
3297 % Body =
3298 % (
3299 % 'chr default_store'(Store),
3300 % DetachBody
3301 % )
3302 % ;
3303 % generate_detach_body_n(C,Store,Susp,DetachBody),
3304 % Body =
3305 % (
3306 % 'chr default_store'(Store),
3307 % DetachBody
3308 % )
3309 % ).
3310 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3311 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3312 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3313 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3314 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3315 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3316 constants_store_index_name(C,Index,IndexName),
3317 IndexLookup =.. [IndexName,Key,StoreName],
3318 Body =
3319 ( KeyBody,
3320 ( IndexLookup ->
3321 nb_getval(StoreName,Store),
3322 'chr sbag_del_element'(Store,Susp,NStore),
3323 b_setval(StoreName,NStore)
3324 ;
3325 true
3326 )).
3327 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3328 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3329 constants_store_index_name(C,Index,IndexName),
3330 IndexLookup =.. [IndexName,Key,StoreName],
3331 Body =
3332 ( KeyBody,
3333 ( IndexLookup ->
3334 nb_getval(StoreName,Store),
3335 'chr sbag_del_element'(Store,Susp,NStore),
3336 b_setval(StoreName,NStore)
3337 ;
3338 true
3339 )).
3340 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3341 ( chr_pp_flag(debugable,on) ->
3342 global_ground_store_name(C,StoreName),
3343 make_get_store_goal(StoreName,Store,GetStoreGoal),
3344 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3345 Body =
3346 (
3347 GetStoreGoal, % nb_getval(StoreName,Store),
3348 'chr sbag_del_element'(Store,Susp,NStore),
3349 UpdateStoreGoal % b_setval(StoreName,NStore)
3350 )
3351 ;
3352 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3353 global_ground_store_name(C,StoreName),
3354 make_get_store_goal(StoreName,Store,GetStoreGoal),
3355 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3356 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3357 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3358 Body =
3359 (
3360 GetGoal,
3361 ( var(PredCell) ->
3362 GetStoreGoal, % nb_getval(StoreName,Store),
3363 Store = [_|Tail],
3364 UpdateStoreGoal,
3365 ( Tail = [NextSusp|_] ->
3366 SetGoal1
3367 ;
3368 true
3369 )
3370 ;
3371 PredCell = [_,_|Tail],
3372 setarg(2,PredCell,Tail),
3373 ( Tail = [NextSusp|_] ->
3374 SetGoal2
3375 ;
3376 true
3377 )
3378 )
3379 )
3380 ).
3381 % global_ground_store_name(C,StoreName),
3382 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3383 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3384 % Body =
3385 % (
3386 % GetStoreGoal, % nb_getval(StoreName,Store),
3387 % 'chr sbag_del_element'(Store,Susp,NStore),
3388 % UpdateStoreGoal % b_setval(StoreName,NStore)
3389 % ).
3390 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3391 get_target_module(Module),
3392 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3393 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3394 Body = (
3395 VariableGoal,
3396 get_attr(Variable,Module,AssocStore),
3397 KeyGoal,
3398 delete_assoc_store(AssocStore,Key,Susp)
3399 ).
3400 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3401 global_singleton_store_name(C,StoreName),
3402 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3403 Body =
3404 (
3405 UpdateStoreGoal % b_setval(StoreName,[])
3406 ).
3407 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3408 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3409 list2conj(Bodies,Body).
3410 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3411 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3412 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3413 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3414 get_identifier_size(ISize),
3415 functor(Struct,struct,ISize),
3416 get_identifier_index(C,Index,IIndex),
3417 arg(IIndex,Struct,Susps),
3418 Body = (
3419 VariableGoal,
3420 Variable = Struct,
3421 'chr sbag_del_element'(Susps,Susp,NSusps),
3422 setarg(IIndex,Variable,NSusps)
3423 ).
3424 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3425 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3426 type_indexed_identifier_structure(IndexType,Struct),
3427 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3428 arg(IIndex,Struct,Susps),
3429 Body = (
3430 VariableGoal,
3431 Variable = Struct,
3432 'chr sbag_del_element'(Susps,Susp,NSusps),
3433 setarg(IIndex,Variable,NSusps)
3434 ).
3436 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3437 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3438 multi_hash_store_name(FA,Index,StoreName),
3439 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3440 Body =
3441 (
3442 KeyBody,
3443 nb_getval(StoreName,Store),
3444 delete_iht(Store,Key,Susp)
3445 ),
3446 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3447 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3448 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3449 multi_hash_store_name(C,Index,StoreName),
3450 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3451 make_get_store_goal(StoreName,Store,GetStoreGoal),
3452 ( chr_pp_flag(ht_removal,on)
3453 -> ht_prev_field(Index,PrevField),
3454 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3455 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3456 SetGoal1),
3457 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3458 SetGoal2),
3459 Body =
3460 (
3461 GetGoal,
3462 ( var(Prev)
3463 -> GetStoreGoal,
3464 KeyBody,
3465 delete_first_ht(Store,Key,Values),
3466 ( Values = [NextSusp|_]
3467 -> SetGoal1
3468 ; true
3469 )
3470 ; Prev = [_,_|Values],
3471 setarg(2,Prev,Values),
3472 ( Values = [NextSusp|_]
3473 -> SetGoal2
3474 ; true
3475 )
3476 )
3477 )
3478 ; Body =
3479 (
3480 KeyBody,
3481 GetStoreGoal, % nb_getval(StoreName,Store),
3482 delete_ht(Store,Key,Susp)
3483 )
3484 ),
3485 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3489 :- chr_constraint
3490 module_initializer/1,
3491 module_initializers/1.
3493 module_initializers(G), module_initializer(Initializer) <=>
3494 G = (Initializer,Initializers),
3495 module_initializers(Initializers).
3497 module_initializers(G) <=>
3498 G = true.
3500 generate_attach_code(Constraints,[Enumerate|L]) :-
3501 enumerate_stores_code(Constraints,Enumerate),
3502 generate_attach_code(Constraints,L,T),
3503 module_initializers(Initializers),
3504 prolog_global_variables_code(PrologGlobalVariables),
3505 % Do not rename or the 'chr_initialization' predicate
3506 % without warning SSS
3507 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3509 generate_attach_code([],L,L).
3510 generate_attach_code([C|Cs],L,T) :-
3511 get_store_type(C,StoreType),
3512 generate_attach_code(StoreType,C,L,L1),
3513 generate_attach_code(Cs,L1,T).
3515 generate_attach_code(default,C,L,T) :-
3516 global_list_store_initialisation(C,L,T).
3517 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3518 multi_inthash_store_initialisations(Indexes,C,L,L1),
3519 multi_inthash_via_lookups(Indexes,C,L1,T).
3520 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3521 multi_hash_store_initialisations(Indexes,C,L,L1),
3522 multi_hash_lookups(Indexes,C,L1,T).
3523 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3524 constants_initializers(C,Index,Constants),
3525 atomic_constants_code(C,Index,Constants,L,T).
3526 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3527 constants_initializers(C,Index,Constants),
3528 ground_constants_code(C,Index,Constants,L,T).
3529 generate_attach_code(global_ground,C,L,T) :-
3530 global_ground_store_initialisation(C,L,T).
3531 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3532 use_auxiliary_module(chr_assoc_store).
3533 generate_attach_code(global_singleton,C,L,T) :-
3534 global_singleton_store_initialisation(C,L,T).
3535 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3536 multi_store_generate_attach_code(StoreTypes,C,L,T).
3537 generate_attach_code(identifier_store(Index),C,L,T) :-
3538 get_identifier_index(C,Index,IIndex),
3539 ( IIndex == 2 ->
3540 get_identifier_size(ISize),
3541 functor(Struct,struct,ISize),
3542 Struct =.. [_,Label|Stores],
3543 set_elems(Stores,[]),
3544 Clause1 = new_identifier(Label,Struct),
3545 functor(Struct2,struct,ISize),
3546 arg(1,Struct2,Label2),
3547 Clause2 =
3548 ( user:portray(Struct2) :-
3549 write('<id:'),
3550 print(Label2),
3551 write('>')
3552 ),
3553 functor(Struct3,struct,ISize),
3554 arg(1,Struct3,Label3),
3555 Clause3 = identifier_label(Struct3,Label3),
3556 L = [Clause1,Clause2,Clause3|T]
3557 ;
3558 L = T
3559 ).
3560 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3561 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3562 ( IIndex == 2 ->
3563 identifier_store_initialization(IndexType,L,L1),
3564 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3565 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3566 get_type_indexed_identifier_size(IndexType,ISize),
3567 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3568 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3569 type_indexed_identifier_structure(IndexType,Struct),
3570 Struct =.. [_,Label|Stores],
3571 set_elems(Stores,[]),
3572 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3573 Clause1 =.. [Name1,Label,Struct],
3574 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3575 Goal1 =.. [Name1,Label1b,S1b],
3576 type_indexed_identifier_structure(IndexType,Struct1b),
3577 Struct1b =.. [_,Label1b|Stores1b],
3578 set_elems(Stores1b,[]),
3579 Expansion1 = (S1b = Struct1b),
3580 Clause1b = user:goal_expansion(Goal1,Expansion1),
3581 % writeln(Clause1-Clause1b),
3582 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3583 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3584 type_indexed_identifier_structure(IndexType,Struct2),
3585 arg(1,Struct2,Label2),
3586 Clause2 =
3587 ( user:portray(Struct2) :-
3588 write('<id:'),
3589 print(Label2),
3590 write('>')
3591 ),
3592 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3593 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3594 type_indexed_identifier_structure(IndexType,Struct3),
3595 arg(1,Struct3,Label3),
3596 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3597 Clause3 =.. [Name3,Struct3,Label3],
3598 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3599 Goal3b =.. [Name3,S3b,L3b],
3600 type_indexed_identifier_structure(IndexType,Struct3b),
3601 arg(1,Struct3b,L3b),
3602 Expansion3b = (S3 = Struct3b),
3603 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3604 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3606 identifier_store_name(IndexType,GlobalVariable),
3607 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3608 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3609 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3610 Clause4 =
3611 ( LookupAtom :-
3612 nb_getval(GlobalVariable,HT),
3613 ( lookup_ht(HT,X,[IX]) ->
3614 true
3615 ;
3616 NewIdentifierGoal,
3617 insert_ht(HT,X,IX)
3618 )
3619 ),
3620 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3621 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3622 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3623 ;
3624 L = T
3625 ).
3627 constants_initializers(C,Index,Constants) :-
3628 maplist(constant_initializer(C,Index),Constants).
3630 constant_initializer(C,Index,Constant) :-
3631 constants_store_name(C,Index,Constant,StoreName),
3632 module_initializer(nb_setval(StoreName,[])).
3634 lookup_identifier_atom(Key,X,IX,Atom) :-
3635 atom_concat('lookup_identifier_',Key,LookupFunctor),
3636 Atom =.. [LookupFunctor,X,IX].
3638 identifier_label_atom(IndexType,IX,X,Atom) :-
3639 type_indexed_identifier_name(IndexType,identifier_label,Name),
3640 Atom =.. [Name,IX,X].
3642 multi_store_generate_attach_code([],_,L,L).
3643 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3644 generate_attach_code(ST,C,L,L1),
3645 multi_store_generate_attach_code(STs,C,L1,T).
3647 multi_inthash_store_initialisations([],_,L,L).
3648 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3649 use_auxiliary_module(chr_integertable_store),
3650 multi_hash_store_name(FA,Index,StoreName),
3651 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3652 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3653 L1 = L,
3654 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3655 multi_hash_store_initialisations([],_,L,L).
3656 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3657 use_auxiliary_module(chr_hashtable_store),
3658 multi_hash_store_name(FA,Index,StoreName),
3659 prolog_global_variable(StoreName),
3660 make_init_store_goal(StoreName,HT,InitStoreGoal),
3661 module_initializer((new_ht(HT),InitStoreGoal)),
3662 L1 = L,
3663 multi_hash_store_initialisations(Indexes,FA,L1,T).
3665 global_list_store_initialisation(C,L,T) :-
3666 ( is_stored(C) ->
3667 global_list_store_name(C,StoreName),
3668 prolog_global_variable(StoreName),
3669 make_init_store_goal(StoreName,[],InitStoreGoal),
3670 module_initializer(InitStoreGoal)
3671 ;
3672 true
3673 ),
3674 L = T.
3675 global_ground_store_initialisation(C,L,T) :-
3676 global_ground_store_name(C,StoreName),
3677 prolog_global_variable(StoreName),
3678 make_init_store_goal(StoreName,[],InitStoreGoal),
3679 module_initializer(InitStoreGoal),
3680 L = T.
3681 global_singleton_store_initialisation(C,L,T) :-
3682 global_singleton_store_name(C,StoreName),
3683 prolog_global_variable(StoreName),
3684 make_init_store_goal(StoreName,[],InitStoreGoal),
3685 module_initializer(InitStoreGoal),
3686 L = T.
3687 identifier_store_initialization(IndexType,L,T) :-
3688 use_auxiliary_module(chr_hashtable_store),
3689 identifier_store_name(IndexType,StoreName),
3690 prolog_global_variable(StoreName),
3691 make_init_store_goal(StoreName,HT,InitStoreGoal),
3692 module_initializer((new_ht(HT),InitStoreGoal)),
3693 L = T.
3696 multi_inthash_via_lookups([],_,L,L).
3697 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3698 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3699 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3700 L = [(Head :- Body)|L1],
3701 multi_inthash_via_lookups(Indexes,C,L1,T).
3702 multi_hash_lookups([],_,L,L).
3703 multi_hash_lookups([Index|Indexes],C,L,T) :-
3704 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3705 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3706 L = [(Head :- Body)|L1],
3707 multi_hash_lookups(Indexes,C,L1,T).
3709 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3710 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3711 Head =.. [Name,Key,SuspsList].
3713 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3714 %
3715 % Returns goal that performs hash table lookup.
3716 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3717 % INLINED:
3718 get_store_type(ConstraintSymbol,multi_store(Stores)),
3719 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3720 ( ground(Key) ->
3721 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3722 Goal = nb_getval(StoreName,SuspsList)
3723 ;
3724 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3725 Lookup =.. [IndexName,Key,StoreName],
3726 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3727 )
3728 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3729 ( ground(Key) ->
3730 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3731 Goal = nb_getval(StoreName,SuspsList)
3732 ;
3733 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3734 Lookup =.. [IndexName,Key,StoreName],
3735 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3736 )
3737 ; memberchk(multi_hash([Index]),Stores) ->
3738 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3739 make_get_store_goal(StoreName,HT,GetStoreGoal),
3740 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3741 Goal =
3742 (
3743 GetStoreGoal, % nb_getval(StoreName,HT),
3744 HashCall, % hash_term(Key,Hash),
3745 lookup_ht1(HT,Hash,Key,SuspsList)
3746 )
3747 ;
3748 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3749 Goal =
3750 (
3751 GetStoreGoal, % nb_getval(StoreName,HT),
3752 Lookup
3753 )
3754 )
3755 ; HashType == inthash ->
3756 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3757 make_get_store_goal(StoreName,HT,GetStoreGoal),
3758 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3759 Goal =
3760 (
3761 GetStoreGoal, % nb_getval(StoreName,HT),
3762 Lookup
3763 )
3764 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3765 % find alternative index
3766 % -> SubIndex + RestIndex
3767 % -> SubKey + RestKeys
3768 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3769 % instantiate rest goal?
3770 % Goal = (SubGoal,RestGoal)
3771 ).
3774 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3775 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3777 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3778 ( ground(Key) ->
3779 % This is based on a property of SWI-Prolog's
3780 % hash_term/2 predicate:
3781 % the hash value is stable over repeated invocations
3782 % of SWI-Prolog
3783 hash_term(Key,Hash),
3784 Call = true
3785 ; Index = [IndexPos],
3786 get_constraint_type(Constraint,ArgTypes),
3787 nth1(IndexPos,ArgTypes,Type),
3788 unalias_type(Type,NormalType),
3789 memberchk_eq(NormalType,[int,natural]) ->
3790 ( NormalType == int ->
3791 Hash = abs(Key),
3792 Call = true
3793 ;
3794 Hash = Key,
3795 Call = true
3796 )
3797 ;
3798 nonvar(Key),
3799 specialize_hash_term(Key,NewKey),
3800 NewKey \== Key,
3801 Call = hash_term(NewKey,Hash)
3802 ).
3804 specialize_hash_term(Term,NewTerm) :-
3805 ( ground(Term) ->
3806 hash_term(Term,NewTerm)
3807 ; var(Term) ->
3808 NewTerm = Term
3809 ;
3810 Term =.. [F|Args],
3811 maplist(specialize_hash_term,Args,NewArgs),
3812 NewTerm =.. [F|NewArgs]
3813 ).
3815 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3816 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3817 ( /* chr_pp_flag(experiment,off) ->
3818 true
3819 ; */ atomic(Key) ->
3820 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3821 ; ground(Key) ->
3822 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3823 ;
3824 ( Index = [Pos],
3825 get_constraint_arg_type(ConstraintSymbol,Pos,chr_constants(_))
3826 ->
3827 true
3828 ;
3829 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3830 )
3831 ),
3832 delay_phase_end(validate_store_type_assumptions,
3833 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3835 :- chr_constraint actual_atomic_multi_hash_keys/3.
3836 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3838 :- chr_constraint actual_ground_multi_hash_keys/3.
3839 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3841 :- chr_constraint actual_non_ground_multi_hash_key/2.
3842 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3844 /*
3845 actual_atomic_multi_hash_keys(C,Index,Keys)
3846 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3848 actual_ground_multi_hash_keys(C,Index,Keys)
3849 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3851 actual_non_ground_multi_hash_key(C,Index)
3852 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3853 */
3854 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3855 <=> append(Keys1,Keys2,Keys0),
3856 sort(Keys0,Keys),
3857 actual_atomic_multi_hash_keys(C,Index,Keys).
3859 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3860 <=> append(Keys1,Keys2,Keys0),
3861 sort(Keys0,Keys),
3862 actual_ground_multi_hash_keys(C,Index,Keys).
3864 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3865 <=> append(Keys1,Keys2,Keys0),
3866 sort(Keys0,Keys),
3867 actual_ground_multi_hash_keys(C,Index,Keys).
3869 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3870 <=> true.
3872 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3873 <=> true.
3875 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3876 <=> true.
3878 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3879 %
3880 % Returns predicate name of hash table lookup predicate.
3881 multi_hash_lookup_name(F/A,Index,Name) :-
3882 ( integer(Index) ->
3883 IndexName = Index
3884 ; is_list(Index) ->
3885 atom_concat_list(Index,IndexName)
3886 ),
3887 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3889 multi_hash_store_name(F/A,Index,Name) :-
3890 get_target_module(Mod),
3891 ( integer(Index) ->
3892 IndexName = Index
3893 ; is_list(Index) ->
3894 atom_concat_list(Index,IndexName)
3895 ),
3896 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3898 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3899 ( ( integer(Index) ->
3900 I = Index
3901 ;
3902 Index = [I]
3903 ) ->
3904 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3905 ; is_list(Index) ->
3906 sort(Index,Indexes),
3907 maplist(get_dynamic_suspension_term_field1(FA,Susp),Indexes,Keys,Bodies),
3908 Key =.. [k|Keys],
3909 list2conj(Bodies,KeyBody)
3910 ).
3912 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3913 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3915 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3916 ( ( integer(Index) ->
3917 I = Index
3918 ;
3919 Index = [I]
3920 ) ->
3921 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3922 ; is_list(Index) ->
3923 sort(Index,Indexes),
3924 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Indexes,Keys,Bodies),
3925 Key =.. [k|Keys],
3926 list2conj(Bodies,KeyBody)
3927 ).
3929 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3930 arg(Index,Head,OriginalArg),
3931 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3932 Goal = true
3933 ;
3934 functor(Head,F,A),
3935 C = F/A,
3936 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3937 ).
3939 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3940 ( ( integer(Index) ->
3941 I = Index
3942 ;
3943 Index = [I]
3944 ) ->
3945 UsedVars = [I-Key]
3946 ; is_list(Index) ->
3947 sort(Index,Indexes),
3948 pairup(Indexes,Keys,UsedVars),
3949 Key =.. [k|Keys]
3950 ).
3952 multi_hash_key_args(Index,Head,KeyArgs) :-
3953 ( integer(Index) ->
3954 arg(Index,Head,Arg),
3955 KeyArgs = [Arg]
3956 ; is_list(Index) ->
3957 sort(Index,Indexes),
3958 term_variables(Head,Vars),
3959 maplist(arg1(Head),Indexes,KeyArgs)
3960 ).
3962 %-------------------------------------------------------------------------------
3963 atomic_constants_code(C,Index,Constants,L,T) :-
3964 constants_store_index_name(C,Index,IndexName),
3965 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3966 append(Clauses,T,L).
3968 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3969 constants_store_name(C,Index,Constant,StoreName),
3970 Clause =.. [IndexName,Constant,StoreName].
3972 %-------------------------------------------------------------------------------
3973 ground_constants_code(C,Index,Terms,L,T) :-
3974 constants_store_index_name(C,Index,IndexName),
3975 maplist(constants_store_name(C,Index),Terms,StoreNames),
3976 length(Terms,N),
3977 replicate(N,[],More),
3978 trie_index([Terms|More],StoreNames,IndexName,L,T).
3980 constants_store_name(F/A,Index,Term,Name) :-
3981 get_target_module(Mod),
3982 term_to_atom(Term,Constant),
3983 term_to_atom(Index,IndexAtom),
3984 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3986 constants_store_index_name(F/A,Index,Name) :-
3987 get_target_module(Mod),
3988 term_to_atom(Index,IndexAtom),
3989 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3991 % trie index code {{{
3992 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3993 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3995 trie_step([],_,_,[],[],L,L) :- !.
3996 % length MorePatterns == length Patterns == length Results
3997 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3998 MorePatterns = [List|_],
3999 length(List,N),
4000 aggregate_all(set(F/A),
4001 ( member(Pattern,Patterns),
4002 functor(Pattern,F,A)
4003 ),
4004 FAs),
4005 N1 is N + 1,
4006 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
4008 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
4009 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
4010 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
4011 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
4013 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
4014 Clause = (Head :- Body),
4015 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4016 N1 is N + 1,
4017 functor(Head,Symbol,N1),
4018 arg(1,Head,IndexPattern),
4019 Head =.. [_,_|RestArgs],
4020 once(append(Vs,[Result],RestArgs)),
4021 /* IndexPattern = F() */
4022 functor(IndexPattern,F,A),
4023 IndexPattern =.. [_|Args],
4024 append(Args,RestArgs,RecArgs),
4025 ( RecArgs == [Result] ->
4026 /* nothing more to match on */
4027 List = Tail,
4028 Body = true,
4029 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4030 MoreResults = [Result]
4031 ; /* more things to match on */
4032 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4033 ( MoreCases = [OneMoreCase] ->
4034 /* only one more thing to match on */
4035 List = Tail,
4036 Body = true,
4037 append([Cases,OneMoreCase,MoreResults],RecArgs)
4038 ;
4039 /* more than one thing to match on */
4040 /* [ x1,..., xn]
4041 [xs1,...,xsn]
4042 */
4043 pairup(Cases,MoreCases,CasePairs),
4044 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4045 append(Args,Vs,[First|Rest]),
4046 First-Rest = CommonPatternPair,
4047 % Body = RSymbol(DiffVars,Result)
4048 gensym(Prefix,RSymbol),
4049 append(DiffVars,[Result],RecCallVars),
4050 Body =.. [RSymbol|RecCallVars],
4051 findall(CH-CT,member([CH|CT],Differences),CPairs),
4052 once(pairup(CHs,CTs,CPairs)),
4053 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4054 )
4055 ).
4057 rec_cases([],[],[],_,[],[],[]).
4058 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4059 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4060 Cases = [Case|NCases],
4061 MoreCases = [MoreCase|NMoreCases],
4062 MoreResults = [Result|NMoreResults],
4063 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4064 ;
4065 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4066 ).
4067 % }}}
4069 %% common_pattern(+terms,-term,-vars,-differences) is det.
4070 common_pattern(Ts,T,Vars,Differences) :-
4071 fold1(gct,Ts,T),
4072 term_variables(T,Vars),
4073 findall(Vars,member(T,Ts),Differences).
4075 gct(T1,T2,T) :-
4076 gct_(T1,T2,T,[],_).
4078 gct_(T1,T2,T,Dict0,Dict) :-
4079 ( nonvar(T1),
4080 nonvar(T2),
4081 functor(T1,F1,A1),
4082 functor(T2,F2,A2),
4083 F1 == F2,
4084 A1 == A2 ->
4085 functor(T,F1,A1),
4086 T1 =.. [_|Args1],
4087 T2 =.. [_|Args2],
4088 T =.. [_|Args],
4089 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4090 ;
4091 /* T is a variable */
4092 ( lookup_eq(Dict0,T1+T2,T) ->
4093 /* we already have a variable for this difference */
4094 Dict = Dict0
4095 ;
4096 /* T is a fresh variable */
4097 Dict = [(T1+T2)-T|Dict0]
4098 )
4099 ).
4102 fold1(P,[Head|Tail],Result) :-
4103 fold(Tail,P,Head,Result).
4105 fold([],_,Acc,Acc).
4106 fold([X|Xs],P,Acc,Res) :-
4107 call(P,X,Acc,NAcc),
4108 fold(Xs,P,NAcc,Res).
4110 maplist_dcg(P,L1,L2,L) -->
4111 maplist_dcg_(L1,L2,L,P).
4113 maplist_dcg_([],[],[],_) --> [].
4114 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4115 call(P,X,Y,Z),
4116 maplist_dcg_(Xs,Ys,Zs,P).
4117 %-------------------------------------------------------------------------------
4118 global_list_store_name(F/A,Name) :-
4119 get_target_module(Mod),
4120 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4121 global_ground_store_name(F/A,Name) :-
4122 get_target_module(Mod),
4123 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4124 global_singleton_store_name(F/A,Name) :-
4125 get_target_module(Mod),
4126 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4128 identifier_store_name(TypeName,Name) :-
4129 get_target_module(Mod),
4130 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4132 :- chr_constraint prolog_global_variable/1.
4133 :- chr_option(mode,prolog_global_variable(+)).
4135 :- chr_constraint prolog_global_variables/1.
4136 :- chr_option(mode,prolog_global_variables(-)).
4138 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4140 prolog_global_variables(List), prolog_global_variable(Name) <=>
4141 List = [Name|Tail],
4142 prolog_global_variables(Tail).
4143 prolog_global_variables(List) <=> List = [].
4145 %% SWI begin
4146 prolog_global_variables_code(Code) :-
4147 prolog_global_variables(Names),
4148 ( Names == [] ->
4149 Code = []
4150 ;
4151 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4152 Code = [(:- dynamic user:exception/3),
4153 (:- multifile user:exception/3),
4154 (user:exception(undefined_global_variable,Name,retry) :-
4155 (
4156 '$chr_prolog_global_variable'(Name),
4157 '$chr_initialization'
4158 )
4159 )
4160 |
4161 NameDeclarations
4162 ]
4163 ).
4164 %% SWI end
4165 %% SICStus begin
4166 % prolog_global_variables_code([]).
4167 %% SICStus end
4168 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4169 %sbag_member_call(S,L,sysh:mem(S,L)).
4170 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4171 %sbag_member_call(S,L,member(S,L)).
4172 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4173 %update_mutable_call(A,B,setarg(1, B, A)).
4174 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4175 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4177 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4178 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4179 % create_get_mutable(Value,Field,Get1).
4180 %
4181 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4182 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4183 % update_mutable_call(NewValue,Field,Set).
4184 %
4185 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4186 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4187 % create_get_mutable_ref(Value,Field,Get1),
4188 % update_mutable_call(NewValue,Field,Set).
4189 %
4190 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4191 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4192 % create_mutable_call(Value,Field,Create).
4193 %
4194 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4195 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4196 % create_get_mutable(Value,Field,Get).
4197 %
4198 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4199 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4200 % create_get_mutable_ref(Value,Field,Get),
4201 % update_mutable_call(NewValue,Field,Set).
4203 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4204 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4206 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4207 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4209 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4210 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4211 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4213 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4214 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4216 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4217 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4219 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4220 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4221 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4223 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4225 enumerate_stores_code(Constraints,Clause) :-
4226 Head = '$enumerate_constraints'(Constraint),
4227 enumerate_store_bodies(Constraints,Constraint,Bodies),
4228 list2disj(Bodies,Body),
4229 Clause = (Head :- Body).
4231 enumerate_store_bodies([],_,[]).
4232 enumerate_store_bodies([C|Cs],Constraint,L) :-
4233 ( is_stored(C) ->
4234 get_store_type(C,StoreType),
4235 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4236 true
4237 ;
4238 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4239 ),
4240 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4241 C = F/_,
4242 Constraint0 =.. [F|Arguments],
4243 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4244 L = [Body|T]
4245 ;
4246 L = T
4247 ),
4248 enumerate_store_bodies(Cs,Constraint,T).
4250 enumerate_store_body(default,C,Susp,Body) :-
4251 global_list_store_name(C,StoreName),
4252 sbag_member_call(Susp,List,Sbag),
4253 make_get_store_goal(StoreName,List,GetStoreGoal),
4254 Body =
4255 (
4256 GetStoreGoal, % nb_getval(StoreName,List),
4257 Sbag
4258 ).
4259 % get_constraint_index(C,Index),
4260 % get_target_module(Mod),
4261 % get_max_constraint_index(MaxIndex),
4262 % Body1 =
4263 % (
4264 % 'chr default_store'(GlobalStore),
4265 % get_attr(GlobalStore,Mod,Attr)
4266 % ),
4267 % ( MaxIndex > 1 ->
4268 % NIndex is Index + 1,
4269 % sbag_member_call(Susp,List,Sbag),
4270 % Body2 =
4271 % (
4272 % arg(NIndex,Attr,List),
4273 % Sbag
4274 % )
4275 % ;
4276 % sbag_member_call(Susp,Attr,Sbag),
4277 % Body2 = Sbag
4278 % ),
4279 % Body = (Body1,Body2).
4280 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4281 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4282 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4283 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4284 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4285 Completeness == complete, % fail if incomplete
4286 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4287 list2disj(Disjuncts, Disjunction),
4288 Body = ( Disjunction, member(Susp,Susps) ).
4289 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4290 constants_store_name(C,Index,Constant,StoreName).
4292 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4293 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4294 enumerate_store_body(global_ground,C,Susp,Body) :-
4295 global_ground_store_name(C,StoreName),
4296 sbag_member_call(Susp,List,Sbag),
4297 make_get_store_goal(StoreName,List,GetStoreGoal),
4298 Body =
4299 (
4300 GetStoreGoal, % nb_getval(StoreName,List),
4301 Sbag
4302 ).
4303 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4304 Body = fail.
4305 enumerate_store_body(global_singleton,C,Susp,Body) :-
4306 global_singleton_store_name(C,StoreName),
4307 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4308 Body =
4309 (
4310 GetStoreGoal, % nb_getval(StoreName,Susp),
4311 Susp \== []
4312 ).
4313 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4314 once((
4315 member(ST,STs),
4316 enumerate_store_body(ST,C,Susp,Body)
4317 )).
4318 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4319 Body = fail.
4320 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4321 Body = fail.
4323 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4324 multi_hash_store_name(C,I,StoreName),
4325 B =
4326 (
4327 nb_getval(StoreName,HT),
4328 value_iht(HT,Susp)
4329 ).
4330 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4331 multi_hash_store_name(C,I,StoreName),
4332 make_get_store_goal(StoreName,HT,GetStoreGoal),
4333 B =
4334 (
4335 GetStoreGoal, % nb_getval(StoreName,HT),
4336 value_ht(HT,Susp)
4337 ).
4339 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4342 :- chr_constraint
4343 prev_guard_list/8,
4344 prev_guard_list/6,
4345 simplify_guards/1,
4346 set_all_passive/1.
4348 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4349 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4350 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4351 :- chr_option(mode,simplify_guards(+)).
4352 :- chr_option(mode,set_all_passive(+)).
4354 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4355 % GUARD SIMPLIFICATION
4356 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4357 % If the negation of the guards of earlier rules entails (part of)
4358 % the current guard, the current guard can be simplified. We can only
4359 % use earlier rules with a head that matches if the head of the current
4360 % rule does, and which make it impossible for the current rule to match
4361 % if they fire (i.e. they shouldn't be propagation rules and their
4362 % head constraints must be subsets of those of the current rule).
4363 % At this point, we know for sure that the negation of the guard
4364 % of such a rule has to be true (otherwise the earlier rule would have
4365 % fired, because of the refined operational semantics), so we can use
4366 % that information to simplify the guard by replacing all entailed
4367 % conditions by true/0. As a consequence, the never-stored analysis
4368 % (in a further phase) will detect more cases of never-stored constraints.
4369 %
4370 % e.g. c(X),d(Y) <=> X > 0 | ...
4371 % e(X) <=> X < 0 | ...
4372 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4373 % \____________/
4374 % true
4376 guard_simplification :-
4377 ( chr_pp_flag(guard_simplification,on) ->
4378 precompute_head_matchings,
4379 simplify_guards(1)
4380 ;
4381 true
4382 ).
4384 % for every rule, we create a prev_guard_list where the last argument
4385 % eventually is a list of the negations of earlier guards
4386 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4387 <=>
4388 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4389 append(Head1,Head2,Heads),
4390 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4391 tree_set_empty(Done),
4392 multiple_occ_constraints_checked(Done),
4393 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4395 append(IDs1,IDs2,IDs),
4396 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4397 empty_q(EmptyHeap),
4398 insert_list_q(HeapData,EmptyHeap,Heap),
4399 next_prev_rule(Heap,_,Heap1),
4400 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4401 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4402 NextRule is RuleNb+1,
4403 simplify_guards(NextRule).
4405 next_prev_rule(Heap,RuleNb,NHeap) :-
4406 ( find_min_q(Heap,_-Priority) ->
4407 Priority = (-RuleNb),
4408 normalize_heap(Heap,Priority,NHeap)
4409 ;
4410 RuleNb = 0,
4411 NHeap = Heap
4412 ).
4414 normalize_heap(Heap,Priority,NHeap) :-
4415 ( find_min_q(Heap,_-Priority) ->
4416 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4417 ( O > 1 ->
4418 NO is O -1,
4419 get_occurrence(C,NO,RuleNb,_),
4420 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4421 ;
4422 Heap2 = Heap1
4423 ),
4424 normalize_heap(Heap2,Priority,NHeap)
4425 ;
4426 NHeap = Heap
4427 ).
4429 % no more rule
4430 simplify_guards(_)
4431 <=>
4432 true.
4434 % The negation of the guard of a non-propagation rule is added
4435 % if its kept head constraints are a subset of the kept constraints of
4436 % the rule we're working on, and its removed head constraints (at least one)
4437 % are a subset of the removed constraints.
4439 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4440 <=>
4441 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4442 H1 \== [],
4443 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4444 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4445 |
4446 append(H1,H2,Heads),
4447 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4448 append(GuardList,DerivedInfo,GL1),
4449 normalize_conj_list(GL1,GL),
4450 append(GH_New1,GH,GH1),
4451 normalize_conj_list(GH1,GH_New),
4452 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4453 % PrevPrevRuleNb is PrevRuleNb-1,
4454 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4456 % if this isn't the case, we skip this one and try the next rule
4457 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4458 <=>
4459 ( N > 0 ->
4460 next_prev_rule(Heap,N1,NHeap),
4461 % N1 is N-1,
4462 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4463 ;
4464 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4465 ).
4467 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4468 <=>
4469 GH \== []
4470 |
4471 head_types_modes_condition(GH,H,TypeInfo),
4472 conj2list(TypeInfo,TI),
4473 term_variables(H,HeadVars),
4474 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4475 normalize_conj_list(Info,InfoL),
4476 prev_guard_list(RuleNb,H,G,InfoL,M,[]).
4478 head_types_modes_condition([],H,true).
4479 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4480 types_modes_condition(H,GH,TI1),
4481 head_types_modes_condition(GHs,H,TI2).
4483 %%
4484 %
4485 % when all earlier guards are added or skipped, we simplify the guard.
4486 % if it's different from the original one, we change the rule
4488 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4489 <=>
4490 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4491 G \== true, % let's not try to simplify this ;)
4492 append(M,GuardList,Info),
4493 simplify_guard(G,B,Info,SimpleGuard,NB),
4494 G \== SimpleGuard
4495 |
4496 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4497 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4499 %% normalize_conj_list(+List,-NormalList) is det.
4500 %
4501 % Removes =true= elements and flattens out conjunctions.
4503 normalize_conj_list(List,NormalList) :-
4504 list2conj(List,Conj),
4505 conj2list(Conj,NormalList).
4507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4508 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4509 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4511 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4512 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4513 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4514 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4515 append(Renaming1,ExtraRenaming,Renaming2),
4516 list2conj(PrevMatchings,Match),
4517 negate_b(Match,HeadsDontMatch),
4518 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4519 list2conj(HeadsMatch,HeadsMatchBut),
4520 term_variables(Renaming2,RenVars),
4521 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4522 new_vars(MGVars,RenVars,ExtraRenaming2),
4523 append(Renaming2,ExtraRenaming2,Renaming),
4524 ( PrevGuard == true -> % true can't fail
4525 Info_ = HeadsDontMatch
4526 ;
4527 negate_b(PrevGuard,TheGuardFailed),
4528 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4529 ),
4530 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4531 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4532 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4533 list2conj(RenamedMatchings_,RenamedMatchings),
4534 apply_guard_wrt_term(H,RenamedG2,GH2),
4535 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4536 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4538 simplify_guard(G,B,Info,SG,NB) :-
4539 conj2list(G,LG),
4540 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4541 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4542 list2conj(SGL,SG).
4545 new_vars([],_,[]).
4546 new_vars([A|As],RV,ER) :-
4547 ( memberchk_eq(A,RV) ->
4548 new_vars(As,RV,ER)
4549 ;
4550 ER = [A-NewA,NewA-A|ER2],
4551 new_vars(As,RV,ER2)
4552 ).
4554 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4555 %
4556 % check if a list of constraints is a subset of another list of constraints
4557 % (multiset-subset), meanwhile computing a variable renaming to convert
4558 % one into the other.
4559 head_subset(H,Head,Renaming) :-
4560 head_subset(H,Head,Renaming,[],_).
4562 head_subset([],Remainder,Renaming,Renaming,Remainder).
4563 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4564 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4565 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4567 % check if A is in the list, remove it from Headleft
4568 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4569 ( variable_replacement(A,X,Acc,Renaming),
4570 Remainder = Xs
4571 ;
4572 Remainder = [X|RRemainder],
4573 head_member(Xs,A,Renaming,Acc,RRemainder)
4574 ).
4575 %-------------------------------------------------------------------------------%
4576 % memoing code to speed up repeated computation
4578 :- chr_constraint precompute_head_matchings/0.
4580 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4581 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4582 append(H1,H2,Heads),
4583 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4584 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4585 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4587 precompute_head_matchings <=> true.
4589 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4590 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4592 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4593 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4595 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4596 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4597 <=>
4598 Q1 = NHeads,
4599 Q2 = Matchings.
4600 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4602 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4603 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4604 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4605 %-------------------------------------------------------------------------------%
4607 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4608 extract_arguments(Heads,Arguments),
4609 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4610 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4612 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4613 extract_arguments(Heads,Arguments),
4614 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4615 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4617 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4618 extract_arguments(Heads,Arguments1),
4619 extract_arguments(MatchingFreeHeads,Arguments2),
4620 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4622 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4623 %
4624 % Returns list of arguments of given list of constraints.
4625 extract_arguments([],[]).
4626 extract_arguments([Constraint|Constraints],AllArguments) :-
4627 Constraint =.. [_|Arguments],
4628 append(Arguments,RestArguments,AllArguments),
4629 extract_arguments(Constraints,RestArguments).
4631 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4632 %
4633 % Substitutes arguments of constraints with those in the given list.
4635 substitute_arguments([],[],[]).
4636 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4637 functor(Constraint,F,N),
4638 split_at(N,Variables,Arguments,RestVariables),
4639 NConstraint =.. [F|Arguments],
4640 substitute_arguments(Constraints,RestVariables,NConstraints).
4642 make_matchings_explicit([],[],_,MC,MC,[]).
4643 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4644 ( var(Arg) ->
4645 ( memberchk_eq(Arg,VarAcc) ->
4646 list2disj(MatchingCondition,MatchingCondition_disj),
4647 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4648 NVarAcc = VarAcc
4649 ;
4650 Matchings = RestMatchings,
4651 NewVar = Arg,
4652 NVarAcc = [Arg|VarAcc]
4653 ),
4654 MatchingCondition2 = MatchingCondition
4655 ;
4656 functor(Arg,F,A),
4657 Arg =.. [F|RecArgs],
4658 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4659 FlatArg =.. [F|RecVars],
4660 ( RecMatchings == [] ->
4661 Matchings = [functor(NewVar,F,A)|RestMatchings]
4662 ;
4663 list2conj(RecMatchings,ArgM_conj),
4664 list2disj(MatchingCondition,MatchingCondition_disj),
4665 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4666 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4667 ),
4668 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4669 term_variables(Args,ArgVars),
4670 append(ArgVars,VarAcc,NVarAcc)
4671 ),
4672 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4675 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4676 %
4677 % Returns list of new variables and list of pairwise unifications between given list and variables.
4679 make_matchings_explicit_not_negated([],[],[]).
4680 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4681 Matchings = [Var = X|RMatchings],
4682 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4684 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4685 %
4686 % (Partially) applies substitutions of =Goal= to given list.
4688 apply_guard_wrt_term([],_Guard,[]).
4689 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4690 ( var(Term) ->
4691 apply_guard_wrt_variable(Guard,Term,NTerm)
4692 ;
4693 Term =.. [F|HArgs],
4694 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4695 NTerm =.. [F|NewHArgs]
4696 ),
4697 apply_guard_wrt_term(RH,Guard,RGH).
4699 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4700 %
4701 % (Partially) applies goal =Guard= wrt variable.
4703 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4704 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4705 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4706 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4707 ( Guard = (X = Y), Variable == X ->
4708 NVariable = Y
4709 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4710 functor(NVariable,Functor,Arity)
4711 ;
4712 NVariable = Variable
4713 ).
4715 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4716 % ALWAYS FAILING HEADS
4717 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4719 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[])
4720 <=>
4721 chr_pp_flag(check_impossible_rules,on),
4722 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4723 append(M,GuardList,Info),
4724 guard_entailment:entails_guard(Info,fail)
4725 |
4726 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4727 set_all_passive(RuleNb).
4729 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4730 % HEAD SIMPLIFICATION
4731 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4733 % now we check the head matchings (guard may have been simplified meanwhile)
4734 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4735 <=>
4736 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4737 simplify_heads(M,GuardList,G,B,NewM,NewB),
4738 NewM \== [],
4739 extract_arguments(Head1,VH1),
4740 extract_arguments(Head2,VH2),
4741 extract_arguments(H,VH),
4742 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4743 substitute_arguments(Head1,H1,NewH1),
4744 substitute_arguments(Head2,H2,NewH2),
4745 append(NewB,NewB_,NewBody),
4746 list2conj(NewBody,BodyMatchings),
4747 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4748 (Head1 \== NewH1 ; Head2 \== NewH2 )
4749 |
4750 rule(RuleNb,NewRule).
4752 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4753 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4754 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4756 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4757 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4758 ( NH == M ->
4759 H2_ = M,
4760 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4761 ;
4762 (M = functor(X,F,A), NH == X ->
4763 length(A_args,A),
4764 (var(H2) ->
4765 NewB1 = [],
4766 H2_ =.. [F|A_args]
4767 ;
4768 H2 =.. [F|OrigArgs],
4769 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4770 H2_ =.. [F|A_args_]
4771 ),
4772 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4773 append(NewB1,NewB2,NewB)
4774 ;
4775 H2_ = H2,
4776 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4777 )
4778 ).
4780 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4781 ( NH == M ->
4782 H1_ = M,
4783 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4784 ;
4785 (M = functor(X,F,A), NH == X ->
4786 length(A_args,A),
4787 (var(H1) ->
4788 NewB1 = [],
4789 H1_ =.. [F|A_args]
4790 ;
4791 H1 =.. [F|OrigArgs],
4792 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4793 H1_ =.. [F|A_args_]
4794 ),
4795 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4796 append(NewB1,NewB2,NewB)
4797 ;
4798 H1_ = H1,
4799 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4800 )
4801 ).
4803 use_same_args([],[],[],_,_,[]).
4804 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4805 var(OA),!,
4806 Out = OA,
4807 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4808 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4809 nonvar(OA),!,
4810 ( common_variables(OA,Body) ->
4811 NewB = [NA = OA|NextB]
4812 ;
4813 NewB = NextB
4814 ),
4815 Out = NA,
4816 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4819 simplify_heads([],_GuardList,_G,_Body,[],[]).
4820 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4821 M = (A = B),
4822 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4823 guard_entailment:entails_guard(GuardList,(A=B)) ->
4824 ( common_variables(B,G-RM-GuardList) ->
4825 NewB = NextB,
4826 NewM = NextM
4827 ;
4828 ( common_variables(B,Body) ->
4829 NewB = [A = B|NextB]
4830 ;
4831 NewB = NextB
4832 ),
4833 NewM = [A|NextM]
4834 )
4835 ;
4836 ( nonvar(B), functor(B,BFu,BAr),
4837 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4838 NewB = NextB,
4839 ( common_variables(B,G-RM-GuardList) ->
4840 NewM = NextM
4841 ;
4842 NewM = [functor(A,BFu,BAr)|NextM]
4843 )
4844 ;
4845 NewM = NextM,
4846 NewB = NextB
4847 )
4848 ),
4849 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4851 common_variables(B,G) :-
4852 term_variables(B,BVars),
4853 term_variables(G,GVars),
4854 intersect_eq(BVars,GVars,L),
4855 L \== [].
4858 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4859 % ALWAYS FAILING GUARDS
4860 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4862 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4863 set_all_passive(_) <=> true.
4865 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4866 ==>
4867 chr_pp_flag(check_impossible_rules,on),
4868 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4869 conj2list(G,GL),
4870 % writeq(guard_entailment:entails_guard(GL,fail)),nl,
4871 guard_entailment:entails_guard(GL,fail)
4872 |
4873 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4874 set_all_passive(RuleNb).
4878 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4879 % OCCURRENCE SUBSUMPTION
4880 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4882 :- chr_constraint
4883 first_occ_in_rule/4,
4884 next_occ_in_rule/6.
4886 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4887 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4889 :- chr_constraint multiple_occ_constraints_checked/1.
4890 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4892 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4893 occurrence(C,O,RuleNb,ID,_),
4894 occurrence(C,O2,RuleNb,ID2,_),
4895 rule(RuleNb,Rule)
4896 \
4897 multiple_occ_constraints_checked(Done)
4898 <=>
4899 O < O2,
4900 chr_pp_flag(occurrence_subsumption,on),
4901 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4902 H1 \== [],
4903 \+ tree_set_memberchk(C,Done)
4904 |
4905 first_occ_in_rule(RuleNb,C,O,ID),
4906 tree_set_add(Done,C,NDone),
4907 multiple_occ_constraints_checked(NDone).
4909 % Find first occurrence of constraint =C= in rule =RuleNb=
4910 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4911 <=>
4912 O < O2
4913 |
4914 first_occ_in_rule(RuleNb,C,O,ID).
4916 first_occ_in_rule(RuleNb,C,O,ID_o1)
4917 <=>
4918 C = F/A,
4919 functor(FreshHead,F,A),
4920 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4922 % Skip passive occurrences.
4923 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4924 <=>
4925 O2 is O+1
4926 |
4927 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4929 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)
4930 <=>
4931 O2 is O+1,
4932 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4933 |
4934 append(H1,H2,Heads),
4935 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4936 ( ExtraCond == [chr_pp_void_info] ->
4937 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4938 ;
4939 append(ExtraCond,Cond,NewCond),
4940 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4941 copy_term(GuardList,FGuardList),
4942 variable_replacement(GuardList,FGuardList,GLRepl),
4943 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4944 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4945 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4946 append(NewCond,GuardList2,BigCond),
4947 append(BigCond,GuardList3,BigCond2),
4948 copy_with_variable_replacement(M,M2,Repl),
4949 copy_with_variable_replacement(M,M3,Repl2),
4950 append(M3,BigCond2,BigCond3),
4951 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4952 list2conj(CheckCond,OccSubsum),
4953 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4954 ( OccSubsum \= chr_pp_void_info ->
4955 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4956 passive(RuleNb,ID_o2)
4957 ;
4958 true
4959 )
4960 ;
4961 true
4962 ),!,
4963 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4964 ).
4967 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4968 <=>
4969 true.
4971 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4972 <=>
4973 true.
4975 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4976 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4977 append(ID2,ID1,IDs),
4978 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4979 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4980 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4981 copy_with_variable_replacement(G,FG,Repl),
4982 extract_explicit_matchings(FG,FG2),
4983 negate_b(FG2,NotFG),
4984 copy_with_variable_replacement(MPCond,FMPCond,Repl),
4985 ( subsumes(FH,FH2) ->
4986 FailCond = [(NotFG;FMPCond)]
4987 ;
4988 % in this case, not much can be done
4989 % e.g. c(f(...)), c(g(...)) <=> ...
4990 FailCond = [chr_pp_void_info]
4991 ).
4993 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4994 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4995 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4996 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4997 Cond = (chr_pp_not_in_store(H);Cond1),
4998 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5000 extract_explicit_matchings((A,B),D) :- !,
5001 ( extract_explicit_matchings(A) ->
5002 extract_explicit_matchings(B,D)
5003 ;
5004 D = (A,E),
5005 extract_explicit_matchings(B,E)
5006 ).
5007 extract_explicit_matchings(A,D) :- !,
5008 ( extract_explicit_matchings(A) ->
5009 D = true
5010 ;
5011 D = A
5012 ).
5014 extract_explicit_matchings(A=B) :-
5015 var(A), var(B), !, A=B.
5016 extract_explicit_matchings(A==B) :-
5017 var(A), var(B), !, A=B.
5019 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5020 % TYPE INFORMATION
5021 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5023 :- chr_constraint
5024 type_definition/2,
5025 type_alias/2,
5026 constraint_type/2,
5027 get_type_definition/2,
5028 get_constraint_type/2.
5031 :- chr_option(mode,type_definition(?,?)).
5032 :- chr_option(mode,get_type_definition(?,?)).
5033 :- chr_option(mode,type_alias(?,?)).
5034 :- chr_option(mode,constraint_type(+,+)).
5035 :- chr_option(mode,get_constraint_type(+,-)).
5037 assert_constraint_type(Constraint,ArgTypes) :-
5038 ( ground(ArgTypes) ->
5039 constraint_type(Constraint,ArgTypes)
5040 ;
5041 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5042 ).
5044 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5045 % Consistency checks of type aliases
5047 type_alias(T,T2) <=>
5048 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5049 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
5050 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5052 type_alias(T1,A1), type_alias(T2,A2) <=>
5053 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
5054 \+ (T1\=T2) |
5055 copy_term_nat(T1,T1_),
5056 copy_term_nat(T2,T2_),
5057 T1_ = T2_,
5058 chr_error(type_error,
5059 '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_]).
5061 type_alias(T,B) \ type_alias(X,T2) <=>
5062 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5063 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
5064 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5065 type_alias(X2,D1).
5067 oneway_unification(X,Y) :-
5068 term_variables(X,XVars),
5069 chr_runtime:lockv(XVars),
5070 X=Y,
5071 chr_runtime:unlockv(XVars).
5073 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5074 % Consistency checks of type definitions
5076 type_definition(T1,_), type_definition(T2,_)
5077 <=>
5078 functor(T1,F,A), functor(T2,F,A)
5079 |
5080 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5082 type_definition(T1,_), type_alias(T2,_)
5083 <=>
5084 functor(T1,F,A), functor(T2,F,A)
5085 |
5086 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5088 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5089 %% get_type_definition(+Type,-Definition) is semidet.
5090 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5092 get_type_definition(T,Def)
5093 <=>
5094 \+ ground(T)
5095 |
5096 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5098 type_alias(T,D) \ get_type_definition(T2,Def)
5099 <=>
5100 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5101 copy_term_nat((T,D),(T1,D1)),T1=T2
5102 |
5103 ( get_type_definition(D1,Def) ->
5104 true
5105 ;
5106 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5107 ).
5109 type_definition(T,D) \ get_type_definition(T2,Def)
5110 <=>
5111 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5112 copy_term_nat((T,D),(T1,D1)),T1=T2
5113 |
5114 Def = D1.
5116 get_type_definition(Type,Def)
5117 <=>
5118 atomic_builtin_type(Type,_,_)
5119 |
5120 Def = [Type].
5122 get_type_definition(Type,Def)
5123 <=>
5124 compound_builtin_type(Type,_,_,_)
5125 |
5126 Def = [Type].
5128 get_type_definition(X,Y) <=> fail.
5130 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5131 %% get_type_definition_det(+Type,-Definition) is det.
5132 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5133 get_type_definition_det(Type,Definition) :-
5134 ( get_type_definition(Type,Definition) ->
5135 true
5136 ;
5137 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5138 ).
5140 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5141 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5142 %
5143 % Return argument types of =ConstraintSymbol=, but fails if none where
5144 % declared.
5145 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5146 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5147 get_constraint_type(_,_) <=> fail.
5149 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5150 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5151 %
5152 % Like =get_constraint_type/2=, but returns list of =any= types when
5153 % no types are declared.
5154 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5155 get_constraint_type_det(ConstraintSymbol,Types) :-
5156 ( get_constraint_type(ConstraintSymbol,Types) ->
5157 true
5158 ;
5159 ConstraintSymbol = _ / N,
5160 replicate(N,any,Types)
5161 ).
5162 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5163 %% unalias_type(+Alias,-Type) is det.
5164 %
5165 % Follows alias chain until base type is reached.
5166 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5167 :- chr_constraint unalias_type/2.
5169 unalias_var @
5170 unalias_type(Alias,BaseType)
5171 <=>
5172 var(Alias)
5173 |
5174 BaseType = Alias.
5176 unalias_alias @
5177 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5178 <=>
5179 nonvar(AliasProtoType),
5180 nonvar(Alias),
5181 functor(AliasProtoType,F,A),
5182 functor(Alias,F,A),
5183 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5184 Alias = AliasInstance
5185 |
5186 unalias_type(Type,BaseType).
5188 unalias_type_definition @
5189 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5190 <=>
5191 nonvar(ProtoType),
5192 nonvar(Alias),
5193 functor(ProtoType,F,A),
5194 functor(Alias,F,A)
5195 |
5196 BaseType = Alias.
5198 unalias_atomic_builtin @
5199 unalias_type(Alias,BaseType)
5200 <=>
5201 atomic_builtin_type(Alias,_,_)
5202 |
5203 BaseType = Alias.
5205 unalias_compound_builtin @
5206 unalias_type(Alias,BaseType)
5207 <=>
5208 compound_builtin_type(Alias,_,_,_)
5209 |
5210 BaseType = Alias.
5212 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5213 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5214 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5215 :- chr_constraint types_modes_condition/3.
5216 :- chr_option(mode,types_modes_condition(+,+,?)).
5217 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5219 types_modes_condition([],[],T) <=> T=true.
5221 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5222 <=>
5223 functor(Head,F,A)
5224 |
5225 Head =.. [_|Args],
5226 Condition = (ModesCondition, TypesCondition, RestCondition),
5227 modes_condition(Modes,Args,ModesCondition),
5228 get_constraint_type_det(F/A,Types),
5229 UnrollHead =.. [_|RealArgs],
5230 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5231 types_modes_condition(Heads,UnrollHeads,RestCondition).
5233 types_modes_condition([Head|_],_,_)
5234 <=>
5235 functor(Head,F,A),
5236 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5239 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5240 %% modes_condition(+Modes,+Args,-Condition) is det.
5241 %
5242 % Return =Condition= on =Args= that checks =Modes=.
5243 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5244 modes_condition([],[],true).
5245 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5246 ( Mode == (+) ->
5247 Condition = ( ground(Arg) , RCondition )
5248 ; Mode == (-) ->
5249 Condition = ( var(Arg) , RCondition )
5250 ;
5251 Condition = RCondition
5252 ),
5253 modes_condition(Modes,Args,RCondition).
5255 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5256 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5257 %
5258 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5259 % =UnrollArgs= controls the depth of type definition unrolling.
5260 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5261 types_condition([],[],[],[],true).
5262 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5263 ( Mode == (-) ->
5264 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5265 ;
5266 get_type_definition_det(Type,Def),
5267 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5268 ( Mode == (+) ->
5269 TypeConditionList = TypeConditionList1
5270 ;
5271 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5272 )
5273 ),
5274 list2disj(TypeConditionList,DisjTypeConditionList),
5275 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5277 type_condition([],_,_,_,[]).
5278 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5279 ( var(DefCase) ->
5280 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5281 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5282 true
5283 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5284 true
5285 ;
5286 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5287 ),
5288 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5290 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5291 :- chr_type atomic_builtin_type ---> any
5292 ; number
5293 ; float
5294 ; int
5295 ; natural
5296 ; dense_int
5297 ; chr_identifier
5298 ; chr_identifier(any)
5299 ; /* all possible values are given */
5300 chr_enum(list(any))
5301 ; /* all possible values appear in rule heads;
5302 to distinguish between multiple chr_constants
5303 we have a key*/
5304 chr_constants(any).
5305 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5307 atomic_builtin_type(any,_Arg,true).
5308 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5309 atomic_builtin_type(int,Arg,integer(Arg)).
5310 atomic_builtin_type(number,Arg,number(Arg)).
5311 atomic_builtin_type(float,Arg,float(Arg)).
5312 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5313 atomic_builtin_type(chr_identifier,_Arg,true).
5315 compound_builtin_type(chr_constants(_),_Arg,true,true).
5316 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5317 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5318 once(( member(Constant,Constants),
5319 unifiable(Arg,Constant,_)
5320 )
5321 )
5322 ).
5324 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5325 ( nonvar(DefCase) ->
5326 functor(DefCase,F,A),
5327 ( A == 0 ->
5328 Condition = (Arg = DefCase)
5329 ; var(UnrollArg) ->
5330 Condition = functor(Arg,F,A)
5331 ; functor(UnrollArg,F,A) ->
5332 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5333 DefCase =.. [_|ArgTypes],
5334 UnrollArg =.. [_|UnrollArgs],
5335 functor(Template,F,A),
5336 Template =.. [_|TemplateArgs],
5337 replicate(A,Mode,ArgModes),
5338 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5339 ;
5340 Condition = functor(Arg,F,A)
5341 )
5342 ;
5343 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5344 ).
5347 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5348 % STATIC TYPE CHECKING
5349 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5350 % Checks head constraints and CHR constraint calls in bodies.
5351 %
5352 % TODO:
5353 % - type clashes involving built-in types
5354 % - Prolog built-ins in guard and body
5355 % - indicate position in terms in error messages
5356 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5357 :- chr_constraint
5358 static_type_check/0.
5361 % 1. Check the declared types
5363 constraint_type(Constraint,ArgTypes), static_type_check
5364 ==>
5365 forall(
5366 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5367 ( get_type_definition(Type,_) ->
5368 true
5369 ;
5370 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5371 )
5372 ).
5374 % 2. Check the rules
5376 :- chr_type type_error_src ---> head(any) ; body(any).
5378 rule(_,Rule), static_type_check
5379 ==>
5380 copy_term_nat(Rule,RuleCopy),
5381 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5382 (
5383 catch(
5384 ( static_type_check_heads(Head1),
5385 static_type_check_heads(Head2),
5386 conj2list(Body,GoalList),
5387 static_type_check_body(GoalList)
5388 ),
5389 type_error(Error),
5390 ( Error = invalid_functor(Src,Term,Type) ->
5391 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5392 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5393 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5394 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5395 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5396 )
5397 ),
5398 fail % cleanup constraints
5399 ;
5400 true
5401 ).
5404 static_type_check <=> true.
5406 static_type_check_heads([]).
5407 static_type_check_heads([Head|Heads]) :-
5408 static_type_check_head(Head),
5409 static_type_check_heads(Heads).
5411 static_type_check_head(Head) :-
5412 functor(Head,F,A),
5413 get_constraint_type_det(F/A,Types),
5414 Head =..[_|Args],
5415 maplist(static_type_check_term(head(Head)),Args,Types).
5417 static_type_check_body([]).
5418 static_type_check_body([Goal|Goals]) :-
5419 functor(Goal,F,A),
5420 get_constraint_type_det(F/A,Types),
5421 Goal =..[_|Args],
5422 maplist(static_type_check_term(body(Goal)),Args,Types),
5423 static_type_check_body(Goals).
5425 :- chr_constraint static_type_check_term/3.
5426 :- chr_option(mode,static_type_check_term(?,?,?)).
5427 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5429 static_type_check_term(Src,Term,Type)
5430 <=>
5431 var(Term)
5432 |
5433 static_type_check_var(Src,Term,Type).
5434 static_type_check_term(Src,Term,Type)
5435 <=>
5436 atomic_builtin_type(Type,Term,Goal)
5437 |
5438 ( call(Goal) ->
5439 true
5440 ;
5441 throw(type_error(invalid_functor(Src,Term,Type)))
5442 ).
5443 static_type_check_term(Src,Term,Type)
5444 <=>
5445 compound_builtin_type(Type,Term,_,Goal)
5446 |
5447 ( call(Goal) ->
5448 true
5449 ;
5450 throw(type_error(invalid_functor(Src,Term,Type)))
5451 ).
5452 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5453 <=>
5454 functor(Type,F,A),
5455 functor(AType,F,A)
5456 |
5457 copy_term_nat(AType-ADef,Type-Def),
5458 static_type_check_term(Src,Term,Def).
5460 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5461 <=>
5462 functor(Type,F,A),
5463 functor(AType,F,A)
5464 |
5465 copy_term_nat(AType-ADef,Type-Variants),
5466 functor(Term,TF,TA),
5467 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5468 Term =.. [_|Args],
5469 Variant =.. [_|Types],
5470 maplist(static_type_check_term(Src),Args,Types)
5471 ;
5472 throw(type_error(invalid_functor(Src,Term,Type)))
5473 ).
5475 static_type_check_term(Src,Term,Type)
5476 <=>
5477 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5479 :- chr_constraint static_type_check_var/3.
5480 :- chr_option(mode,static_type_check_var(?,-,?)).
5481 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5483 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5484 <=>
5485 functor(AType,F,A),
5486 functor(Type,F,A)
5487 |
5488 copy_term_nat(AType-ADef,Type-Def),
5489 static_type_check_var(Src,Var,Def).
5491 static_type_check_var(Src,Var,Type)
5492 <=>
5493 atomic_builtin_type(Type,_,_)
5494 |
5495 static_atomic_builtin_type_check_var(Src,Var,Type).
5497 static_type_check_var(Src,Var,Type)
5498 <=>
5499 compound_builtin_type(Type,_,_,_)
5500 |
5501 true.
5504 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5505 <=>
5506 Type1 \== Type2
5507 |
5508 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5510 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5511 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5512 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5513 :- chr_constraint static_atomic_builtin_type_check_var/3.
5514 :- chr_option(mode,static_type_check_var(?,-,+)).
5515 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5517 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5518 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5519 <=>
5520 true.
5521 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5522 <=>
5523 true.
5524 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5525 <=>
5526 true.
5527 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5528 <=>
5529 true.
5530 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5531 <=>
5532 true.
5533 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5534 <=>
5535 true.
5536 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5537 <=>
5538 true.
5539 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5540 <=>
5541 true.
5542 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5543 <=>
5544 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5546 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5547 %% format_src(+type_error_src) is det.
5548 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5549 format_src(head(Head)) :- format('head ~w',[Head]).
5550 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5552 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5553 % Dynamic type checking
5554 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5556 :- chr_constraint
5557 dynamic_type_check/0,
5558 dynamic_type_check_clauses/1,
5559 get_dynamic_type_check_clauses/1.
5561 generate_dynamic_type_check_clauses(Clauses) :-
5562 ( chr_pp_flag(debugable,on) ->
5563 dynamic_type_check,
5564 get_dynamic_type_check_clauses(Clauses0),
5565 append(Clauses0,
5566 [('$dynamic_type_check'(Type,Term) :-
5567 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5568 )],
5569 Clauses)
5570 ;
5571 Clauses = []
5572 ).
5574 type_definition(T,D), dynamic_type_check
5575 ==>
5576 copy_term_nat(T-D,Type-Definition),
5577 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5578 dynamic_type_check_clauses(DynamicChecks).
5579 type_alias(A,B), dynamic_type_check
5580 ==>
5581 copy_term_nat(A-B,Alias-Body),
5582 dynamic_type_check_alias_clause(Alias,Body,Clause),
5583 dynamic_type_check_clauses([Clause]).
5585 dynamic_type_check <=>
5586 findall(
5587 ('$dynamic_type_check'(Type,Term) :- Goal),
5588 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5589 BuiltinChecks
5590 ),
5591 dynamic_type_check_clauses(BuiltinChecks).
5593 dynamic_type_check_clause(T,DC,Clause) :-
5594 copy_term(T-DC,Type-DefinitionClause),
5595 functor(DefinitionClause,F,A),
5596 functor(Term,F,A),
5597 DefinitionClause =.. [_|DCArgs],
5598 Term =.. [_|TermArgs],
5599 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5600 list2conj(RecursiveCallList,RecursiveCalls),
5601 Clause = (
5602 '$dynamic_type_check'(Type,Term) :-
5603 RecursiveCalls
5604 ).
5606 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5607 Clause = (
5608 '$dynamic_type_check'(Alias,Term) :-
5609 '$dynamic_type_check'(Body,Term)
5610 ).
5612 dynamic_type_check_call(Type,Term,Call) :-
5613 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5614 % Call = when(nonvar(Term),Goal)
5615 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5616 % Call = when(nonvar(Term),Goal)
5617 % ;
5618 ( Type == any ->
5619 Call = true
5620 ;
5621 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5622 )
5623 % )
5624 .
5626 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5627 <=>
5628 append(C1,C2,C),
5629 dynamic_type_check_clauses(C).
5631 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5632 <=>
5633 Q = C.
5634 get_dynamic_type_check_clauses(Q)
5635 <=>
5636 Q = [].
5638 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5639 % Atomic Types
5640 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5641 % Some optimizations can be applied for atomic types...
5642 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5644 atomic_types_suspended_constraint(C) :-
5645 C = _/N,
5646 get_constraint_type(C,ArgTypes),
5647 get_constraint_mode(C,ArgModes),
5648 findall(I,between(1,N,I),Indexes),
5649 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5651 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5652 ( is_indexed_argument(C,Index) ->
5653 ( Mode == (?) ->
5654 atomic_type(Type)
5655 ;
5656 true
5657 )
5658 ;
5659 true
5660 ).
5662 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5663 %% atomic_type(+Type) is semidet.
5664 %
5665 % Succeeds when all values of =Type= are atomic.
5666 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5667 :- chr_constraint atomic_type/1.
5669 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5671 type_definition(TypePat,Def) \ atomic_type(Type)
5672 <=>
5673 functor(Type,F,A), functor(TypePat,F,A)
5674 |
5675 maplist(atomic,Def).
5677 type_alias(TypePat,Alias) \ atomic_type(Type)
5678 <=>
5679 functor(Type,F,A), functor(TypePat,F,A)
5680 |
5681 atomic(Alias),
5682 copy_term_nat(TypePat-Alias,Type-NType),
5683 atomic_type(NType).
5685 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5686 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5687 %
5688 % Succeeds when all values of =Type= are atomic
5689 % and the atom values are finitely enumerable.
5690 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5691 :- chr_constraint enumerated_atomic_type/2.
5693 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5695 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5696 <=>
5697 functor(Type,F,A), functor(TypePat,F,A)
5698 |
5699 maplist(atomic,Def),
5700 Atoms = Def.
5702 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5703 <=>
5704 functor(Type,F,A), functor(TypePat,F,A)
5705 |
5706 atomic(Alias),
5707 copy_term_nat(TypePat-Alias,Type-NType),
5708 enumerated_atomic_type(NType,Atoms).
5709 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5711 :- chr_constraint
5712 stored/3, % constraint,occurrence,(yes/no/maybe)
5713 stored_completing/3,
5714 stored_complete/3,
5715 is_stored/1,
5716 is_finally_stored/1,
5717 check_all_passive/2.
5719 :- chr_option(mode,stored(+,+,+)).
5720 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5721 :- chr_type storedinfo ---> yes ; no ; maybe.
5722 :- chr_option(mode,stored_complete(+,+,+)).
5723 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5724 :- chr_option(mode,guard_list(+,+,+,+)).
5725 :- chr_option(mode,check_all_passive(+,+)).
5726 :- chr_option(type_declaration,check_all_passive(any,list)).
5728 % change yes in maybe when yes becomes passive
5729 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5730 stored(C,O,yes), stored_complete(C,RO,Yesses)
5731 <=> O < RO | NYesses is Yesses - 1,
5732 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5733 % change yes in maybe when not observed
5734 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5735 <=> O < RO |
5736 NYesses is Yesses - 1,
5737 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5739 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5740 ==> RO =< MO2 | % C2 is never stored
5741 passive(RuleNb,ID).
5746 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5748 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5749 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5750 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5752 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5753 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5754 check_all_passive(RuleNb,IDs2).
5756 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5757 check_all_passive(RuleNb,IDs).
5759 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5760 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5762 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5764 % collect the storage information
5765 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5766 <=> NO is O + 1, NYesses is Yesses + 1,
5767 stored_completing(C,NO,NYesses).
5768 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5769 <=> NO is O + 1,
5770 stored_completing(C,NO,Yesses).
5772 stored(C,O,no) \ stored_completing(C,O,Yesses)
5773 <=> stored_complete(C,O,Yesses).
5774 stored_completing(C,O,Yesses)
5775 <=> stored_complete(C,O,Yesses).
5777 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5778 O2 > O | passive(RuleNb,Id).
5780 % decide whether a constraint is stored
5781 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5782 <=> RO =< MO | fail.
5783 is_stored(C) <=> true.
5785 % decide whether a constraint is suspends after occurrences
5786 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5787 <=> RO =< MO | fail.
5788 is_finally_stored(C) <=> true.
5790 storage_analysis(Constraints) :-
5791 ( chr_pp_flag(storage_analysis,on) ->
5792 check_constraint_storages(Constraints)
5793 ;
5794 true
5795 ).
5797 check_constraint_storages([]).
5798 check_constraint_storages([C|Cs]) :-
5799 check_constraint_storage(C),
5800 check_constraint_storages(Cs).
5802 check_constraint_storage(C) :-
5803 get_max_occurrence(C,MO),
5804 check_occurrences_storage(C,1,MO).
5806 check_occurrences_storage(C,O,MO) :-
5807 ( O > MO ->
5808 stored_completing(C,1,0)
5809 ;
5810 check_occurrence_storage(C,O),
5811 NO is O + 1,
5812 check_occurrences_storage(C,NO,MO)
5813 ).
5815 check_occurrence_storage(C,O) :-
5816 get_occurrence(C,O,RuleNb,ID),
5817 ( is_passive(RuleNb,ID) ->
5818 stored(C,O,maybe)
5819 ;
5820 get_rule(RuleNb,PragmaRule),
5821 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5822 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5823 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5824 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5825 check_storage_head2(Head2,O,Heads1,Body)
5826 )
5827 ).
5829 check_storage_head1(Head,O,H1,H2,G) :-
5830 functor(Head,F,A),
5831 C = F/A,
5832 ( H1 == [Head],
5833 H2 == [],
5834 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5835 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5836 Head =.. [_|L],
5837 no_matching(L,[]) ->
5838 stored(C,O,no)
5839 ;
5840 stored(C,O,maybe)
5841 ).
5843 no_matching([],_).
5844 no_matching([X|Xs],Prev) :-
5845 var(X),
5846 \+ memberchk_eq(X,Prev),
5847 no_matching(Xs,[X|Prev]).
5849 check_storage_head2(Head,O,H1,B) :-
5850 functor(Head,F,A),
5851 C = F/A,
5852 ( %(
5853 ( H1 \== [], B == true )
5854 %;
5855 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5856 %)
5857 ->
5858 stored(C,O,maybe)
5859 ;
5860 stored(C,O,yes)
5861 ).
5863 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5865 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5866 %% ____ _ ____ _ _ _ _
5867 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5868 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5869 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5870 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5871 %% |_|
5873 constraints_code(Constraints,Clauses) :-
5874 (chr_pp_flag(reduced_indexing,on),
5875 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5876 none_suspended_on_variables
5877 ;
5878 true
5879 ),
5880 constraints_code1(Constraints,Clauses,[]).
5882 %===============================================================================
5883 :- chr_constraint constraints_code1/3.
5884 :- chr_option(mode,constraints_code1(+,+,+)).
5885 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5886 %-------------------------------------------------------------------------------
5887 constraints_code1([],L,T) <=> L = T.
5888 constraints_code1([C|RCs],L,T)
5889 <=>
5890 constraint_code(C,L,T1),
5891 constraints_code1(RCs,T1,T).
5892 %===============================================================================
5893 :- chr_constraint constraint_code/3.
5894 :- chr_option(mode,constraint_code(+,+,+)).
5895 %-------------------------------------------------------------------------------
5896 %% Generate code for a single CHR constraint
5897 constraint_code(Constraint, L, T)
5898 <=> true
5899 | ( (chr_pp_flag(debugable,on) ;
5900 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5901 ( may_trigger(Constraint) ;
5902 get_allocation_occurrence(Constraint,AO),
5903 get_max_occurrence(Constraint,MO), MO >= AO ) )
5904 ->
5905 constraint_prelude(Constraint,Clause),
5906 add_dummy_location(Clause,LocatedClause),
5907 L = [LocatedClause | L1]
5908 ;
5909 L = L1
5910 ),
5911 Id = [0],
5912 occurrences_code(Constraint,1,Id,NId,L1,L2),
5913 gen_cond_attach_clause(Constraint,NId,L2,T).
5915 %===============================================================================
5916 %% Generate prelude predicate for a constraint.
5917 %% f(...) :- f/a_0(...,Susp).
5918 constraint_prelude(F/A, Clause) :-
5919 vars_susp(A,Vars,Susp,VarsSusp),
5920 Head =.. [ F | Vars],
5921 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5922 build_head(F,A,[0],VarsSusp,Delegate),
5923 ( chr_pp_flag(debugable,on) ->
5924 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5925 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5926 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5927 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5929 ( get_constraint_type(F/A,ArgTypeList) ->
5930 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5931 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5932 ;
5933 DynamicTypeChecks = true
5934 ),
5936 Clause =
5937 ( Head :-
5938 DynamicTypeChecks,
5939 InsertGoal,
5940 InsertCall,
5941 AttachCall,
5942 Inactive,
5943 'chr debug_event'(insert(Head#Susp)),
5944 (
5945 'chr debug_event'(call(Susp)),
5946 Delegate
5947 ;
5948 'chr debug_event'(fail(Susp)), !,
5949 fail
5950 ),
5951 (
5952 'chr debug_event'(exit(Susp))
5953 ;
5954 'chr debug_event'(redo(Susp)),
5955 fail
5956 )
5957 )
5958 ; get_allocation_occurrence(F/A,0) ->
5959 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5960 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5961 Clause = ( Head :- Goal, Inactive, Delegate )
5962 ;
5963 Clause = ( Head :- Delegate )
5964 ).
5966 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5967 ( may_trigger(F/A) ->
5968 build_head(F,A,[0],VarsSusp,Delegate),
5969 ( chr_pp_flag(debugable,off) ->
5970 Goal = Delegate
5971 ;
5972 get_target_module(Mod),
5973 Goal = Mod:Delegate
5974 )
5975 ;
5976 Goal = true
5977 ).
5979 %===============================================================================
5980 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5981 :- chr_option(mode,has_active_occurrence(+)).
5982 :- chr_option(mode,has_active_occurrence(+,+)).
5983 %-------------------------------------------------------------------------------
5984 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5986 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5987 O > MO | fail.
5988 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5989 has_active_occurrence(C,O) <=>
5990 NO is O + 1,
5991 has_active_occurrence(C,NO).
5992 has_active_occurrence(C,O) <=> true.
5993 %===============================================================================
5995 gen_cond_attach_clause(F/A,Id,L,T) :-
5996 ( is_finally_stored(F/A) ->
5997 get_allocation_occurrence(F/A,AllocationOccurrence),
5998 get_max_occurrence(F/A,MaxOccurrence),
5999 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6000 ( only_ground_indexed_arguments(F/A) ->
6001 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6002 ;
6003 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6004 )
6005 ; vars_susp(A,Args,Susp,AllArgs),
6006 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6007 ),
6008 build_head(F,A,Id,AllArgs,Head),
6009 Clause = ( Head :- Body ),
6010 add_dummy_location(Clause,LocatedClause),
6011 L = [LocatedClause | T]
6012 ;
6013 L = T
6014 ).
6016 :- chr_constraint use_auxiliary_predicate/1.
6017 :- chr_option(mode,use_auxiliary_predicate(+)).
6019 :- chr_constraint use_auxiliary_predicate/2.
6020 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6022 :- chr_constraint is_used_auxiliary_predicate/1.
6023 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6025 :- chr_constraint is_used_auxiliary_predicate/2.
6026 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6029 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6031 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6033 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6035 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6037 is_used_auxiliary_predicate(P) <=> fail.
6039 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6040 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6042 is_used_auxiliary_predicate(P,C) <=> fail.
6044 %------------------------------------------------------------------------------%
6045 % Only generate import statements for actually used modules.
6046 %------------------------------------------------------------------------------%
6048 :- chr_constraint use_auxiliary_module/1.
6049 :- chr_option(mode,use_auxiliary_module(+)).
6051 :- chr_constraint is_used_auxiliary_module/1.
6052 :- chr_option(mode,is_used_auxiliary_module(+)).
6055 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6057 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6059 is_used_auxiliary_module(P) <=> fail.
6061 % only called for constraints with
6062 % at least one
6063 % non-ground indexed argument
6064 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6065 vars_susp(A,Args,Susp,AllArgs),
6066 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6067 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6068 Attach = true
6069 ;
6070 attach_constraint_atom(F/A,Vars,Susp,Attach)
6071 ),
6072 FTerm =.. [F|Args],
6073 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6074 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6075 ( may_trigger(F/A) ->
6076 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6077 Goal =
6078 (
6079 ( var(Susp) ->
6080 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6081 InsertCall,
6082 Attach
6083 ;
6084 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6085 )
6086 )
6087 ;
6088 Goal =
6089 (
6090 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6091 InsertCall,
6092 Attach
6093 )
6094 ).
6096 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6097 vars_susp(A,Args,Susp,AllArgs),
6098 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6099 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6100 attach_constraint_atom(F/A,Vars,Susp,Attach)
6101 ;
6102 Attach = true
6103 ),
6104 FTerm =.. [F|Args],
6105 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6106 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6107 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6108 Goal =
6109 (
6110 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6111 InsertCall
6112 )
6113 ;
6114 Goal =
6115 (
6116 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6117 InsertCall,
6118 Attach
6119 )
6120 ).
6122 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6123 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6124 attach_constraint_atom(FA,Vars,Susp,Attach)
6125 ;
6126 Attach = true
6127 ),
6128 insert_constraint_goal(FA,Susp,Args,InsertCall),
6129 ( chr_pp_flag(late_allocation,on) ->
6130 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6131 ;
6132 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6133 ).
6135 %-------------------------------------------------------------------------------
6136 :- chr_constraint occurrences_code/6.
6137 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6138 %-------------------------------------------------------------------------------
6139 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6140 <=> O > MO
6141 | NId = Id, L = T.
6142 occurrences_code(C,O,Id,NId,L,T)
6143 <=>
6144 occurrence_code(C,O,Id,Id1,L,L1),
6145 NO is O + 1,
6146 occurrences_code(C,NO,Id1,NId,L1,T).
6147 %-------------------------------------------------------------------------------
6148 :- chr_constraint occurrence_code/6.
6149 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6150 %-------------------------------------------------------------------------------
6151 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6152 <=>
6153 ( named_history(RuleNb,_,_) ->
6154 does_use_history(C,O)
6155 ;
6156 true
6157 ),
6158 NId = Id,
6159 L = T.
6160 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6161 <=> true |
6162 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6163 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6164 NId = Id,
6165 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6166 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6168 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6169 ( should_skip_to_next_id(C,O) ->
6170 inc_id(Id,NId),
6171 ( unconditional_occurrence(C,O) ->
6172 L1 = T
6173 ;
6174 gen_alloc_inc_clause(C,O,Id,L1,T)
6175 )
6176 ;
6177 NId = Id,
6178 L1 = T
6179 )
6180 ).
6182 occurrence_code(C,O,_,_,_,_)
6183 <=>
6184 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6185 %-------------------------------------------------------------------------------
6187 %% Generate code based on one removed head of a CHR rule
6188 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6189 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6190 Rule = rule(_,Head2,_,_),
6191 ( Head2 == [] ->
6192 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6193 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6194 ;
6195 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6196 ).
6198 %% Generate code based on one persistent head of a CHR rule
6199 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6200 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6201 Rule = rule(Head1,_,_,_),
6202 ( Head1 == [] ->
6203 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6204 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6205 ;
6206 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6207 ).
6209 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6210 vars_susp(A,Vars,Susp,VarsSusp),
6211 build_head(F,A,Id,VarsSusp,Head),
6212 inc_id(Id,IncId),
6213 build_head(F,A,IncId,VarsSusp,CallHead),
6214 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6215 Clause =
6216 (
6217 Head :-
6218 ConditionalAlloc,
6219 CallHead
6220 ),
6221 add_dummy_location(Clause,LocatedClause),
6222 L = [LocatedClause|T].
6224 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6225 get_allocation_occurrence(FA,AO),
6226 get_occurrence_code_id(FA,AO,AId),
6227 get_occurrence_code_id(FA,O,Id),
6228 ( chr_pp_flag(debugable,off), Id == AId ->
6229 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6230 ( may_trigger(FA) ->
6231 Goal = (var(Susp) -> Goal0 ; true)
6232 ;
6233 Goal = Goal0
6234 )
6235 ;
6236 Goal = true
6237 ).
6239 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6240 get_allocation_occurrence(FA,AO),
6241 ( chr_pp_flag(debugable,off), O < AO ->
6242 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6243 ( may_trigger(FA) ->
6244 Goal = (var(Susp) -> Goal0 ; true)
6245 ;
6246 Goal = Goal0
6247 )
6248 ;
6249 Goal = true
6250 ).
6252 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6254 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6255 %
6256 % Reorders guard goals with respect to partner constraint retrieval goals and
6257 % active constraint. Returns combined partner retrieval + guard goal.
6259 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6260 ( chr_pp_flag(guard_via_reschedule,on) ->
6261 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6262 list2conj(ScheduleSkeleton,GoalSkeleton)
6263 ;
6264 length(Retrievals,RL), length(LookupSkeleton,RL),
6265 length(GuardList,GL), length(GuardListSkeleton,GL),
6266 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6267 list2conj(GoalListSkeleton,GoalSkeleton)
6268 ).
6269 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6270 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6271 initialize_unit_dictionary(ActiveHead,Dict),
6272 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6273 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6274 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6275 dependency_reorder(Units,NUnits),
6276 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6277 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6278 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6280 wrappedunits2lists([],[],[],[]).
6281 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6282 Ss = [GoalCopy|TSs],
6283 ( WrappedGoal = lookup(Goal) ->
6284 Ls = [GoalCopy|TLs],
6285 Gs = TGs
6286 ; WrappedGoal = guard(Goal) ->
6287 Gs = [N-GoalCopy|TGs],
6288 Ls = TLs
6289 ),
6290 wrappedunits2lists(Units,TGs,TLs,TSs).
6292 guard_splitting(Rule,SplitGuardList) :-
6293 Rule = rule(H1,H2,Guard,_),
6294 append(H1,H2,Heads),
6295 conj2list(Guard,GuardList),
6296 term_variables(Heads,HeadVars),
6297 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6298 append(GuardPrefix,[RestGuard],SplitGuardList),
6299 term_variables(RestGuardList,GuardVars1),
6300 % variables that are declared to be ground don't need to be locked
6301 ground_vars(Heads,GroundVars),
6302 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6303 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6304 ( chr_pp_flag(guard_locks,on),
6305 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6306 once(pairup(Locks,Unlocks,LocksUnlocks))
6307 ;
6308 Locks = [],
6309 Unlocks = []
6310 ),
6311 list2conj(Locks,LockPhase),
6312 list2conj(Unlocks,UnlockPhase),
6313 list2conj(RestGuardList,RestGuard1),
6314 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6316 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6317 Rule = rule(_,_,_,Body),
6318 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6319 my_term_copy(Body,VarDict2,BodyCopy).
6322 split_off_simple_guard_new([],_,[],[]).
6323 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6324 ( simple_guard_new(G,VarDict) ->
6325 S = [G|Ss],
6326 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6327 ;
6328 S = [],
6329 C = [G|Gs]
6330 ).
6332 % simple guard: cheap and benign (does not bind variables)
6333 simple_guard_new(G,Vars) :-
6334 builtin_binds_b(G,BoundVars),
6335 \+ (( member(V,BoundVars),
6336 memberchk_eq(V,Vars)
6337 )).
6339 dependency_reorder(Units,NUnits) :-
6340 dependency_reorder(Units,[],NUnits).
6342 dependency_reorder([],Acc,Result) :-
6343 reverse(Acc,Result).
6345 dependency_reorder([Unit|Units],Acc,Result) :-
6346 Unit = unit(_GID,_Goal,Type,GIDs),
6347 ( Type == fixed ->
6348 NAcc = [Unit|Acc]
6349 ;
6350 dependency_insert(Acc,Unit,GIDs,NAcc)
6351 ),
6352 dependency_reorder(Units,NAcc,Result).
6354 dependency_insert([],Unit,_,[Unit]).
6355 dependency_insert([X|Xs],Unit,GIDs,L) :-
6356 X = unit(GID,_,_,_),
6357 ( memberchk(GID,GIDs) ->
6358 L = [Unit,X|Xs]
6359 ;
6360 L = [X | T],
6361 dependency_insert(Xs,Unit,GIDs,T)
6362 ).
6364 build_units(Retrievals,Guard,InitialDict,Units) :-
6365 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6366 build_guard_units(Guard,N,Dict,Tail).
6368 build_retrieval_units([],N,N,Dict,Dict,L,L).
6369 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6370 term_variables(U,Vs),
6371 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6372 L = [unit(N,U,fixed,GIDs)|L1],
6373 N1 is N + 1,
6374 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6376 initialize_unit_dictionary(Term,Dict) :-
6377 term_variables(Term,Vars),
6378 pair_all_with(Vars,0,Dict).
6380 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6381 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6382 ( lookup_eq(Dict,V,GID) ->
6383 ( (GID == This ; memberchk(GID,GIDs) ) ->
6384 GIDs1 = GIDs
6385 ;
6386 GIDs1 = [GID|GIDs]
6387 ),
6388 Dict1 = Dict
6389 ;
6390 Dict1 = [V - This|Dict],
6391 GIDs1 = GIDs
6392 ),
6393 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6395 build_guard_units(Guard,N,Dict,Units) :-
6396 ( Guard = [Goal] ->
6397 Units = [unit(N,Goal,fixed,[])]
6398 ; Guard = [Goal|Goals] ->
6399 term_variables(Goal,Vs),
6400 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6401 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6402 N1 is N + 1,
6403 build_guard_units(Goals,N1,NDict,RUnits)
6404 ).
6406 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6407 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6408 ( lookup_eq(Dict,V,GID) ->
6409 ( (GID == This ; memberchk(GID,GIDs) ) ->
6410 GIDs1 = GIDs
6411 ;
6412 GIDs1 = [GID|GIDs]
6413 ),
6414 Dict1 = [V - This|Dict]
6415 ;
6416 Dict1 = [V - This|Dict],
6417 GIDs1 = GIDs
6418 ),
6419 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6424 %% ____ _ ____ _ _
6425 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6426 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6427 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6428 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6429 %%
6430 %% _ _ _ ___ __
6431 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6432 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6433 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6434 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6435 %% |_|
6436 :- chr_constraint
6437 functional_dependency/4,
6438 get_functional_dependency/4.
6440 :- chr_option(mode,functional_dependency(+,+,?,?)).
6441 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6443 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6444 <=>
6445 RuleNb > 1, AO > O
6446 |
6447 functional_dependency(C,1,Pattern,Key).
6449 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6450 <=>
6451 RuleNb2 >= RuleNb1
6452 |
6453 QPattern = Pattern, QKey = Key.
6454 get_functional_dependency(_,_,_,_)
6455 <=>
6456 fail.
6458 functional_dependency_analysis(Rules) :-
6459 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6460 functional_dependency_analysis_main(Rules)
6461 ;
6462 true
6463 ).
6465 functional_dependency_analysis_main([]).
6466 functional_dependency_analysis_main([PRule|PRules]) :-
6467 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6468 functional_dependency(C,RuleNb,Pattern,Key)
6469 ;
6470 true
6471 ),
6472 functional_dependency_analysis_main(PRules).
6474 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6475 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6476 Rule = rule(H1,H2,Guard,_),
6477 ( H1 = [C1],
6478 H2 = [C2] ->
6479 true
6480 ; H1 = [C1,C2],
6481 H2 == [] ->
6482 true
6483 ),
6484 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6485 term_variables(C1,Vs),
6486 \+ (
6487 member(V1,Vs),
6488 lookup_eq(List,V1,V2),
6489 memberchk_eq(V2,Vs)
6490 ),
6491 select_pragma_unique_variables(Vs,List,Key1),
6492 copy_term_nat(C1-Key1,Pattern-Key),
6493 functor(C1,F,A).
6495 select_pragma_unique_variables([],_,[]).
6496 select_pragma_unique_variables([V|Vs],List,L) :-
6497 ( lookup_eq(List,V,_) ->
6498 L = T
6499 ;
6500 L = [V|T]
6501 ),
6502 select_pragma_unique_variables(Vs,List,T).
6504 % depends on functional dependency analysis
6505 % and shape of rule: C1 \ C2 <=> true.
6506 set_semantics_rules(Rules) :-
6507 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6508 set_semantics_rules_main(Rules)
6509 ;
6510 true
6511 ).
6513 set_semantics_rules_main([]).
6514 set_semantics_rules_main([R|Rs]) :-
6515 set_semantics_rule_main(R),
6516 set_semantics_rules_main(Rs).
6518 set_semantics_rule_main(PragmaRule) :-
6519 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6520 ( Rule = rule([C1],[C2],true,_),
6521 IDs = ids([ID1],[ID2]),
6522 \+ is_passive(RuleNb,ID1),
6523 functor(C1,F,A),
6524 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6525 copy_term_nat(Pattern-Key,C1-Key1),
6526 copy_term_nat(Pattern-Key,C2-Key2),
6527 Key1 == Key2 ->
6528 passive(RuleNb,ID2)
6529 ;
6530 true
6531 ).
6533 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6534 \+ any_passive_head(RuleNb),
6535 variable_replacement(C1-C2,C2-C1,List),
6536 copy_with_variable_replacement(G,OtherG,List),
6537 negate_b(G,NotG),
6538 once(entails_b(NotG,OtherG)).
6540 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6541 % where C1 and C2 are symmteric constraints
6542 symmetry_analysis(Rules) :-
6543 ( chr_pp_flag(check_unnecessary_active,off) ->
6544 true
6545 ;
6546 symmetry_analysis_main(Rules)
6547 ).
6549 symmetry_analysis_main([]).
6550 symmetry_analysis_main([R|Rs]) :-
6551 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6552 Rule = rule(H1,H2,_,_),
6553 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6554 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6555 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6556 ;
6557 true
6558 ),
6559 symmetry_analysis_main(Rs).
6561 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6562 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6563 ( \+ is_passive(RuleNb,ID),
6564 member2(PreHs,PreIDs,PreH-PreID),
6565 \+ is_passive(RuleNb,PreID),
6566 variable_replacement(PreH,H,List),
6567 copy_with_variable_replacement(Rule,Rule2,List),
6568 identical_guarded_rules(Rule,Rule2) ->
6569 passive(RuleNb,ID)
6570 ;
6571 true
6572 ),
6573 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6575 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6576 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6577 ( \+ is_passive(RuleNb,ID),
6578 member2(PreHs,PreIDs,PreH-PreID),
6579 \+ is_passive(RuleNb,PreID),
6580 variable_replacement(PreH,H,List),
6581 copy_with_variable_replacement(Rule,Rule2,List),
6582 identical_rules(Rule,Rule2) ->
6583 passive(RuleNb,ID)
6584 ;
6585 true
6586 ),
6587 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6589 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6591 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6592 %% ____ _ _ _ __ _ _ _
6593 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6594 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6595 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6596 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6597 %% |_|
6598 %% {{{
6600 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6601 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6602 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6603 build_head(F,A,Id,HeadVars,ClauseHead),
6604 get_constraint_mode(F/A,Mode),
6605 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6608 guard_splitting(Rule,GuardList0),
6609 ( is_stored_in_guard(F/A, RuleNb) ->
6610 GuardList = [Hole1|GuardList0]
6611 ;
6612 GuardList = GuardList0
6613 ),
6614 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6616 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6618 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6620 ( is_stored_in_guard(F/A, RuleNb) ->
6621 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6622 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6623 GuardCopyList = [Hole1Copy|_],
6624 Hole1Copy = (Allocation, Attachment)
6625 ;
6626 true
6627 ),
6630 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6631 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6633 ( chr_pp_flag(debugable,on) ->
6634 Rule = rule(_,_,Guard,Body),
6635 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6636 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6637 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6638 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6639 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6640 ;
6641 Cut = ActualCut
6642 ),
6643 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6644 Clause = ( ClauseHead :-
6645 FirstMatching,
6646 RescheduledTest,
6647 Cut,
6648 SuspsDetachments,
6649 SuspDetachment,
6650 BodyCopy
6651 ),
6652 add_location(Clause,RuleNb,LocatedClause),
6653 L = [LocatedClause | T].
6655 % }}}
6657 add_location(Clause,RuleNb,NClause) :-
6658 ( chr_pp_flag(line_numbers,on) ->
6659 get_chr_source_file(File),
6660 get_line_number(RuleNb,LineNb),
6661 NClause = '$source_location'(File,LineNb):Clause
6662 ;
6663 NClause = Clause
6664 ).
6666 add_dummy_location(Clause,NClause) :-
6667 ( chr_pp_flag(line_numbers,on) ->
6668 get_chr_source_file(File),
6669 NClause = '$source_location'(File,1):Clause
6670 ;
6671 NClause = Clause
6672 ).
6673 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6674 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6675 %
6676 % Return goal matching newly introduced variables with variables in
6677 % previously looked-up heads.
6678 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6679 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6680 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6682 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6683 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6684 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6685 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6686 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6687 list2conj(GoalList,Goal).
6689 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6690 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6691 ( var(Arg) ->
6692 ( lookup_eq(VarDict,Arg,OtherVar) ->
6693 ( Mode = (+) ->
6694 ( memberchk_eq(Arg,GroundVars) ->
6695 GoalList = [Var = OtherVar | RestGoalList],
6696 GroundVars1 = GroundVars
6697 ;
6698 GoalList = [Var == OtherVar | RestGoalList],
6699 GroundVars1 = [Arg|GroundVars]
6700 )
6701 ;
6702 GoalList = [Var == OtherVar | RestGoalList],
6703 GroundVars1 = GroundVars
6704 ),
6705 VarDict1 = VarDict
6706 ;
6707 VarDict1 = [Arg-Var | VarDict],
6708 GoalList = RestGoalList,
6709 ( Mode = (+) ->
6710 GroundVars1 = [Arg|GroundVars]
6711 ;
6712 GroundVars1 = GroundVars
6713 )
6714 ),
6715 Pairs = Rest,
6716 RestModes = Modes
6717 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6718 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6719 GoalList = [Goal|RestGoalList],
6720 VarDict = VarDict1,
6721 GroundVars1 = GroundVars,
6722 Pairs = Rest,
6723 RestModes = Modes
6724 ; atomic(Arg) ->
6725 ( Mode = (+) ->
6726 GoalList = [ Var = Arg | RestGoalList]
6727 ;
6728 GoalList = [ Var == Arg | RestGoalList]
6729 ),
6730 VarDict = VarDict1,
6731 GroundVars1 = GroundVars,
6732 Pairs = Rest,
6733 RestModes = Modes
6734 ; Mode == (+), is_ground(GroundVars,Arg) ->
6735 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6736 GoalList = [ Var = ArgCopy | RestGoalList],
6737 VarDict = VarDict1,
6738 GroundVars1 = GroundVars,
6739 Pairs = Rest,
6740 RestModes = Modes
6741 ; Mode == (?), is_ground(GroundVars,Arg) ->
6742 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6743 GoalList = [ Var == ArgCopy | RestGoalList],
6744 VarDict = VarDict1,
6745 GroundVars1 = GroundVars,
6746 Pairs = Rest,
6747 RestModes = Modes
6748 ; Arg =.. [_|Args],
6749 functor(Arg,Fct,N),
6750 functor(Term,Fct,N),
6751 Term =.. [_|Vars],
6752 ( Mode = (+) ->
6753 GoalList = [ Var = Term | RestGoalList ]
6754 ;
6755 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6756 ),
6757 pairup(Args,Vars,NewPairs),
6758 append(NewPairs,Rest,Pairs),
6759 replicate(N,Mode,NewModes),
6760 append(NewModes,Modes,RestModes),
6761 VarDict1 = VarDict,
6762 GroundVars1 = GroundVars
6763 ),
6764 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6766 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6767 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6768 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6769 add_heads_types([],VarTypes,VarTypes).
6770 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6771 add_head_types(Head,VarTypes,VarTypes1),
6772 add_heads_types(Heads,VarTypes1,NVarTypes).
6774 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6775 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6776 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6777 add_head_types(Head,VarTypes,NVarTypes) :-
6778 functor(Head,F,A),
6779 get_constraint_type_det(F/A,ArgTypes),
6780 Head =.. [_|Args],
6781 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6783 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6784 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6785 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6786 add_args_types([],[],VarTypes,VarTypes).
6787 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6788 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6789 add_args_types(Args,Types,VarTypes1,NVarTypes).
6791 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6792 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6793 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6794 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6795 ( var(Term) ->
6796 ( lookup_eq(VarTypes,Term,_) ->
6797 NVarTypes = VarTypes
6798 ;
6799 NVarTypes = [Term-Type|VarTypes]
6800 )
6801 ; ground(Term) ->
6802 NVarTypes = VarTypes
6803 ; % TODO improve approximation!
6804 term_variables(Term,Vars),
6805 length(Vars,VarNb),
6806 replicate(VarNb,any,Types),
6807 add_args_types(Vars,Types,VarTypes,NVarTypes)
6808 ).
6812 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6813 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6814 %
6815 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6816 add_heads_ground_variables([],GroundVars,GroundVars).
6817 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6818 add_head_ground_variables(Head,GroundVars,GroundVars1),
6819 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6821 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6822 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6823 %
6824 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6825 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6826 functor(Head,F,A),
6827 get_constraint_mode(F/A,ArgModes),
6828 Head =.. [_|Args],
6829 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6832 add_arg_ground_variables([],[],GroundVars,GroundVars).
6833 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6834 ( Mode == (+) ->
6835 term_variables(Arg,Vars),
6836 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6837 ;
6838 GroundVars = GroundVars1
6839 ),
6840 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6842 add_var_ground_variables([],GroundVars,GroundVars).
6843 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6844 ( memberchk_eq(Var,GroundVars) ->
6845 GroundVars1 = GroundVars
6846 ;
6847 GroundVars1 = [Var|GroundVars]
6848 ),
6849 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6850 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6851 %% is_ground(+GroundVars,+Term) is semidet.
6852 %
6853 % Determine whether =Term= is always ground.
6854 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6855 is_ground(GroundVars,Term) :-
6856 ( ground(Term) ->
6857 true
6858 ; compound(Term) ->
6859 Term =.. [_|Args],
6860 maplist(is_ground(GroundVars),Args)
6861 ;
6862 memberchk_eq(Term,GroundVars)
6863 ).
6865 %% check_ground(+GroundVars,+Term,-Goal) is det.
6866 %
6867 % Return runtime check to see whether =Term= is ground.
6868 check_ground(GroundVars,Term,Goal) :-
6869 term_variables(Term,Variables),
6870 check_ground_variables(Variables,GroundVars,Goal).
6872 check_ground_variables([],_,true).
6873 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6874 ( memberchk_eq(Var,GroundVars) ->
6875 check_ground_variables(Vars,GroundVars,Goal)
6876 ;
6877 Goal = (ground(Var), RGoal),
6878 check_ground_variables(Vars,GroundVars,RGoal)
6879 ).
6881 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6882 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6884 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6885 ( Heads = [_|_] ->
6886 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6887 ;
6888 GoalList = [],
6889 Susps = [],
6890 VarDict = NVarDict,
6891 GroundVars = NGroundVars
6892 ).
6894 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6895 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6896 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6897 functor(H,F,A),
6898 head_info(H,A,Vars,_,_,Pairs),
6899 get_store_type(F/A,StoreType),
6900 ( StoreType == default ->
6901 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6902 delay_phase_end(validate_store_type_assumptions,
6903 ( static_suspension_term(F/A,Suspension),
6904 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6905 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6906 )
6907 ),
6908 % create_get_mutable_ref(active,State,GetMutable),
6909 get_constraint_mode(F/A,Mode),
6910 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6911 NPairs = Pairs,
6912 sbag_member_call(Susp,VarSusps,Sbag),
6913 ExistentialLookup = (
6914 ViaGoal,
6915 Sbag,
6916 Susp = Suspension, % not inlined
6917 GetState
6918 )
6919 ;
6920 delay_phase_end(validate_store_type_assumptions,
6921 ( static_suspension_term(F/A,Suspension),
6922 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6923 )
6924 ),
6925 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6926 get_constraint_mode(F/A,Mode),
6927 filter_mode(NPairs,Pairs,Mode,NMode),
6928 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6929 ),
6930 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6931 append(NPairs,VarDict1,DA_), % order important here
6932 translate(GroundVars1,DA_,GroundVarsA),
6933 translate(GroundVars1,VarDict1,GroundVarsB),
6934 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6935 Goal =
6936 (
6937 ExistentialLookup,
6938 DiffSuspGoals,
6939 MatchingGoal2
6940 ),
6941 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6943 inline_matching_goal(A==B,true,GVA,GVB) :-
6944 memberchk_eq(A,GVA),
6945 memberchk_eq(B,GVB),
6946 A=B, !.
6948 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6949 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6950 inline_matching_goal(A,A2,GVA,GVB),
6951 inline_matching_goal(B,B2,GVA,GVB).
6952 inline_matching_goal(X,X,_,_).
6955 filter_mode([],_,_,[]).
6956 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6957 ( Var == V ->
6958 Modes = [M|MT],
6959 filter_mode(Rest,R,Ms,MT)
6960 ;
6961 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6962 ).
6964 check_unique_keys([],_).
6965 check_unique_keys([V|Vs],Dict) :-
6966 lookup_eq(Dict,V,_),
6967 check_unique_keys(Vs,Dict).
6969 % Generates tests to ensure the found constraint differs from previously found constraints
6970 % TODO: detect more cases where constraints need be different
6971 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6972 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6973 list2conj(DiffSuspGoalList,DiffSuspGoals).
6975 different_from_other_susps_(_,[],_,_,[]) :- !.
6976 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6977 ( functor(Head,F,A), functor(PreHead,F,A),
6978 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6979 \+ \+ PreHeadCopy = HeadCopy ->
6981 List = [Susp \== PreSusp | Tail]
6982 ;
6983 List = Tail
6984 ),
6985 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6987 % passive_head_via(in,in,in,in,out,out,out) :-
6988 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6989 functor(Head,F,A),
6990 get_constraint_index(F/A,Pos),
6991 common_variables(Head,PrevHeads,CommonVars),
6992 global_list_store_name(F/A,Name),
6993 GlobalGoal = nb_getval(Name,AllSusps),
6994 get_constraint_mode(F/A,ArgModes),
6995 ( Vars == [] ->
6996 Goal = GlobalGoal
6997 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6998 translate([CommonVar],VarDict,[Var]),
6999 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7000 Goal = AttrGoal
7001 ;
7002 translate(CommonVars,VarDict,Vars),
7003 add_heads_types(PrevHeads,[],TypeDict),
7004 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7005 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7006 Goal =
7007 ( ViaGoal ->
7008 AttrGoal
7009 ;
7010 GlobalGoal
7011 )
7012 ).
7014 common_variables(T,Ts,Vs) :-
7015 term_variables(T,V1),
7016 term_variables(Ts,V2),
7017 intersect_eq(V1,V2,Vs).
7019 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7020 get_target_module(Mod),
7021 ( Vars = [A] ->
7022 lookup_eq(TypeDict,A,Type),
7023 ( atomic_type(Type) ->
7024 ViaGoal = var(A),
7025 A = V
7026 ;
7027 ViaGoal = 'chr newvia_1'(A,V)
7028 )
7029 ; Vars = [A,B] ->
7030 ViaGoal = 'chr newvia_2'(A,B,V)
7031 ;
7032 ViaGoal = 'chr newvia'(Vars,V)
7033 ),
7034 AttrGoal =
7035 ( get_attr(V,Mod,TSusps),
7036 TSuspsEqSusps % TSusps = Susps
7037 ),
7038 get_max_constraint_index(N),
7039 ( N == 1 ->
7040 TSuspsEqSusps = true, % TSusps = Susps
7041 AllSusps = TSusps
7042 ;
7043 get_constraint_index(FA,Pos),
7044 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7045 ).
7046 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7047 get_target_module(Mod),
7048 AttrGoal =
7049 ( get_attr(Var,Mod,TSusps),
7050 TSuspsEqSusps % TSusps = Susps
7051 ),
7052 get_max_constraint_index(N),
7053 ( N == 1 ->
7054 TSuspsEqSusps = true, % TSusps = Susps
7055 AllSusps = TSusps
7056 ;
7057 get_constraint_index(FA,Pos),
7058 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7059 ).
7061 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7062 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7063 list2conj(GuardCopyList,GuardCopy).
7065 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7066 Rule = rule(_,H,Guard,Body),
7067 conj2list(Guard,GuardList),
7068 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7069 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7071 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7072 term_variables(RestGuardList,GuardVars),
7073 term_variables(RestGuardListCopyCore,GuardCopyVars),
7074 % variables that are declared to be ground don't need to be locked
7075 ground_vars(H,GroundVars),
7076 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7077 ( chr_pp_flag(guard_locks,on),
7078 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7079 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7080 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7081 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7082 ),
7083 LocksUnlocks) ->
7084 once(pairup(Locks,Unlocks,LocksUnlocks))
7085 ;
7086 Locks = [],
7087 Unlocks = []
7088 ),
7089 list2conj(Locks,LockPhase),
7090 list2conj(Unlocks,UnlockPhase),
7091 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7092 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7093 my_term_copy(Body,VarDict2,BodyCopy).
7096 split_off_simple_guard([],_,[],[]).
7097 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7098 ( simple_guard(G,VarDict) ->
7099 S = [G|Ss],
7100 split_off_simple_guard(Gs,VarDict,Ss,C)
7101 ;
7102 S = [],
7103 C = [G|Gs]
7104 ).
7106 % simple guard: cheap and benign (does not bind variables)
7107 simple_guard(G,VarDict) :-
7108 binds_b(G,Vars),
7109 \+ (( member(V,Vars),
7110 lookup_eq(VarDict,V,_)
7111 )).
7113 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7114 functor(Head,F,A),
7115 C = F/A,
7116 ( is_stored(C) ->
7117 (
7118 (
7119 Id == [0], chr_pp_flag(store_in_guards, off)
7120 ;
7121 ( get_allocation_occurrence(C,AO),
7122 get_max_occurrence(C,MO),
7123 MO < AO )
7124 ),
7125 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7126 SuspDetachment = true
7127 ;
7128 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7129 ( chr_pp_flag(late_allocation,on) ->
7130 SuspDetachment =
7131 ( var(Susp) ->
7132 true
7133 ;
7134 UnCondSuspDetachment
7135 )
7136 ;
7137 SuspDetachment = UnCondSuspDetachment
7138 )
7139 )
7140 ;
7141 SuspDetachment = true
7142 ).
7144 partner_constraint_detachments([],[],_,true).
7145 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7146 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7147 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7149 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7150 functor(Head,F,A),
7151 C = F/A,
7152 ( is_stored(C) ->
7153 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7154 ( chr_pp_flag(debugable,on) ->
7155 DebugEvent = 'chr debug_event'(remove(Susp))
7156 ;
7157 DebugEvent = true
7158 ),
7159 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7160 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7161 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7162 detach_constraint_atom(C,Vars,Susp,Detach)
7163 ;
7164 Detach = true
7165 )
7166 ;
7167 SuspDetachment = true
7168 ).
7170 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7173 %% ____ _ _ _ _
7174 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7175 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7176 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7177 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7178 %% |_| |___/
7179 %% {{{
7181 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7182 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7183 Rule = rule(_Heads,Heads2,Guard,Body),
7185 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7186 get_constraint_mode(F/A,Mode),
7187 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7189 build_head(F,A,Id,HeadVars,ClauseHead),
7191 append(RestHeads,Heads2,Heads),
7192 append(OtherIDs,Heads2IDs,IDs),
7193 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7195 guard_splitting(Rule,GuardList0),
7196 ( is_stored_in_guard(F/A, RuleNb) ->
7197 GuardList = [Hole1|GuardList0]
7198 ;
7199 GuardList = GuardList0
7200 ),
7201 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7203 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7204 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7206 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7208 ( is_stored_in_guard(F/A, RuleNb) ->
7209 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7210 GuardCopyList = [Hole1Copy|_],
7211 Hole1Copy = Attachment
7212 ;
7213 true
7214 ),
7216 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7217 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7218 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7220 ( chr_pp_flag(debugable,on) ->
7221 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7222 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7223 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7224 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7225 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7226 instrument_goal((!),DebugTry,DebugApply,Cut)
7227 ;
7228 Cut = (!)
7229 ),
7231 Clause = ( ClauseHead :-
7232 FirstMatching,
7233 RescheduledTest,
7234 Cut,
7235 SuspsDetachments,
7236 SuspDetachment,
7237 BodyCopy
7238 ),
7239 add_location(Clause,RuleNb,LocatedClause),
7240 L = [LocatedClause | T].
7242 % }}}
7244 split_by_ids([],[],_,[],[]).
7245 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7246 ( memberchk_eq(I,I1s) ->
7247 S1s = [S | R1s],
7248 S2s = R2s
7249 ;
7250 S1s = R1s,
7251 S2s = [S | R2s]
7252 ),
7253 split_by_ids(Is,Ss,I1s,R1s,R2s).
7255 split_by_ids([],[],_,[],[],[],[]).
7256 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7257 ( memberchk_eq(I,I1s) ->
7258 S1s = [S | R1s],
7259 SI1s = [I|RSI1s],
7260 S2s = R2s,
7261 SI2s = RSI2s
7262 ;
7263 S1s = R1s,
7264 SI1s = RSI1s,
7265 S2s = [S | R2s],
7266 SI2s = [I|RSI2s]
7267 ),
7268 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7269 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7272 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7273 %% ____ _ _ _ ____
7274 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7275 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7276 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7277 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7278 %% |_| |___/
7280 %% Genereate prelude + worker predicate
7281 %% prelude calls worker
7282 %% worker iterates over one type of removed constraints
7283 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7284 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7285 Rule = rule(Heads1,_,Guard,Body),
7286 append(Heads1,RestHeads2,Heads),
7287 append(IDs1,RestIDs,IDs),
7288 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7289 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7290 extend_id(Id,Id1),
7291 ( memberchk_eq(NID,IDs2) ->
7292 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7293 ;
7294 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7295 ),
7296 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7297 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7299 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7300 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7301 Heads = [Head|RHeads],
7302 inc_id(Id,Id1),
7303 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7304 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7305 ( memberchk_eq(ID,IDs2) ->
7306 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7307 ;
7308 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7309 ).
7311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7312 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7313 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7314 build_head(F,A,Id1,VarsSusp,ClauseHead),
7315 get_constraint_mode(F/A,Mode),
7316 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7318 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7320 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7322 extend_id(Id1,DelegateId),
7323 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7324 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7325 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7327 PreludeClause =
7328 ( ClauseHead :-
7329 FirstMatching,
7330 ModConstraintsGoal,
7331 !,
7332 ConstraintAllocationGoal,
7333 Delegate
7334 ),
7335 add_dummy_location(PreludeClause,LocatedPreludeClause),
7336 L = [LocatedPreludeClause|T].
7338 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7339 Term =.. [_|Args],
7340 delegate_variables(Term,Terms,VarDict,Args,Vars).
7342 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7343 term_variables(PrevTerms,PrevVars),
7344 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7346 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7347 term_variables(Term,V1),
7348 term_variables(Terms,V2),
7349 intersect_eq(V1,V2,V3),
7350 list_difference_eq(V3,PrevVars,V4),
7351 translate(V4,VarDict,Vars).
7354 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7355 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7356 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7357 Rule = rule(_,_,Guard,Body),
7358 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7360 gen_var(OtherSusp),
7361 gen_var(OtherSusps),
7363 functor(CurrentHead,OtherF,OtherA),
7364 gen_vars(OtherA,OtherVars),
7365 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7366 get_constraint_mode(OtherF/OtherA,Mode),
7367 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7369 delay_phase_end(validate_store_type_assumptions,
7370 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7371 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7372 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7373 )
7374 ),
7375 % create_get_mutable_ref(active,State,GetMutable),
7376 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7377 CurrentSuspTest = (
7378 OtherSusp = OtherSuspension,
7379 GetState,
7380 DiffSuspGoals,
7381 FirstMatching
7382 ),
7384 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7385 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7387 guard_splitting(Rule,GuardList0),
7388 ( is_stored_in_guard(F/A, RuleNb) ->
7389 GuardList = [Hole1|GuardList0]
7390 ;
7391 GuardList = GuardList0
7392 ),
7393 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7395 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7396 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7397 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7399 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7401 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7402 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7403 RecursiveVars2 = [[]|PreVarsAndSusps],
7404 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7406 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7407 ( is_stored_in_guard(F/A, RuleNb) ->
7408 GuardCopyList = [GuardAttachment|_] % once( ) ??
7409 ;
7410 true
7411 ),
7413 ( is_observed(F/A,O) ->
7414 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7415 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7416 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7417 ;
7418 Attachment = true,
7419 ConditionalRecursiveCall = RecursiveCall,
7420 ConditionalRecursiveCall2 = RecursiveCall2
7421 ),
7423 ( chr_pp_flag(debugable,on) ->
7424 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7425 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7426 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7427 ;
7428 DebugTry = true,
7429 DebugApply = true
7430 ),
7432 ( is_stored_in_guard(F/A, RuleNb) ->
7433 GuardAttachment = Attachment,
7434 BodyAttachment = true
7435 ;
7436 GuardAttachment = true,
7437 BodyAttachment = Attachment % will be true if not observed at all
7438 ),
7440 ( member(unique(ID1,UniqueKeys), Pragmas),
7441 check_unique_keys(UniqueKeys,VarDict) ->
7442 Clause =
7443 ( ClauseHead :-
7444 ( CurrentSuspTest ->
7445 ( RescheduledTest,
7446 DebugTry ->
7447 DebugApply,
7448 Susps1Detachments,
7449 BodyAttachment,
7450 BodyCopy,
7451 ConditionalRecursiveCall2
7452 ;
7453 RecursiveCall2
7454 )
7455 ;
7456 RecursiveCall
7457 )
7458 )
7459 ;
7460 Clause =
7461 ( ClauseHead :-
7462 ( CurrentSuspTest,
7463 RescheduledTest,
7464 DebugTry ->
7465 DebugApply,
7466 Susps1Detachments,
7467 BodyAttachment,
7468 BodyCopy,
7469 ConditionalRecursiveCall
7470 ;
7471 RecursiveCall
7472 )
7473 )
7474 ),
7475 add_location(Clause,RuleNb,LocatedClause),
7476 L = [LocatedClause | T].
7478 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7479 ( may_trigger(FA) ->
7480 does_use_field(FA,generation),
7481 delay_phase_end(validate_store_type_assumptions,
7482 ( static_suspension_term(FA,Suspension),
7483 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7484 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7485 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7486 )
7487 )
7488 ;
7489 delay_phase_end(validate_store_type_assumptions,
7490 ( static_suspension_term(FA,Suspension),
7491 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7492 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7493 )
7494 ),
7495 GetGeneration = true
7496 ),
7497 ConditionalCall =
7498 ( Susp = Suspension,
7499 GetState,
7500 GetGeneration ->
7501 UpdateState,
7502 Call
7503 ;
7504 true
7505 ).
7507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7511 %% ____ _ _
7512 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7513 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7514 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7515 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7516 %% |_| |___/
7518 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7519 ( RestHeads == [] ->
7520 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7521 ;
7522 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7523 ).
7524 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7525 %% Single headed propagation
7526 %% everything in a single clause
7527 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7528 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7529 build_head(F,A,Id,VarsSusp,ClauseHead),
7531 inc_id(Id,NextId),
7532 build_head(F,A,NextId,VarsSusp,NextHead),
7534 get_constraint_mode(F/A,Mode),
7535 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7536 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7538 % - recursive call -
7539 RecursiveCall = NextHead,
7541 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7542 ActualCut = true
7543 ;
7544 ActualCut = !
7545 ),
7547 Rule = rule(_,_,Guard,Body),
7548 ( chr_pp_flag(debugable,on) ->
7549 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7550 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7551 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7552 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7553 ;
7554 Cut = ActualCut
7555 ),
7556 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7557 use_auxiliary_predicate(novel_production),
7558 use_auxiliary_predicate(extend_history),
7559 does_use_history(F/A,O),
7560 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7562 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7563 ( HistoryIDs == [] ->
7564 empty_named_history_novel_production(HistoryName,NovelProduction),
7565 empty_named_history_extend_history(HistoryName,ExtendHistory)
7566 ;
7567 Tuple = HistoryName
7568 )
7569 ;
7570 Tuple = RuleNb
7571 ),
7573 ( var(NovelProduction) ->
7574 NovelProduction = '$novel_production'(Susp,Tuple),
7575 ExtendHistory = '$extend_history'(Susp,Tuple)
7576 ;
7577 true
7578 ),
7580 ( is_observed(F/A,O) ->
7581 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7582 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7583 ;
7584 Attachment = true,
7585 ConditionalRecursiveCall = RecursiveCall
7586 )
7587 ;
7588 Allocation = true,
7589 NovelProduction = true,
7590 ExtendHistory = true,
7592 ( is_observed(F/A,O) ->
7593 get_allocation_occurrence(F/A,AllocO),
7594 ( O == AllocO ->
7595 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7596 Generation = 0
7597 ; % more room for improvement?
7598 Attachment = (Attachment1, Attachment2),
7599 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7600 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7601 ),
7602 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7603 ;
7604 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7605 ConditionalRecursiveCall = RecursiveCall
7606 )
7607 ),
7609 ( is_stored_in_guard(F/A, RuleNb) ->
7610 GuardAttachment = Attachment,
7611 BodyAttachment = true
7612 ;
7613 GuardAttachment = true,
7614 BodyAttachment = Attachment % will be true if not observed at all
7615 ),
7617 Clause = (
7618 ClauseHead :-
7619 HeadMatching,
7620 Allocation,
7621 NovelProduction,
7622 GuardAttachment,
7623 GuardCopy,
7624 Cut,
7625 ExtendHistory,
7626 BodyAttachment,
7627 BodyCopy,
7628 ConditionalRecursiveCall
7629 ),
7630 add_location(Clause,RuleNb,LocatedClause),
7631 ProgramList = [LocatedClause | ProgramTail].
7633 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7634 %% multi headed propagation
7635 %% prelude + predicates to accumulate the necessary combinations of suspended
7636 %% constraints + predicate to execute the body
7637 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7638 RestHeads = [First|Rest],
7639 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7640 extend_id(Id,ExtendedId),
7641 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7643 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7644 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7645 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7646 build_head(F,A,Id,VarsSusp,PreludeHead),
7647 get_constraint_mode(F/A,Mode),
7648 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7649 Rule = rule(_,_,Guard,Body),
7650 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7652 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7654 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7656 extend_id(Id,NestedId),
7657 append([Susps|VarsSusp],ExtraVars,NestedVars),
7658 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7659 NestedCall = NestedHead,
7661 Prelude = (
7662 PreludeHead :-
7663 FirstMatching,
7664 FirstSuspGoal,
7665 !,
7666 CondAllocation,
7667 NestedCall
7668 ),
7669 add_dummy_location(Prelude,LocatedPrelude),
7670 L = [LocatedPrelude|T].
7672 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7673 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7674 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7675 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7677 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7678 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7679 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7680 inc_id(Id,IncId),
7681 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7683 %check_fd_lookup_condition(_,_,_,_) :- fail.
7684 check_fd_lookup_condition(F,A,_,_) :-
7685 get_store_type(F/A,global_singleton), !.
7686 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7687 \+ may_trigger(F/A),
7688 get_functional_dependency(F/A,1,P,K),
7689 copy_term(P-K,CurrentHead-Key),
7690 term_variables(PreHeads,PreVars),
7691 intersect_eq(Key,PreVars,Key),!.
7693 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7694 Rule = rule(_,H2,Guard,Body),
7695 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7696 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7697 init(AllSusps,RestSusps),
7698 last(AllSusps,Susp),
7699 gen_var(OtherSusp),
7700 gen_var(OtherSusps),
7701 functor(CurrentHead,OtherF,OtherA),
7702 gen_vars(OtherA,OtherVars),
7703 delay_phase_end(validate_store_type_assumptions,
7704 ( static_suspension_term(OtherF/OtherA,Suspension),
7705 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7706 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7707 )
7708 ),
7709 % create_get_mutable_ref(active,State,GetMutable),
7710 CurrentSuspTest = (
7711 OtherSusp = Suspension,
7712 GetState
7713 ),
7714 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7715 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7716 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7717 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7718 RecursiveVars = PreVarsAndSusps1
7719 ;
7720 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7721 PrevId0 = Id
7722 ),
7723 ( PrevId0 = [_] ->
7724 PrevId = PrevId0
7725 ;
7726 PrevId = [O|PrevId0]
7727 ),
7728 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7729 RecursiveCall = RecursiveHead,
7730 CurrentHead =.. [_|OtherArgs],
7731 pairup(OtherArgs,OtherVars,OtherPairs),
7732 get_constraint_mode(OtherF/OtherA,Mode),
7733 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7735 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7736 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7737 get_occurrence(F/A,O,_,ID),
7739 ( is_observed(F/A,O) ->
7740 init(FirstVarsSusp,FirstVars),
7741 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7742 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7743 ;
7744 Attachment = true,
7745 ConditionalRecursiveCall = RecursiveCall
7746 ),
7747 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7748 NovelProduction = true,
7749 ExtendHistory = true
7750 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7751 NovelProduction = true,
7752 ExtendHistory = true
7753 ;
7754 get_occurrence(F/A,O,_,ID),
7755 use_auxiliary_predicate(novel_production),
7756 use_auxiliary_predicate(extend_history),
7757 does_use_history(F/A,O),
7758 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7759 ( HistoryIDs == [] ->
7760 empty_named_history_novel_production(HistoryName,NovelProduction),
7761 empty_named_history_extend_history(HistoryName,ExtendHistory)
7762 ;
7763 reverse([OtherSusp|RestSusps],NamedSusps),
7764 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7765 HistorySusps = [HistorySusp|_],
7767 ( length(HistoryIDs, 1) ->
7768 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7769 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7770 ;
7771 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7772 Tuple =.. [t,HistoryName|HistorySusps]
7773 )
7774 )
7775 ;
7776 HistorySusp = Susp,
7777 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
7778 sort([ID|RestIDs],HistoryIDs),
7779 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7780 Tuple =.. [t,RuleNb|HistorySusps]
7781 ),
7783 ( var(NovelProduction) ->
7784 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7785 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7786 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7787 ;
7788 true
7789 )
7790 ),
7793 ( chr_pp_flag(debugable,on) ->
7794 Rule = rule(_,_,Guard,Body),
7795 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7796 get_occurrence(F/A,O,_,ID),
7797 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7798 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7799 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7800 ;
7801 DebugTry = true,
7802 DebugApply = true
7803 ),
7805 ( is_stored_in_guard(F/A, RuleNb) ->
7806 GuardAttachment = Attachment,
7807 BodyAttachment = true
7808 ;
7809 GuardAttachment = true,
7810 BodyAttachment = Attachment % will be true if not observed at all
7811 ),
7813 Clause = (
7814 ClauseHead :-
7815 ( CurrentSuspTest,
7816 DiffSuspGoals,
7817 Matching,
7818 NovelProduction,
7819 GuardAttachment,
7820 GuardCopy,
7821 DebugTry ->
7822 DebugApply,
7823 ExtendHistory,
7824 BodyAttachment,
7825 BodyCopy,
7826 ConditionalRecursiveCall
7827 ; RecursiveCall
7828 )
7829 ),
7830 add_location(Clause,RuleNb,LocatedClause),
7831 L = [LocatedClause|T].
7833 novel_production_calls([],[],[],_,_,true).
7834 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7835 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7836 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7837 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7839 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7840 reverse(ReversedRestSusps,RestSusps),
7841 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7843 named_history_susps([],_,_,[]).
7844 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7845 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7846 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7850 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7851 !,
7852 functor(Head,F,A),
7853 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7854 get_constraint_mode(F/A,Mode),
7855 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7856 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7857 append(VarsSusp,ExtraVars,HeadVars).
7858 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7859 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7860 functor(Head,F,A),
7861 gen_var(Susps),
7862 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7863 get_constraint_mode(F/A,Mode),
7864 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7865 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7866 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7868 % returns
7869 % VarDict for the copies of variables in the original heads
7870 % VarsSuspsList list of lists of arguments for the successive heads
7871 % FirstVarsSusp top level arguments
7872 % SuspList list of all suspensions
7873 % Iterators list of all iterators
7874 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7875 !,
7876 functor(Head,F,A),
7877 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7878 get_constraint_mode(F/A,Mode),
7879 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7880 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7881 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7882 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7883 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7884 functor(Head,F,A),
7885 gen_var(Susps),
7886 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7887 get_constraint_mode(F/A,Mode),
7888 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7889 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7890 append(HeadVars,[Susp,Susps],Vars).
7892 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7893 !,
7894 functor(Head,F,A),
7895 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7896 get_constraint_mode(F/A,Mode),
7897 head_arg_matches(Pairs,Mode,[],_,VarDict),
7898 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7899 append(VarsSusp,ExtraVars,HeadVars).
7900 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7901 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
7902 functor(Head,F,A),
7903 gen_var(Susps),
7904 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
7905 get_constraint_mode(F/A,Mode),
7906 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
7907 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7908 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
7910 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7912 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7913 %% ____ _ _ _ _
7914 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
7915 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7916 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
7917 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7918 %%
7919 %% ____ _ _ _
7920 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
7921 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7922 %% | _ < __/ |_| | | | __/\ V / (_| | |
7923 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
7924 %%
7925 %% ____ _ _
7926 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
7927 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7928 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
7929 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
7930 %% |___/
7932 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7933 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7934 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7935 ;
7936 NRestHeads = RestHeads,
7937 NRestIDs = RestIDs
7938 ).
7940 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7941 term_variables(Head,Vars),
7942 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7943 copy_term_nat(InitialData,InitialDataCopy),
7944 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7945 InitialDataCopy = InitialData,
7946 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7947 reverse(RNRestHeads,NRestHeads),
7948 reverse(RNRestIDs,NRestIDs).
7950 final_data(Entry) :-
7951 Entry = entry(_,_,_,_,[],_).
7953 expand_data(Entry,NEntry,Cost) :-
7954 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7955 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7956 term_variables([Head1|Vars],Vars1),
7957 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7958 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7960 % Assigns score to head based on known variables and heads to lookup
7961 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7962 functor(Head,F,A),
7963 get_store_type(F/A,StoreType),
7964 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7966 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7967 term_variables(Head,HeadVars),
7968 term_variables(RestHeads,RestVars),
7969 order_score_vars(HeadVars,KnownVars,RestVars,Score).
7970 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7971 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7972 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7973 order_score_indexes(Indexes,Head,KnownVars,0,Score).
7974 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7975 term_variables(Head,HeadVars),
7976 term_variables(RestHeads,RestVars),
7977 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7978 Score is Score_ * 2.
7979 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7980 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7981 Score = 1. % guaranteed O(1)
7983 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7984 maplist(order_score1(Head,ID,KnownVars,RestHeads,RuleNb),StoreTypes,Scores),
7985 min_list(Scores,Score).
7986 order_score1(Head,ID,KnownVars,RestHeads,RuleNb,StoreType,Score) :-
7987 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score) ->
7988 true
7989 ;
7990 Score = 10000
7991 ).
7992 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7993 Score = 10.
7994 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7995 Score = 10.
7997 order_score_indexes([],_,_,Score,NScore) :-
7998 Score > 0, NScore = 100.
7999 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
8000 multi_hash_key_args(I,Head,Args),
8001 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
8002 Score1 is Score + 1
8003 ;
8004 Score1 = Score
8005 ),
8006 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
8008 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8009 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8010 ( K-R-O == 0-0-0 ->
8011 Score = 0
8012 ; K > 0 ->
8013 Score is max(10 - K,0)
8014 ; R > 0 ->
8015 Score is max(10 - R,1) * 10
8016 ;
8017 Score is max(10-O,1) * 100
8018 ).
8019 order_score_count_vars([],_,_,0-0-0).
8020 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8021 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8022 ( memberchk_eq(V,KnownVars) ->
8023 NK is K + 1,
8024 NR = R, NO = O
8025 ; memberchk_eq(V,RestVars) ->
8026 NR is R + 1,
8027 NK = K, NO = O
8028 ;
8029 NO is O + 1,
8030 NK = K, NR = R
8031 ).
8033 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8034 %% ___ _ _ _
8035 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8036 %% | || '_ \| | | '_ \| | '_ \ / _` |
8037 %% | || | | | | | | | | | | | | (_| |
8038 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8039 %% |___/
8041 %% SWI begin
8042 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8043 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8044 %% SWI end
8046 %% SICStus begin
8047 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8048 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8049 %% SICStus end
8051 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8053 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8054 %% _ _ _ _ _ _ _
8055 %% | | | | |_(_) (_) |_ _ _
8056 %% | | | | __| | | | __| | | |
8057 %% | |_| | |_| | | | |_| |_| |
8058 %% \___/ \__|_|_|_|\__|\__, |
8059 %% |___/
8061 % Create a fresh variable.
8062 gen_var(_).
8064 % Create =N= fresh variables.
8065 gen_vars(N,Xs) :-
8066 length(Xs,N).
8068 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8069 vars_susp(A,Vars,Susp,VarsSusp),
8070 Head =.. [_|Args],
8071 pairup(Args,Vars,HeadPairs).
8073 inc_id([N|Ns],[O|Ns]) :-
8074 O is N + 1.
8075 dec_id([N|Ns],[M|Ns]) :-
8076 M is N - 1.
8078 extend_id(Id,[0|Id]).
8080 next_id([_,N|Ns],[O|Ns]) :-
8081 O is N + 1.
8083 % return clause Head
8084 % for F/A constraint symbol, predicate identifier Id and arguments Head
8085 build_head(F,A,Id,Args,Head) :-
8086 buildName(F,A,Id,Name),
8087 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8088 ( may_trigger(F/A) ;
8089 get_allocation_occurrence(F/A,AO),
8090 get_max_occurrence(F/A,MO),
8091 MO >= AO ) ) ->
8092 Head =.. [Name|Args]
8093 ;
8094 init(Args,ArgsWOSusp), % XXX not entirely correct!
8095 Head =.. [Name|ArgsWOSusp]
8096 ).
8098 % return predicate name Result
8099 % for Fct/Aty constraint symbol and predicate identifier List
8100 buildName(Fct,Aty,List,Result) :-
8101 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8102 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8103 MO >= AO ) ; List \= [0])) ) ) ->
8104 atom_concat(Fct, '___' ,FctSlash),
8105 atomic_concat(FctSlash,Aty,FctSlashAty),
8106 buildName_(List,FctSlashAty,Result)
8107 ;
8108 Result = Fct
8109 ).
8111 buildName_([],Name,Name).
8112 buildName_([N|Ns],Name,Result) :-
8113 buildName_(Ns,Name,Name1),
8114 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8115 atomic_concat(NameDash,N,Result).
8117 vars_susp(A,Vars,Susp,VarsSusp) :-
8118 length(Vars,A),
8119 append(Vars,[Susp],VarsSusp).
8121 or_pattern(Pos,Pat) :-
8122 Pow is Pos - 1,
8123 Pat is 1 << Pow. % was 2 ** X
8125 and_pattern(Pos,Pat) :-
8126 X is Pos - 1,
8127 Y is 1 << X, % was 2 ** X
8128 Pat is (-1)*(Y + 1).
8130 make_name(Prefix,F/A,Name) :-
8131 atom_concat_list([Prefix,F,'___',A],Name).
8133 %===============================================================================
8134 % Attribute for attributed variables
8136 make_attr(N,Mask,SuspsList,Attr) :-
8137 length(SuspsList,N),
8138 Attr =.. [v,Mask|SuspsList].
8140 get_all_suspensions2(N,Attr,SuspensionsList) :-
8141 chr_pp_flag(dynattr,off), !,
8142 make_attr(N,_,SuspensionsList,Attr).
8144 % NEW
8145 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8146 % writeln(get_all_suspensions2),
8147 length(SuspensionsList,N),
8148 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8151 % NEW
8152 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8153 % writeln(normalize_attr),
8154 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8156 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8157 chr_pp_flag(dynattr,off), !,
8158 make_attr(N,_,SuspsList,Attr),
8159 nth1(Position,SuspsList,Suspensions).
8161 % NEW
8162 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8163 % writeln(get_suspensions),
8164 Goal =
8165 ( memberchk(Position-Suspensions,TAttr) ->
8166 true
8167 ;
8168 Suspensions = []
8169 ).
8171 %-------------------------------------------------------------------------------
8172 % +N: number of constraint symbols
8173 % +Suspension: source-level variable, for suspension
8174 % +Position: constraint symbol number
8175 % -Attr: source-level term, for new attribute
8176 singleton_attr(N,Suspension,Position,Attr) :-
8177 chr_pp_flag(dynattr,off), !,
8178 or_pattern(Position,Pattern),
8179 make_attr(N,Pattern,SuspsList,Attr),
8180 nth1(Position,SuspsList,[Suspension]),
8181 chr_delete(SuspsList,[Suspension],RestSuspsList),
8182 set_elems(RestSuspsList,[]).
8184 % NEW
8185 singleton_attr(N,Suspension,Position,Attr) :-
8186 % writeln(singleton_attr),
8187 Attr = [Position-[Suspension]].
8189 %-------------------------------------------------------------------------------
8190 % +N: number of constraint symbols
8191 % +Suspension: source-level variable, for suspension
8192 % +Position: constraint symbol number
8193 % +TAttr: source-level variable, for old attribute
8194 % -Goal: goal for creating new attribute
8195 % -NTAttr: source-level variable, for new attribute
8196 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8197 chr_pp_flag(dynattr,off), !,
8198 make_attr(N,Mask,SuspsList,Attr),
8199 or_pattern(Position,Pattern),
8200 nth1(Position,SuspsList,Susps),
8201 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8202 make_attr(N,Mask,SuspsList1,NewAttr1),
8203 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8204 make_attr(N,NewMask,SuspsList2,NewAttr2),
8205 Goal = (
8206 TAttr = Attr,
8207 ( Mask /\ Pattern =:= Pattern ->
8208 NTAttr = NewAttr1
8209 ;
8210 NewMask is Mask \/ Pattern,
8211 NTAttr = NewAttr2
8212 )
8213 ), !.
8215 % NEW
8216 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8217 % writeln(add_attr),
8218 Goal =
8219 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8220 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8221 ;
8222 NTAttr = [Position-[Suspension]|TAttr]
8223 ).
8225 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8226 chr_pp_flag(dynattr,off), !,
8227 or_pattern(Position,Pattern),
8228 and_pattern(Position,DelPattern),
8229 make_attr(N,Mask,SuspsList,Attr),
8230 nth1(Position,SuspsList,Susps),
8231 substitute_eq(Susps,SuspsList,[],SuspsList1),
8232 make_attr(N,NewMask,SuspsList1,Attr1),
8233 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8234 make_attr(N,Mask,SuspsList2,Attr2),
8235 get_target_module(Mod),
8236 Goal = (
8237 TAttr = Attr,
8238 ( Mask /\ Pattern =:= Pattern ->
8239 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8240 ( NewSusps == [] ->
8241 NewMask is Mask /\ DelPattern,
8242 ( NewMask == 0 ->
8243 del_attr(Var,Mod)
8244 ;
8245 put_attr(Var,Mod,Attr1)
8246 )
8247 ;
8248 put_attr(Var,Mod,Attr2)
8249 )
8250 ;
8251 true
8252 )
8253 ), !.
8255 % NEW
8256 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8257 % writeln(rem_attr),
8258 get_target_module(Mod),
8259 Goal =
8260 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8261 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8262 ( NSuspensions == [] ->
8263 ( RAttr == [] ->
8264 del_attr(Var,Mod)
8265 ;
8266 put_attr(Var,Mod,RAttr)
8267 )
8268 ;
8269 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8270 )
8271 ;
8272 true
8273 ).
8275 %-------------------------------------------------------------------------------
8276 % +N: number of constraint symbols
8277 % +TAttr1: source-level variable, for attribute
8278 % +TAttr2: source-level variable, for other attribute
8279 % -Goal: goal for merging the two attributes
8280 % -Attr: source-level term, for merged attribute
8281 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8282 chr_pp_flag(dynattr,off), !,
8283 make_attr(N,Mask1,SuspsList1,Attr1),
8284 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8285 Goal = (
8286 TAttr1 = Attr1,
8287 Goal2
8288 ).
8290 % NEW
8291 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8292 % writeln(merge_attributes),
8293 Goal = (
8294 sort(TAttr1,Sorted1),
8295 sort(TAttr2,Sorted2),
8296 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8297 ).
8300 %-------------------------------------------------------------------------------
8301 % +N: number of constraint symbols
8302 % +Mask1: ...
8303 % +SuspsList1: static term, for suspensions list
8304 % +TAttr2: source-level variable, for other attribute
8305 % -Goal: goal for merging the two attributes
8306 % -Attr: source-level term, for merged attribute
8307 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8308 make_attr(N,Mask2,SuspsList2,Attr2),
8309 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8310 list2conj(Gs,SortGoals),
8311 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8312 make_attr(N,Mask,SuspsList,Attr),
8313 Goal = (
8314 TAttr2 = Attr2,
8315 SortGoals,
8316 Mask is Mask1 \/ Mask2
8317 ).
8320 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8321 % Storetype dependent lookup
8323 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8324 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8325 %% -Goal,-SuspensionList) is det.
8326 %
8327 % Create a universal lookup goal for given head.
8328 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8329 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8330 functor(Head,F,A),
8331 get_store_type(F/A,StoreType),
8332 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8334 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8335 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8336 %% -Goal,-SuspensionList) is det.
8337 %
8338 % Create a universal lookup goal for given head.
8339 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8340 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8341 functor(Head,F,A),
8342 get_store_type(F/A,StoreType),
8343 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8345 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8346 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8347 %% +GroundVars,-Goal,-SuspensionList) is det.
8348 %
8349 % Create a universal lookup goal for given head.
8350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8351 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8352 functor(Head,F,A),
8353 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8354 update_store_type(F/A,default).
8355 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8356 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8357 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8358 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8359 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,(Goal,AllSusps \== []),AllSusps) :-
8360 functor(Head,F,A),
8361 global_ground_store_name(F/A,StoreName),
8362 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8363 update_store_type(F/A,global_ground).
8364 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8365 arg(VarIndex,Head,OVar),
8366 arg(KeyIndex,Head,OKey),
8367 translate([OVar,OKey],VarDict,[Var,Key]),
8368 get_target_module(Module),
8369 Goal = (
8370 get_attr(Var,Module,AssocStore),
8371 lookup_assoc_store(AssocStore,Key,AllSusps)
8372 ).
8373 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8374 functor(Head,F,A),
8375 global_singleton_store_name(F/A,StoreName),
8376 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8377 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8378 update_store_type(F/A,global_singleton).
8379 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8380 once((
8381 member(ST,StoreTypes),
8382 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8383 )).
8384 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8385 functor(Head,F,A),
8386 arg(Index,Head,Var),
8387 translate([Var],VarDict,[KeyVar]),
8388 delay_phase_end(validate_store_type_assumptions,
8389 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8390 ),
8391 update_store_type(F/A,identifier_store(Index)),
8392 get_identifier_index(F/A,Index,_).
8393 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8394 functor(Head,F,A),
8395 arg(Index,Head,Var),
8396 ( var(Var) ->
8397 translate([Var],VarDict,[KeyVar]),
8398 Goal = StructGoal
8399 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8400 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8401 Goal = (LookupGoal,StructGoal)
8402 ),
8403 delay_phase_end(validate_store_type_assumptions,
8404 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8405 ),
8406 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8407 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8409 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8410 get_identifier_size(ISize),
8411 functor(Struct,struct,ISize),
8412 get_identifier_index(C,Index,IIndex),
8413 arg(IIndex,Struct,AllSusps),
8414 Goal = (KeyVar = Struct).
8416 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8417 type_indexed_identifier_structure(IndexType,Struct),
8418 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8419 arg(IIndex,Struct,AllSusps),
8420 Goal = (KeyVar = Struct).
8422 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8423 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8424 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8425 %
8426 % Create a universal hash lookup goal for given head.
8427 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8428 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8429 once((
8430 member(Index,Indexes),
8431 multi_hash_key_args(Index,Head,KeyArgs),
8432 (
8433 translate(KeyArgs,VarDict,KeyArgCopies)
8434 ;
8435 ground(KeyArgs), KeyArgCopies = KeyArgs
8436 )
8437 )),
8438 ( KeyArgCopies = [KeyCopy] ->
8439 true
8440 ;
8441 KeyCopy =.. [k|KeyArgCopies]
8442 ),
8443 functor(Head,F,A),
8444 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8446 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8447 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8449 Goal = (GroundCheck,LookupGoal),
8451 ( HashType == inthash ->
8452 update_store_type(F/A,multi_inthash([Index]))
8453 ;
8454 update_store_type(F/A,multi_hash([Index]))
8455 ).
8457 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8458 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8459 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8460 %% +VarArgDict,-NewVarArgDict) is det.
8461 %
8462 % Create existential lookup goal for given head.
8463 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8464 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8465 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8466 sbag_member_call(Susp,AllSusps,Sbag),
8467 functor(Head,F,A),
8468 delay_phase_end(validate_store_type_assumptions,
8469 ( static_suspension_term(F/A,SuspTerm),
8470 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8471 )
8472 ),
8473 Goal = (
8474 UniversalGoal,
8475 Sbag,
8476 Susp = SuspTerm,
8477 GetState
8478 ).
8479 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8480 functor(Head,F,A),
8481 global_singleton_store_name(F/A,StoreName),
8482 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8483 Goal = (
8484 GetStoreGoal, % nb_getval(StoreName,Susp),
8485 Susp \== [],
8486 Susp = SuspTerm
8487 ),
8488 update_store_type(F/A,global_singleton).
8489 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8490 once((
8491 member(ST,StoreTypes),
8492 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8493 )).
8494 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8495 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8496 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8497 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8498 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8499 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8500 hash_index_filter(Pairs,Index,NPairs),
8502 functor(Head,F,A),
8503 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8504 Sbag = (AllSusps = [Susp])
8505 ;
8506 sbag_member_call(Susp,AllSusps,Sbag)
8507 ),
8508 delay_phase_end(validate_store_type_assumptions,
8509 ( static_suspension_term(F/A,SuspTerm),
8510 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8511 )
8512 ),
8513 Goal = (
8514 LookupGoal,
8515 Sbag,
8516 Susp = SuspTerm, % not inlined
8517 GetState
8518 ).
8519 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8520 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8521 hash_index_filter(Pairs,Index,NPairs),
8523 functor(Head,F,A),
8524 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8525 Sbag = (AllSusps = [Susp])
8526 ;
8527 sbag_member_call(Susp,AllSusps,Sbag)
8528 ),
8529 delay_phase_end(validate_store_type_assumptions,
8530 ( static_suspension_term(F/A,SuspTerm),
8531 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8532 )
8533 ),
8534 Goal = (
8535 LookupGoal,
8536 Sbag,
8537 Susp = SuspTerm, % not inlined
8538 GetState
8539 ).
8540 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8541 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8542 sbag_member_call(Susp,Susps,Sbag),
8543 functor(Head,F,A),
8544 delay_phase_end(validate_store_type_assumptions,
8545 ( static_suspension_term(F/A,SuspTerm),
8546 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8547 )
8548 ),
8549 Goal = (
8550 UGoal,
8551 Sbag,
8552 Susp = SuspTerm, % not inlined
8553 GetState
8554 ).
8556 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8557 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8558 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8559 %% +VarArgDict,-NewVarArgDict) is det.
8560 %
8561 % Create existential hash lookup goal for given head.
8562 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8563 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8564 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8566 hash_index_filter(Pairs,Index,NPairs),
8568 functor(Head,F,A),
8569 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8570 Sbag = (AllSusps = [Susp])
8571 ;
8572 sbag_member_call(Susp,AllSusps,Sbag)
8573 ),
8574 delay_phase_end(validate_store_type_assumptions,
8575 ( static_suspension_term(F/A,SuspTerm),
8576 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8577 )
8578 ),
8579 Goal = (
8580 LookupGoal,
8581 Sbag,
8582 Susp = SuspTerm, % not inlined
8583 GetState
8584 ).
8586 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8587 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8588 %
8589 % Filter out pairs already covered by given hash index.
8590 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8591 hash_index_filter(Pairs,Index,NPairs) :-
8592 ( integer(Index) ->
8593 NIndex = [Index]
8594 ;
8595 NIndex = Index
8596 ),
8597 hash_index_filter(Pairs,NIndex,1,NPairs).
8599 hash_index_filter([],_,_,[]).
8600 hash_index_filter([P|Ps],Index,N,NPairs) :-
8601 ( Index = [I|Is] ->
8602 NN is N + 1,
8603 ( I > N ->
8604 NPairs = [P|NPs],
8605 hash_index_filter(Ps,[I|Is],NN,NPs)
8606 ; I == N ->
8607 hash_index_filter(Ps,Is,NN,NPairs)
8608 )
8609 ;
8610 NPairs = [P|Ps]
8611 ).
8613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8614 %------------------------------------------------------------------------------%
8615 %% assume_constraint_stores(+ConstraintSymbols) is det.
8616 %
8617 % Compute all constraint store types that are possible for the given
8618 % =ConstraintSymbols=.
8619 %------------------------------------------------------------------------------%
8620 assume_constraint_stores([]).
8621 assume_constraint_stores([C|Cs]) :-
8622 ( chr_pp_flag(debugable,off),
8623 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8624 is_stored(C),
8625 get_store_type(C,default) ->
8626 get_indexed_arguments(C,AllIndexedArgs),
8627 get_constraint_mode(C,Modes),
8628 aggregate_all(bag(Index)-count,
8629 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8630 IndexedArgs-NbIndexedArgs),
8631 % Construct Index Combinations
8632 ( NbIndexedArgs > 10 ->
8633 findall([Index],member(Index,IndexedArgs),Indexes)
8634 ;
8635 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8636 predsort(longer_list,UnsortedIndexes,Indexes)
8637 ),
8638 % EXPERIMENTAL HEURISTIC
8639 % findall(Index, (
8640 % member(Arg1,IndexedArgs),
8641 % member(Arg2,IndexedArgs),
8642 % Arg1 =< Arg2,
8643 % sort([Arg1,Arg2], Index)
8644 % ), UnsortedIndexes),
8645 % predsort(longer_list,UnsortedIndexes,Indexes),
8646 % Choose Index Type
8647 ( get_functional_dependency(C,1,Pattern,Key),
8648 all_distinct_var_args(Pattern), Key == [] ->
8649 assumed_store_type(C,global_singleton)
8650 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8651 get_constraint_type_det(C,ArgTypes),
8652 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8654 ( IntHashIndexes = [] ->
8655 Stores = Stores1
8656 ;
8657 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8658 ),
8659 ( HashIndexes = [] ->
8660 Stores1 = Stores2
8661 ;
8662 Stores1 = [multi_hash(HashIndexes)|Stores2]
8663 ),
8664 ( IdentifierIndexes = [] ->
8665 Stores2 = Stores3
8666 ;
8667 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8668 append(WrappedIdentifierIndexes,Stores3,Stores2)
8669 ),
8670 append(CompoundIdentifierIndexes,Stores4,Stores3),
8671 ( only_ground_indexed_arguments(C)
8672 -> Stores4 = [global_ground]
8673 ; Stores4 = [default]
8674 ),
8675 assumed_store_type(C,multi_store(Stores))
8676 ; true
8677 )
8678 ;
8679 true
8680 ),
8681 assume_constraint_stores(Cs).
8683 %------------------------------------------------------------------------------%
8684 %% partition_indexes(+Indexes,+Types,
8685 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8686 %------------------------------------------------------------------------------%
8687 partition_indexes([],_,[],[],[],[]).
8688 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8689 ( Index = [I],
8690 nth1(I,Types,Type),
8691 unalias_type(Type,UnAliasedType),
8692 UnAliasedType == chr_identifier ->
8693 IdentifierIndexes = [I|RIdentifierIndexes],
8694 IntHashIndexes = RIntHashIndexes,
8695 HashIndexes = RHashIndexes,
8696 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8697 ; Index = [I],
8698 nth1(I,Types,Type),
8699 unalias_type(Type,UnAliasedType),
8700 nonvar(UnAliasedType),
8701 UnAliasedType = chr_identifier(IndexType) ->
8702 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8703 IdentifierIndexes = RIdentifierIndexes,
8704 IntHashIndexes = RIntHashIndexes,
8705 HashIndexes = RHashIndexes
8706 ; Index = [I],
8707 nth1(I,Types,Type),
8708 unalias_type(Type,UnAliasedType),
8709 UnAliasedType == dense_int ->
8710 IntHashIndexes = [Index|RIntHashIndexes],
8711 HashIndexes = RHashIndexes,
8712 IdentifierIndexes = RIdentifierIndexes,
8713 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8714 ; member(I,Index),
8715 nth1(I,Types,Type),
8716 unalias_type(Type,UnAliasedType),
8717 nonvar(UnAliasedType),
8718 UnAliasedType = chr_identifier(_) ->
8719 % don't use chr_identifiers in hash indexes
8720 IntHashIndexes = RIntHashIndexes,
8721 HashIndexes = RHashIndexes,
8722 IdentifierIndexes = RIdentifierIndexes,
8723 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8724 ;
8725 IntHashIndexes = RIntHashIndexes,
8726 HashIndexes = [Index|RHashIndexes],
8727 IdentifierIndexes = RIdentifierIndexes,
8728 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8729 ),
8730 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8732 longer_list(R,L1,L2) :-
8733 length(L1,N1),
8734 length(L2,N2),
8735 compare(Rt,N2,N1),
8736 ( Rt == (=) ->
8737 compare(R,L1,L2)
8738 ;
8739 R = Rt
8740 ).
8742 all_distinct_var_args(Term) :-
8743 copy_term_nat(Term,TermCopy),
8744 functor(Term,F,A),
8745 functor(Pattern,F,A),
8746 Pattern =@= Term.
8748 get_indexed_arguments(C,IndexedArgs) :-
8749 C = F/A,
8750 get_indexed_arguments(1,A,C,IndexedArgs).
8752 get_indexed_arguments(I,N,C,L) :-
8753 ( I > N ->
8754 L = []
8755 ; ( is_indexed_argument(C,I) ->
8756 L = [I|T]
8757 ;
8758 L = T
8759 ),
8760 J is I + 1,
8761 get_indexed_arguments(J,N,C,T)
8762 ).
8764 validate_store_type_assumptions([]).
8765 validate_store_type_assumptions([C|Cs]) :-
8766 validate_store_type_assumption(C),
8767 validate_store_type_assumptions(Cs).
8769 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8770 % new code generation
8771 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8772 Rule = rule(H1,_,Guard,Body),
8773 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8774 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8775 flatten(VarsAndSuspsList,VarsAndSusps),
8776 Vars = [ [] | VarsAndSusps],
8777 build_head(F,A,[O|Id],Vars,Head),
8778 ( PrevId0 = [_] ->
8779 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8780 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8781 PrevId = [PredictedPrevId] % PrevId = PrevId0
8782 ;
8783 PrevId = [O|PrevId0]
8784 ),
8785 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8786 Clause = ( Head :- PredecessorCall),
8787 add_dummy_location(Clause,LocatedClause),
8788 L = [LocatedClause | T].
8789 % ( H1 == [],
8790 % functor(CurrentHead,CF,CA),
8791 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8792 % L = T
8793 % ;
8794 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8795 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8796 % flatten(VarsAndSuspsList,VarsAndSusps),
8797 % Vars = [ [] | VarsAndSusps],
8798 % build_head(F,A,Id,Vars,Head),
8799 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8800 % Clause = ( Head :- PredecessorCall),
8801 % L = [Clause | T]
8802 % ).
8804 % skips back intelligently over global_singleton lookups
8805 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8806 ( Id = [0|_] ->
8807 % TOM: add partial success continuation optimization here!
8808 next_id(Id,PrevId),
8809 PrevVarsAndSusps = BaseCallArgs
8810 ;
8811 VarsAndSuspsList = [_|AllButFirstList],
8812 dec_id(Id,PrevId1),
8813 ( PrevHeads = [PrevHead|PrevHeads1],
8814 functor(PrevHead,F,A),
8815 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8816 PrevIterators = [_|PrevIterators1],
8817 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8818 ;
8819 PrevId = PrevId1,
8820 flatten(AllButFirstList,AllButFirst),
8821 PrevIterators = [PrevIterator|_],
8822 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8823 )
8824 ).
8826 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8827 Rule = rule(_,_,Guard,Body),
8828 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8829 init(AllSusps,PreSusps),
8830 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8831 gen_var(OtherSusps),
8832 functor(CurrentHead,OtherF,OtherA),
8833 gen_vars(OtherA,OtherVars),
8834 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8835 get_constraint_mode(OtherF/OtherA,Mode),
8836 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8838 delay_phase_end(validate_store_type_assumptions,
8839 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8840 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8841 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8842 )
8843 ),
8845 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8846 % create_get_mutable_ref(active,State,GetMutable),
8847 CurrentSuspTest = (
8848 OtherSusp = OtherSuspension,
8849 GetState,
8850 DiffSuspGoals,
8851 FirstMatching
8852 ),
8853 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8854 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8855 inc_id(Id,NestedId),
8856 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8857 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8858 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8859 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8860 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
8862 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8863 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8864 RecursiveVars = PreVarsAndSusps1
8865 ;
8866 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8867 PrevId0 = Id
8868 ),
8869 ( PrevId0 = [_] ->
8870 PrevId = PrevId0
8871 ;
8872 PrevId = [O|PrevId0]
8873 ),
8874 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
8876 Clause = (
8877 ClauseHead :-
8878 ( CurrentSuspTest,
8879 NextSuspGoal
8880 ->
8881 NestedHead
8882 ; RecursiveHead
8883 )
8884 ),
8885 add_dummy_location(Clause,LocatedClause),
8886 L = [LocatedClause|T].
8888 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8890 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8891 % Observation Analysis
8892 %
8893 % CLASSIFICATION
8894 % Enabled
8895 %
8896 % Analysis based on Abstract Interpretation paper.
8897 %
8898 % TODO:
8899 % stronger analysis domain [research]
8901 :- chr_constraint
8902 initial_call_pattern/1,
8903 call_pattern/1,
8904 call_pattern_worker/1,
8905 final_answer_pattern/2,
8906 abstract_constraints/1,
8907 depends_on/2,
8908 depends_on_ap/4,
8909 depends_on_goal/2,
8910 ai_observed_internal/2,
8911 % ai_observed/2,
8912 ai_not_observed_internal/2,
8913 ai_not_observed/2,
8914 ai_is_observed/2,
8915 depends_on_as/3,
8916 ai_observation_gather_results/0.
8918 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
8919 :- chr_type program_point == any.
8921 :- chr_option(mode,initial_call_pattern(+)).
8922 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8924 :- chr_option(mode,call_pattern(+)).
8925 :- chr_option(type_declaration,call_pattern(abstract_domain)).
8927 :- chr_option(mode,call_pattern_worker(+)).
8928 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
8930 :- chr_option(mode,final_answer_pattern(+,+)).
8931 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
8933 :- chr_option(mode,abstract_constraints(+)).
8934 :- chr_option(type_declaration,abstract_constraints(list)).
8936 :- chr_option(mode,depends_on(+,+)).
8937 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
8939 :- chr_option(mode,depends_on_as(+,+,+)).
8940 :- chr_option(mode,depends_on_ap(+,+,+,+)).
8941 :- chr_option(mode,depends_on_goal(+,+)).
8942 :- chr_option(mode,ai_is_observed(+,+)).
8943 :- chr_option(mode,ai_not_observed(+,+)).
8944 % :- chr_option(mode,ai_observed(+,+)).
8945 :- chr_option(mode,ai_not_observed_internal(+,+)).
8946 :- chr_option(mode,ai_observed_internal(+,+)).
8949 abstract_constraints_fd @
8950 abstract_constraints(_) \ abstract_constraints(_) <=> true.
8952 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8953 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
8954 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
8956 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
8957 ai_is_observed(_,_) <=> true.
8959 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
8960 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
8961 ai_observation_gather_results <=> true.
8963 %------------------------------------------------------------------------------%
8964 % Main Analysis Entry
8965 %------------------------------------------------------------------------------%
8966 ai_observation_analysis(ACs) :-
8967 ( chr_pp_flag(ai_observation_analysis,on),
8968 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
8969 list_to_ord_set(ACs,ACSet),
8970 abstract_constraints(ACSet),
8971 ai_observation_schedule_initial_calls(ACSet,ACSet),
8972 ai_observation_gather_results
8973 ;
8974 true
8975 ).
8977 ai_observation_schedule_initial_calls([],_).
8978 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
8979 ai_observation_schedule_initial_call(AC,ACs),
8980 ai_observation_schedule_initial_calls(RACs,ACs).
8982 ai_observation_schedule_initial_call(AC,ACs) :-
8983 ai_observation_top(AC,CallPattern),
8984 % ai_observation_bot(AC,ACs,CallPattern),
8985 initial_call_pattern(CallPattern).
8987 ai_observation_schedule_new_calls([],AP).
8988 ai_observation_schedule_new_calls([AC|ACs],AP) :-
8989 AP = odom(_,Set),
8990 initial_call_pattern(odom(AC,Set)),
8991 ai_observation_schedule_new_calls(ACs,AP).
8993 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
8994 <=>
8995 ai_observation_leq(AP2,AP1)
8996 |
8997 true.
8999 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9001 initial_call_pattern(CP) ==> call_pattern(CP).
9003 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9004 ==>
9005 ai_observation_schedule_new_calls(ACs,AP)
9006 pragma
9007 passive(ID3).
9009 call_pattern(CP) \ call_pattern(CP) <=> true.
9011 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9012 final_answer_pattern(CP1,AP).
9014 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9016 call_pattern(CP) ==> call_pattern_worker(CP).
9018 %------------------------------------------------------------------------------%
9019 % Abstract Goal
9020 %------------------------------------------------------------------------------%
9022 % AbstractGoala
9023 %call_pattern(odom([],Set)) ==>
9024 % final_answer_pattern(odom([],Set),odom([],Set)).
9026 call_pattern_worker(odom([],Set)) <=>
9027 % writeln(' - AbstractGoal'(odom([],Set))),
9028 final_answer_pattern(odom([],Set),odom([],Set)).
9030 % AbstractGoalb
9031 call_pattern_worker(odom([G|Gs],Set)) <=>
9032 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9033 CP1 = odom(G,Set),
9034 depends_on_goal(odom([G|Gs],Set),CP1),
9035 call_pattern(CP1).
9037 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9038 <=> true pragma passive(ID).
9039 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9040 ==>
9041 CP1 = odom([_|Gs],_),
9042 AP2 = odom([],Set),
9043 CCP = odom(Gs,Set),
9044 call_pattern(CCP),
9045 depends_on(CP1,CCP).
9047 %------------------------------------------------------------------------------%
9048 % Abstract Disjunction
9049 %------------------------------------------------------------------------------%
9051 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9052 CP = odom((AG1;AG2),Set),
9053 InitialAnswerApproximation = odom([],Set),
9054 final_answer_pattern(CP,InitialAnswerApproximation),
9055 CP1 = odom(AG1,Set),
9056 CP2 = odom(AG2,Set),
9057 call_pattern(CP1),
9058 call_pattern(CP2),
9059 depends_on_as(CP,CP1,CP2).
9061 %------------------------------------------------------------------------------%
9062 % Abstract Solve
9063 %------------------------------------------------------------------------------%
9064 call_pattern_worker(odom(builtin,Set)) <=>
9065 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9066 ord_empty(EmptySet),
9067 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9069 %------------------------------------------------------------------------------%
9070 % Abstract Drop
9071 %------------------------------------------------------------------------------%
9072 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9073 <=>
9074 O > MO
9075 |
9076 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9077 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9078 pragma
9079 passive(ID2).
9081 %------------------------------------------------------------------------------%
9082 % Abstract Activate
9083 %------------------------------------------------------------------------------%
9084 call_pattern_worker(odom(AC,Set))
9085 <=>
9086 AC = _ / _
9087 |
9088 % writeln(' - AbstractActivate'(odom(AC,Set))),
9089 CP = odom(occ(AC,1),Set),
9090 call_pattern(CP),
9091 depends_on(odom(AC,Set),CP).
9093 %------------------------------------------------------------------------------%
9094 % Abstract Passive
9095 %------------------------------------------------------------------------------%
9096 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9097 <=>
9098 is_passive(RuleNb,ID)
9099 |
9100 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9101 % DEFAULT
9102 NO is O + 1,
9103 DCP = odom(occ(C,NO),Set),
9104 call_pattern(DCP),
9105 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9106 depends_on(odom(occ(C,O),Set),DCP)
9107 pragma
9108 passive(ID2).
9109 %------------------------------------------------------------------------------%
9110 % Abstract Simplify
9111 %------------------------------------------------------------------------------%
9113 % AbstractSimplify
9114 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9115 <=>
9116 \+ is_passive(RuleNb,ID)
9117 |
9118 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9119 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9120 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9121 ai_observation_memo_abstract_goal(RuleNb,AG),
9122 call_pattern(odom(AG,Set2)),
9123 % DEFAULT
9124 NO is O + 1,
9125 DCP = odom(occ(C,NO),Set),
9126 call_pattern(DCP),
9127 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9128 % DEADLOCK AVOIDANCE
9129 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9130 pragma
9131 passive(ID2).
9133 depends_on_as(CP,CPS,CPD),
9134 final_answer_pattern(CPS,APS),
9135 final_answer_pattern(CPD,APD) ==>
9136 ai_observation_lub(APS,APD,AP),
9137 final_answer_pattern(CP,AP).
9140 :- chr_constraint
9141 ai_observation_memo_simplification_rest_heads/3,
9142 ai_observation_memoed_simplification_rest_heads/3.
9144 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9145 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9147 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9148 <=>
9149 QRH = RH.
9150 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9151 <=>
9152 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9153 once(select2(ID,_,IDs1,H1,_,RestH1)),
9154 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9155 ai_observation_abstract_constraints(H2,ACs,AH2),
9156 append(ARestHeads,AH2,AbstractHeads),
9157 sort(AbstractHeads,QRH),
9158 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9159 pragma
9160 passive(ID1),
9161 passive(ID2),
9162 passive(ID3).
9164 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9166 %------------------------------------------------------------------------------%
9167 % Abstract Propagate
9168 %------------------------------------------------------------------------------%
9171 % AbstractPropagate
9172 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9173 <=>
9174 \+ is_passive(RuleNb,ID)
9175 |
9176 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9177 % observe partners
9178 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9179 ai_observation_observe_set(Set,AHs,Set2),
9180 ord_add_element(Set2,C,Set3),
9181 ai_observation_memo_abstract_goal(RuleNb,AG),
9182 call_pattern(odom(AG,Set3)),
9183 ( ord_memberchk(C,Set2) ->
9184 Delete = no
9185 ;
9186 Delete = yes
9187 ),
9188 % DEFAULT
9189 NO is O + 1,
9190 DCP = odom(occ(C,NO),Set),
9191 call_pattern(DCP),
9192 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9193 pragma
9194 passive(ID2).
9196 :- chr_constraint
9197 ai_observation_memo_propagation_rest_heads/3,
9198 ai_observation_memoed_propagation_rest_heads/3.
9200 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9201 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9203 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9204 <=>
9205 QRH = RH.
9206 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9207 <=>
9208 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9209 once(select2(ID,_,IDs2,H2,_,RestH2)),
9210 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9211 ai_observation_abstract_constraints(H1,ACs,AH1),
9212 append(ARestHeads,AH1,AbstractHeads),
9213 sort(AbstractHeads,QRH),
9214 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9215 pragma
9216 passive(ID1),
9217 passive(ID2),
9218 passive(ID3).
9220 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9222 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9223 final_answer_pattern(CP,APD).
9224 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9225 final_answer_pattern(CPD,APD) ==>
9226 true |
9227 CP = odom(occ(C,O),_),
9228 ( ai_observation_is_observed(APP,C) ->
9229 ai_observed_internal(C,O)
9230 ;
9231 ai_not_observed_internal(C,O)
9232 ),
9233 ( Delete == yes ->
9234 APP = odom([],Set0),
9235 ord_del_element(Set0,C,Set),
9236 NAPP = odom([],Set)
9237 ;
9238 NAPP = APP
9239 ),
9240 ai_observation_lub(NAPP,APD,AP),
9241 final_answer_pattern(CP,AP).
9243 %------------------------------------------------------------------------------%
9244 % Catch All
9245 %------------------------------------------------------------------------------%
9247 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9249 %------------------------------------------------------------------------------%
9250 % Auxiliary Predicates
9251 %------------------------------------------------------------------------------%
9253 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9254 ord_intersection(S1,S2,S3).
9256 ai_observation_bot(AG,AS,odom(AG,AS)).
9258 ai_observation_top(AG,odom(AG,EmptyS)) :-
9259 ord_empty(EmptyS).
9261 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9262 ord_subset(S2,S1).
9264 ai_observation_observe_set(S,ACSet,NS) :-
9265 ord_subtract(S,ACSet,NS).
9267 ai_observation_abstract_constraint(C,ACs,AC) :-
9268 functor(C,F,A),
9269 AC = F/A,
9270 memberchk(AC,ACs).
9272 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9273 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9275 %------------------------------------------------------------------------------%
9276 % Abstraction of Rule Bodies
9277 %------------------------------------------------------------------------------%
9279 :- chr_constraint
9280 ai_observation_memoed_abstract_goal/2,
9281 ai_observation_memo_abstract_goal/2.
9283 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9284 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9286 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9287 <=>
9288 QAG = AG
9289 pragma
9290 passive(ID1).
9292 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9293 <=>
9294 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9295 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9296 QAG = AG,
9297 ai_observation_memoed_abstract_goal(RuleNb,AG)
9298 pragma
9299 passive(ID1),
9300 passive(ID2).
9302 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9303 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9304 term_variables((H1,H2,Guard),HVars),
9305 append(H1,H2,Heads),
9306 % variables that are declared to be ground are safe,
9307 ground_vars(Heads,GroundVars),
9308 % so we remove them from the list of 'dangerous' head variables
9309 list_difference_eq(HVars,GroundVars,HV),
9310 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9311 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9312 % HV are 'dangerous' variables, all others are fresh and safe
9314 ground_vars([],[]).
9315 ground_vars([H|Hs],GroundVars) :-
9316 functor(H,F,A),
9317 get_constraint_mode(F/A,Mode),
9318 % TOM: fix this code!
9319 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9320 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9321 ground_vars(Hs,GroundVars2),
9322 append(GroundVars1,GroundVars2,GroundVars).
9324 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9325 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9326 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9327 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9328 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9329 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9330 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9331 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9332 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9333 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9334 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9335 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9336 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9337 % non-CHR constraint is safe if it only binds fresh variables
9338 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9339 builtin_binds_b(G,Vars),
9340 intersect_eq(Vars,HV,[]),
9341 !.
9342 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9343 AG = builtin. % default case if goal is not recognized/safe
9345 ai_observation_is_observed(odom(_,ACSet),AC) :-
9346 \+ ord_memberchk(AC,ACSet).
9348 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9349 unconditional_occurrence(C,O) :-
9350 get_occurrence(C,O,RuleNb,ID),
9351 get_rule(RuleNb,PRule),
9352 PRule = pragma(ORule,_,_,_,_),
9353 copy_term_nat(ORule,Rule),
9354 Rule = rule(H1,H2,Guard,_),
9355 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl,
9356 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9357 once((
9358 H1 = [Head], H2 == []
9359 ;
9360 H2 = [Head], H1 == [], \+ may_trigger(C)
9361 )),
9362 functor(Head,F,A),
9363 Head =.. [_|Args],
9364 unconditional_occurrence_args(Args).
9366 unconditional_occurrence_args([]).
9367 unconditional_occurrence_args([X|Xs]) :-
9368 var(X),
9369 X = x,
9370 unconditional_occurrence_args(Xs).
9372 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9374 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9375 % Partial wake analysis
9376 %
9377 % In a Var = Var unification do not wake up constraints of both variables,
9378 % but rather only those of one variable.
9379 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9381 :- chr_constraint partial_wake_analysis/0.
9382 :- chr_constraint no_partial_wake/1.
9383 :- chr_option(mode,no_partial_wake(+)).
9384 :- chr_constraint wakes_partially/1.
9385 :- chr_option(mode,wakes_partially(+)).
9387 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9388 ==>
9389 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9390 ( is_passive(RuleNb,ID) ->
9391 true
9392 ; Type == simplification ->
9393 select(H,H1,RestH1),
9394 H =.. [_|Args],
9395 term_variables(Guard,Vars),
9396 partial_wake_args(Args,ArgModes,Vars,FA)
9397 ; % Type == propagation ->
9398 select(H,H2,RestH2),
9399 H =.. [_|Args],
9400 term_variables(Guard,Vars),
9401 partial_wake_args(Args,ArgModes,Vars,FA)
9402 ).
9404 partial_wake_args([],_,_,_).
9405 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9406 ( Mode \== (+) ->
9407 ( nonvar(Arg) ->
9408 no_partial_wake(C)
9409 ; memberchk_eq(Arg,Vars) ->
9410 no_partial_wake(C)
9411 ;
9412 true
9413 )
9414 ;
9415 true
9416 ),
9417 partial_wake_args(Args,Modes,Vars,C).
9419 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9421 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9423 wakes_partially(C) <=> true.
9426 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9427 % Generate rules that implement chr_show_store/1 functionality.
9428 %
9429 % CLASSIFICATION
9430 % Experimental
9431 % Unused
9432 %
9433 % Generates additional rules:
9434 %
9435 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9436 % ...
9437 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9438 % $show <=> true.
9440 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9441 ( chr_pp_flag(show,on) ->
9442 Constraints = ['$show'/0|Constraints0],
9443 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9444 inc_rule_count(RuleNb),
9445 Rule = pragma(
9446 rule(['$show'],[],true,true),
9447 ids([0],[]),
9448 [],
9449 no,
9450 RuleNb
9451 )
9452 ;
9453 Constraints = Constraints0,
9454 Rules = Rules0
9455 ).
9457 generate_show_rules([],Rules,Rules).
9458 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9459 functor(C,F,A),
9460 inc_rule_count(RuleNb),
9461 Rule = pragma(
9462 rule([],['$show',C],true,writeln(C)),
9463 ids([],[0,1]),
9464 [passive(1)],
9465 no,
9466 RuleNb
9467 ),
9468 generate_show_rules(Rest,Tail,Rules).
9470 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9471 % Custom supension term layout
9473 static_suspension_term(F/A,Suspension) :-
9474 suspension_term_base(F/A,Base),
9475 Arity is Base + A,
9476 functor(Suspension,suspension,Arity).
9478 has_suspension_field(FA,Field) :-
9479 suspension_term_base_fields(FA,Fields),
9480 memberchk(Field,Fields).
9482 suspension_term_base(FA,Base) :-
9483 suspension_term_base_fields(FA,Fields),
9484 length(Fields,Base).
9486 suspension_term_base_fields(FA,Fields) :-
9487 ( chr_pp_flag(debugable,on) ->
9488 % 1. ID
9489 % 2. State
9490 % 3. Propagation History
9491 % 4. Generation Number
9492 % 5. Continuation Goal
9493 % 6. Functor
9494 Fields = [id,state,history,generation,continuation,functor]
9495 ;
9496 ( uses_history(FA) ->
9497 Fields = [id,state,history|Fields2]
9498 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9499 Fields = [state|Fields2]
9500 ;
9501 Fields = [id,state|Fields2]
9502 ),
9503 ( only_ground_indexed_arguments(FA) ->
9504 get_store_type(FA,StoreType),
9505 basic_store_types(StoreType,BasicStoreTypes),
9506 ( memberchk(global_ground,BasicStoreTypes) ->
9507 % 1. ID
9508 % 2. State
9509 % 3. Propagation History
9510 % 4. Global List Prev
9511 Fields2 = [global_list_prev|Fields3]
9512 ;
9513 % 1. ID
9514 % 2. State
9515 % 3. Propagation History
9516 Fields2 = Fields3
9517 ),
9518 ( chr_pp_flag(ht_removal,on)
9519 -> ht_prev_fields(BasicStoreTypes,Fields3)
9520 ; Fields3 = []
9521 )
9522 ; may_trigger(FA) ->
9523 % 1. ID
9524 % 2. State
9525 % 3. Propagation History
9526 ( uses_field(FA,generation) ->
9527 % 4. Generation Number
9528 % 5. Global List Prev
9529 Fields2 = [generation,global_list_prev|Fields3]
9530 ;
9531 Fields2 = [global_list_prev|Fields3]
9532 ),
9533 ( chr_pp_flag(mixed_stores,on),
9534 chr_pp_flag(ht_removal,on)
9535 -> get_store_type(FA,StoreType),
9536 basic_store_types(StoreType,BasicStoreTypes),
9537 ht_prev_fields(BasicStoreTypes,Fields3)
9538 ; Fields3 = []
9539 )
9540 ;
9541 % 1. ID
9542 % 2. State
9543 % 3. Propagation History
9544 % 4. Global List Prev
9545 Fields2 = [global_list_prev|Fields3],
9546 ( chr_pp_flag(mixed_stores,on),
9547 chr_pp_flag(ht_removal,on)
9548 -> get_store_type(FA,StoreType),
9549 basic_store_types(StoreType,BasicStoreTypes),
9550 ht_prev_fields(BasicStoreTypes,Fields3)
9551 ; Fields3 = []
9552 )
9553 )
9554 ).
9556 ht_prev_fields(Stores,Prevs) :-
9557 ht_prev_fields_int(Stores,PrevsList),
9558 append(PrevsList,Prevs).
9559 ht_prev_fields_int([],[]).
9560 ht_prev_fields_int([H|T],Fields) :-
9561 ( H = multi_hash(Indexes)
9562 -> maplist(ht_prev_field,Indexes,FH),
9563 Fields = [FH|FT]
9564 ; Fields = FT
9565 ),
9566 ht_prev_fields_int(T,FT).
9568 ht_prev_field(Index,Field) :-
9569 ( integer(Index)
9570 -> atom_concat('multi_hash_prev-',Index,Field)
9571 ; Index = [_|_]
9572 -> concat_atom(['multi_hash_prev-'|Index],Field)
9573 ).
9575 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9576 suspension_term_base_fields(FA,Fields),
9577 nth1(Index,Fields,FieldName), !,
9578 arg(Index,StaticSuspension,Field).
9579 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9580 suspension_term_base(FA,Base),
9581 StaticSuspension =.. [_|Args],
9582 drop(Base,Args,Field).
9583 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9584 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9587 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9588 suspension_term_base_fields(FA,Fields),
9589 nth1(Index,Fields,FieldName), !,
9590 Goal = arg(Index,DynamicSuspension,Field).
9591 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9592 static_suspension_term(FA,StaticSuspension),
9593 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9594 Goal = (DynamicSuspension = StaticSuspension).
9595 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9596 suspension_term_base(FA,Base),
9597 Index is I + Base,
9598 Goal = arg(Index,DynamicSuspension,Field).
9599 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9600 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9603 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9604 suspension_term_base_fields(FA,Fields),
9605 nth1(Index,Fields,FieldName), !,
9606 Goal = setarg(Index,DynamicSuspension,Field).
9607 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9608 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9610 basic_store_types(multi_store(Types),Types) :- !.
9611 basic_store_types(Type,[Type]).
9613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9614 %
9616 :- chr_constraint
9617 phase_end/1,
9618 delay_phase_end/2.
9620 :- chr_option(mode,phase_end(+)).
9621 :- chr_option(mode,delay_phase_end(+,?)).
9623 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9624 % phase_end(Phase) <=> true.
9627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9628 :- chr_constraint
9629 does_use_history/2,
9630 uses_history/1,
9631 novel_production_call/4.
9633 :- chr_option(mode,uses_history(+)).
9634 :- chr_option(mode,does_use_history(+,+)).
9635 :- chr_option(mode,novel_production_call(+,+,?,?)).
9637 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9638 does_use_history(FA,_) \ uses_history(FA) <=> true.
9639 uses_history(_FA) <=> fail.
9641 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9642 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9644 :- chr_constraint
9645 does_use_field/2,
9646 uses_field/2.
9648 :- chr_option(mode,uses_field(+,+)).
9649 :- chr_option(mode,does_use_field(+,+)).
9651 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9652 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9653 uses_field(_FA,_Field) <=> fail.
9655 :- chr_constraint
9656 uses_state/2,
9657 if_used_state/5,
9658 used_states_known/0.
9660 :- chr_option(mode,uses_state(+,+)).
9661 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9664 % states ::= not_stored_yet | passive | active | triggered | removed
9665 %
9666 % allocate CREATES not_stored_yet
9667 % remove CHECKS not_stored_yet
9668 % activate CHECKS not_stored_yet
9669 %
9670 % ==> no allocate THEN no not_stored_yet
9672 % recurs CREATES inactive
9673 % lookup CHECKS inactive
9675 % insert CREATES active
9676 % activate CREATES active
9677 % lookup CHECKS active
9678 % recurs CHECKS active
9680 % runsusp CREATES triggered
9681 % lookup CHECKS triggered
9682 %
9683 % ==> no runsusp THEN no triggered
9685 % remove CREATES removed
9686 % runsusp CHECKS removed
9687 % lookup CHECKS removed
9688 % recurs CHECKS removed
9689 %
9690 % ==> no remove THEN no removed
9692 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9694 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9696 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9697 <=> ResultGoal = Used.
9698 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9699 <=> ResultGoal = NotUsed.
9701 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9702 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9703 % (Feature for SSS)
9704 %
9705 % 1. Checking
9706 % ~~~~~~~~~~~
9707 %
9708 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9709 %
9710 % :- chr_option(declare_stored_constraints,on).
9711 %
9712 % the compiler will check for the storedness of constraints.
9713 %
9714 % By default, the compiler assumes that the programmer wants his constraints to
9715 % be never-stored. Hence, a warning will be issues when a constraint is actually
9716 % stored.
9717 %
9718 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9719 % to a constraint declaration, i.e. writes
9720 %
9721 % :- chr_constraint c(...) # stored.
9722 %
9723 % In that case a warning is issued when the constraint is never-stored.
9724 %
9725 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9726 % constraints are stored anyway.
9727 %
9728 %
9729 % 2. Rule Generation
9730 % ~~~~~~~~~~~~~~~~~~
9731 %
9732 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9733 %
9734 % :- chr_option(declare_stored_constraints,on).
9735 %
9736 % the compiler will generate default simplification rules for constraints.
9737 %
9738 % By default, no default rule is generated for a constraint. However, if the
9739 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9740 %
9741 % :- chr_constraint c(...) # default(Goal).
9742 %
9743 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9744 % the compiler generates a rule:
9745 %
9746 % c(_,...,_) <=> Goal.
9747 %
9748 % at the end of the program. If multiple default rules are generated, for several constraints,
9749 % then the order of the default rules is not specified.
9752 :- chr_constraint stored_assertion/1.
9753 :- chr_option(mode,stored_assertion(+)).
9754 :- chr_option(type_declaration,stored_assertion(constraint)).
9756 :- chr_constraint never_stored_default/2.
9757 :- chr_option(mode,never_stored_default(+,?)).
9758 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9760 % Rule Generation
9761 % ~~~~~~~~~~~~~~~
9763 generate_never_stored_rules(Constraints,Rules) :-
9764 ( chr_pp_flag(declare_stored_constraints,on) ->
9765 never_stored_rules(Constraints,Rules)
9766 ;
9767 Rules = []
9768 ).
9770 :- chr_constraint never_stored_rules/2.
9771 :- chr_option(mode,never_stored_rules(+,?)).
9772 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9774 never_stored_rules([],Rules) <=> Rules = [].
9775 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9776 Constraint = F/A,
9777 functor(Head,F,A),
9778 inc_rule_count(RuleNb),
9779 Rule = pragma(
9780 rule([Head],[],true,Goal),
9781 ids([0],[]),
9782 [],
9783 no,
9784 RuleNb
9785 ),
9786 Rules = [Rule|Tail],
9787 never_stored_rules(Constraints,Tail).
9788 never_stored_rules([_|Constraints],Rules) <=>
9789 never_stored_rules(Constraints,Rules).
9791 % Checking
9792 % ~~~~~~~~
9794 check_storedness_assertions(Constraints) :-
9795 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9796 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9797 ;
9798 true
9799 ).
9802 :- chr_constraint check_storedness_assertion/1.
9803 :- chr_option(mode,check_storedness_assertion(+)).
9804 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9806 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9807 <=> ( is_stored(Constraint) ->
9808 true
9809 ;
9810 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9811 ).
9812 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9813 <=> ( is_finally_stored(Constraint) ->
9814 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9815 ; is_stored(Constraint) ->
9816 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9817 ;
9818 true
9819 ).
9820 % never-stored, no default goal
9821 check_storedness_assertion(Constraint)
9822 <=> ( is_finally_stored(Constraint) ->
9823 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9824 ; is_stored(Constraint) ->
9825 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9826 ;
9827 true
9828 ).
9830 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9831 % success continuation analysis
9833 % TODO
9834 % also use for forward jumping improvement!
9835 % use Prolog indexing for generated code
9836 %
9837 % EXPORTED
9838 %
9839 % should_skip_to_next_id(C,O)
9840 %
9841 % get_occurrence_code_id(C,O,Id)
9842 %
9843 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9845 continuation_analysis(ConstraintSymbols) :-
9846 maplist(analyse_continuations,ConstraintSymbols).
9848 analyse_continuations(C) :-
9849 % 1. compute success continuations of the
9850 % occurrences of constraint C
9851 continuation_analysis(C,1),
9852 % 2. determine for which occurrences
9853 % to skip to next code id
9854 get_max_occurrence(C,MO),
9855 LO is MO + 1,
9856 bulk_propagation(C,1,LO),
9857 % 3. determine code id for each occurrence
9858 set_occurrence_code_id(C,1,0).
9860 % 1. Compute the success continuations of constrait C
9861 %-------------------------------------------------------------------------------
9863 continuation_analysis(C,O) :-
9864 get_max_occurrence(C,MO),
9865 ( O > MO ->
9866 true
9867 ; O == MO ->
9868 NextO is O + 1,
9869 continuation_occurrence(C,O,NextO)
9870 ;
9871 constraint_continuation(C,O,MO,NextO),
9872 continuation_occurrence(C,O,NextO),
9873 NO is O + 1,
9874 continuation_analysis(C,NO)
9875 ).
9877 constraint_continuation(C,O,MO,NextO) :-
9878 ( get_occurrence_head(C,O,Head) ->
9879 NO is O + 1,
9880 ( between(NO,MO,NextO),
9881 get_occurrence_head(C,NextO,NextHead),
9882 unifiable(Head,NextHead,_) ->
9883 true
9884 ;
9885 NextO is MO + 1
9886 )
9887 ; % current occurrence is passive
9888 NextO = MO
9889 ).
9891 get_occurrence_head(C,O,Head) :-
9892 get_occurrence(C,O,RuleNb,Id),
9893 \+ is_passive(RuleNb,Id),
9894 get_rule(RuleNb,Rule),
9895 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
9896 ( select2(Id,Head,Ids1,H1,_,_) -> true
9897 ; select2(Id,Head,Ids2,H2,_,_)
9898 ).
9900 :- chr_constraint continuation_occurrence/3.
9901 :- chr_option(mode,continuation_occurrence(+,+,+)).
9903 :- chr_constraint get_success_continuation_occurrence/3.
9904 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
9906 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
9907 <=>
9908 X = NO.
9910 get_success_continuation_occurrence(C,O,X)
9911 <=>
9912 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
9914 % 2. figure out when to skip to next code id
9915 %-------------------------------------------------------------------------------
9916 % don't go beyond the last occurrence
9917 % we have to go to next id for storage here
9919 :- chr_constraint skip_to_next_id/2.
9920 :- chr_option(mode,skip_to_next_id(+,+)).
9922 :- chr_constraint should_skip_to_next_id/2.
9923 :- chr_option(mode,should_skip_to_next_id(+,+)).
9925 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
9926 <=>
9927 true.
9929 should_skip_to_next_id(_,_)
9930 <=>
9931 fail.
9933 :- chr_constraint bulk_propagation/3.
9934 :- chr_option(mode,bulk_propagation(+,+,+)).
9936 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
9937 <=>
9938 O >= MO
9939 |
9940 skip_to_next_id(C,O).
9941 % we have to go to the next id here because
9942 % a predecessor needs it
9943 bulk_propagation(C,O,LO)
9944 <=>
9945 LO =:= O + 1
9946 |
9947 skip_to_next_id(C,O),
9948 get_max_occurrence(C,MO),
9949 NLO is MO + 1,
9950 bulk_propagation(C,LO,NLO).
9951 % we have to go to the next id here because
9952 % we're running into a simplification rule
9953 % IMPROVE: propagate back to propagation predecessor (IF ANY)
9954 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
9955 <=>
9956 NO =:= O + 1
9957 |
9958 skip_to_next_id(C,O),
9959 get_max_occurrence(C,MO),
9960 NLO is MO + 1,
9961 bulk_propagation(C,NO,NLO).
9962 % we skip the next id here
9963 % and go to the next occurrence
9964 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
9965 <=>
9966 NextO > O + 1
9967 |
9968 NLO is min(LO,NextO),
9969 NO is O + 1,
9970 bulk_propagation(C,NO,NLO).
9971 % default case
9972 % err on the safe side
9973 bulk_propagation(C,O,LO)
9974 <=>
9975 skip_to_next_id(C,O),
9976 get_max_occurrence(C,MO),
9977 NLO is MO + 1,
9978 NO is O + 1,
9979 bulk_propagation(C,NO,NLO).
9981 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
9983 % if this occurrence is passive, but has to skip,
9984 % then the previous one must skip instead...
9985 % IMPROVE reasoning is conservative
9986 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
9987 ==>
9988 O > 1
9989 |
9990 PO is O - 1,
9991 skip_to_next_id(C,PO).
9993 % 3. determine code id of each occurrence
9994 %-------------------------------------------------------------------------------
9996 :- chr_constraint set_occurrence_code_id/3.
9997 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
9999 :- chr_constraint occurrence_code_id/3.
10000 :- chr_option(mode,occurrence_code_id(+,+,+)).
10002 % stop at the end
10003 set_occurrence_code_id(C,O,IdNb)
10004 <=>
10005 get_max_occurrence(C,MO),
10006 O > MO
10007 |
10008 occurrence_code_id(C,O,IdNb).
10010 % passive occurrences don't change the code id
10011 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10012 <=>
10013 occurrence_code_id(C,O,IdNb),
10014 NO is O + 1,
10015 set_occurrence_code_id(C,NO,IdNb).
10017 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10018 <=>
10019 occurrence_code_id(C,O,IdNb),
10020 NO is O + 1,
10021 set_occurrence_code_id(C,NO,IdNb).
10023 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10024 <=>
10025 occurrence_code_id(C,O,IdNb),
10026 NO is O + 1,
10027 NIdNb is IdNb + 1,
10028 set_occurrence_code_id(C,NO,NIdNb).
10030 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10031 <=>
10032 occurrence_code_id(C,O,IdNb),
10033 NO is O + 1,
10034 set_occurrence_code_id(C,NO,IdNb).
10036 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10038 :- chr_constraint get_occurrence_code_id/3.
10039 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10041 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10042 <=>
10043 X = IdNb.
10045 get_occurrence_code_id(C,O,X)
10046 <=>
10047 ( O == 0 ->
10048 true % X = 0
10049 ;
10050 format('no occurrence code for ~w!\n',[C:O])
10051 ).
10053 get_success_continuation_code_id(C,O,NextId) :-
10054 get_success_continuation_occurrence(C,O,NextO),
10055 get_occurrence_code_id(C,NextO,NextId).
10057 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10058 % COLLECT CONSTANTS FOR INLINING
10059 %
10060 % for SSS
10062 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10063 collect_constants(Rules,Constraints,Clauses0) :-
10064 ( not_restarted ->
10065 maplist(collect_rule_constants(Constraints),Rules),
10066 ( chr_pp_flag(verbose,on) ->
10067 print_chr_constants
10068 ;
10069 true
10070 ),
10071 ( chr_pp_flag(experiment,on) ->
10072 flattening_dictionary(Constraints,Dictionary),
10073 copy_term_nat([dict(Dictionary)|Clauses0],Clauses),
10074 flatten_clauses(Clauses,FlatClauses),
10075 install_new_declarations_and_restart(FlatClauses)
10076 ;
10077 true
10078 )
10079 ;
10080 true
10081 ).
10083 :- chr_constraint chr_constants/2.
10084 :- chr_option(mode,chr_constants(+,+)).
10086 :- chr_constraint get_chr_constants/2.
10088 chr_constants(Key,Constants) \ get_chr_constants(Key,Q) <=> Q = Constants.
10090 get_chr_constants(Key,Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10092 % collect_rule_constants(+constraint_symbols,+rule) {{{
10093 collect_rule_constants(Constraints,Rule) :-
10094 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10095 maplist(collect_head_constants,H1),
10096 maplist(collect_head_constants,H2),
10097 collect_body_constants(B,Constraints).
10099 collect_body_constants(Body,Constraints) :-
10100 conj2list(Body,Goals),
10101 maplist(collect_goal_constants(Constraints),Goals).
10103 collect_goal_constants(Constraints,Goal) :-
10104 ( nonvar(Goal),
10105 functor(Goal,C,N),
10106 memberchk(C/N,Constraints) ->
10107 collect_head_constants(Goal)
10108 ; nonvar(Goal),
10109 Goal = Mod : TheGoal,
10110 get_target_module(Module),
10111 Mod == Module,
10112 nonvar(TheGoal),
10113 functor(TheGoal,C,N),
10114 memberchk(C/N,Constraints) ->
10115 collect_head_constants(TheGoal)
10116 ;
10117 true
10118 ).
10120 collect_head_constants(Head) :-
10121 functor(Head,C,N),
10122 get_constraint_type_det(C/N,Types),
10123 Head =.. [_|Args],
10124 maplist(collect_arg_constants,Args,Types).
10126 collect_arg_constants(Arg,Type) :-
10127 ( ground(Arg),
10128 unalias_type(Type,chr_constants(Key)) ->
10129 add_chr_constant(Key,Arg)
10130 ;
10131 true
10132 ).
10133 :- chr_constraint add_chr_constant/2.
10134 :- chr_option(mode,add_chr_constant(+,+)).
10136 add_chr_constant(Key,Constant) , chr_constants(Key,Constants) <=>
10137 sort([Constant|Constants],NConstants),
10138 chr_constants(Key,NConstants).
10140 add_chr_constant(Key,Constant) <=>
10141 chr_constants(Key,[Constant]).
10143 % }}}
10145 :- chr_constraint print_chr_constants/0. % {{{
10147 print_chr_constants, chr_constants(Key,Constants) # Id ==>
10148 format('\t* chr_constants ~w : ~w.\n',[Key,Constants])
10149 pragma passive(Id).
10151 print_chr_constants <=>
10152 true.
10154 % }}}
10156 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10157 flattening_dictionary([],[]).
10158 flattening_dictionary([CS|CSs],Dictionary) :-
10159 ( flattening_dictionary_entry(CS,Entry) ->
10160 Dictionary = [Entry|Rest]
10161 ;
10162 Dictionary = Rest
10163 ),
10164 flattening_dictionary(CSs,Rest).
10166 flattening_dictionary_entry(CS,Entry) :-
10167 get_constraint_arg_type(CS,Pos,Type),
10168 Type = chr_constants(Key), !,
10169 get_chr_constants(Key,Constants),
10170 Entry = CS-Pos-Specs,
10171 maplist(flat_spec(CS,Pos),Constants,Specs).
10173 flat_spec(C/N,Pos,Term,Spec) :-
10174 Spec = Term - Functor,
10175 term_to_atom(Term,TermAtom),
10176 atom_concat_list(['$flat_',C,'/',N,'___',Pos,'___',TermAtom],Functor).
10177 % }}}
10179 % }}}
10180 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10181 % RESTART AFTER FLATTENING {{{
10183 restart_after_flattening(Declarations,Declarations) :-
10184 nb_setval('$chr_restart_after_flattening',started).
10185 restart_after_flattening(_,Declarations) :-
10186 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10187 nb_setval('$chr_restart_after_flattening',restarted).
10189 not_restarted :-
10190 nb_getval('$chr_restart_after_flattening',started).
10192 install_new_declarations_and_restart(Declarations) :-
10193 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10194 fail. /* fails to choicepoint of restart_after_flattening */
10195 % }}}
10196 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10197 % FLATTENING {{{
10199 % DONE
10200 % -) generate dictionary from collected chr_constants
10201 % enable with :- chr_option(experiment,on).
10202 % -) issue constraint declarations for constraints not present in
10203 % dictionary
10204 %
10205 % TODO:
10206 % -) integrate with CHR compiler
10207 % RELEASE-----------------------------------------------------------------
10208 % -) pass Mike's test code (full syntactic support for current CHR code)
10209 % -) rewrite the body using the inliner
10210 % -) refined semantics correctness issue
10211 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10213 flatten_clauses(Clauses0,NClauses) :-
10214 select(dict(Dict),Clauses0,Clauses),
10215 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10216 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10218 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10219 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10220 dispatching_rules(Dict,NClauses1),
10221 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10222 flatten_rules(Clauses,Dict,NClauses3),
10223 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10225 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10226 % Declarations for non-flattened constraints
10228 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10229 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10230 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_,Dict)),Symbols),
10231 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10232 flatten(DeclarationsList,Declarations).
10234 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10235 [(:- chr_constraint ConstraintSymbol),
10236 (:- chr_option(mode,ModeDeclPattern)),
10237 (:- chr_option(type_declaration,TypeDeclPattern))
10238 ]) :-
10239 ConstraintSymbol = Functor / Arity,
10240 % print optional mode declaration
10241 functor(ModeDeclPattern,Functor,Arity),
10242 ( memberchk(ModeDeclPattern,ModeDecls) ->
10243 true
10244 ;
10245 replicate(Arity,(?),Modes),
10246 ModeDeclPattern =.. [_|Modes]
10247 ),
10248 % print optional type declaration
10249 functor(TypeDeclPattern,Functor,Arity),
10250 ( memberchk(TypeDeclPattern,TypeDecls) ->
10251 true
10252 ;
10253 replicate(Arity,any,Types),
10254 TypeDeclPattern =.. [_|Types]
10255 ).
10256 % }}}
10257 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10258 % read clauses from file
10259 % CHR are returned
10260 % declared constaints are returned
10261 % type definitions are returned and printed
10262 % mode declarations are returned
10263 % other clauses are returned
10265 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10266 flatten_readcontent([],[],[],[],[],[],[]).
10267 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10268 % read(Clause),
10269 ( Clause == end_of_file ->
10270 Rules = [],
10271 ConstraintSymbols = [],
10272 ModeDecls = [],
10273 TypeDecls = [],
10274 TypeDefs = [],
10275 RestClauses = []
10276 ; crude_is_rule(Clause) ->
10277 Rules = [Clause|RestRules],
10278 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10279 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10280 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10281 append(SomeModeDecls,RestModeDecls,ModeDecls),
10282 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10283 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10284 ; is_mode_declaration(Clause,ModeDecl) ->
10285 ModeDecls = [ModeDecl|RestModeDecls],
10286 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10287 ; is_type_declaration(Clause,TypeDecl) ->
10288 TypeDecls = [TypeDecl|RestTypeDecls],
10289 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10290 ; is_type_definition(Clause,TypeDef) ->
10291 RestClauses = [Clause|NRestClauses],
10292 TypeDefs = [TypeDef|RestTypeDefs],
10293 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10294 ; ( Clause = (:- op(A,B,C)) ->
10295 % assert operators in order to read and print them out properly
10296 op(A,B,C)
10297 ;
10298 true
10299 ),
10300 RestClauses = [Clause|NRestClauses],
10301 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10302 ).
10304 crude_is_rule(_ @ _).
10305 crude_is_rule(_ pragma _).
10306 crude_is_rule(_ ==> _).
10307 crude_is_rule(_ <=> _).
10309 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10310 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10311 conj2list(Cs,Constraints0),
10312 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10314 pure_extract_type_mode([],[],[],[]).
10315 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10316 pure_extract_type_mode(R,R2,Modes,Types).
10317 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10318 functor(C,F,A),
10319 ConstraintSymbol = F/A,
10320 C =.. [_|Args],
10321 extract_types_and_modes(Args,ArgTypes,ArgModes),
10322 Mode =.. [F|ArgModes],
10323 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10324 Types = RTypes
10325 ;
10326 Types = [Type|RTypes],
10327 Type =.. [F|ArgTypes]
10328 ),
10329 pure_extract_type_mode(R,R2,Modes,RTypes).
10331 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10333 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10334 % }}}
10335 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10336 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10337 % including mode and type declarations
10339 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10340 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10341 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10342 flatten(ConstraintSpecs0,ConstraintSpecs).
10344 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10345 [(:- chr_constraint ConstraintSpec),
10346 (:- chr_option(mode,NewModeDecl)),
10347 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10348 member(C/N-I-SFs,Dict),
10349 arg_modes(C,N,ModeDecls,Modes),
10350 specialize_modes(Modes,I,SpecializedModes),
10351 arg_types(C,N,TypeDecls,Types),
10352 specialize_types(Types,I,SpecializedTypes),
10353 AN is N - 1,
10354 member(_Term-F,SFs),
10355 ConstraintSpec = F/AN,
10356 NewModeDecl =.. [F|SpecializedModes],
10357 NewTypeDecl =.. [F|SpecializedTypes].
10359 arg_modes(C,N,ModeDecls,ArgModes) :-
10360 functor(ConstraintPattern,C,N),
10361 ( memberchk(ConstraintPattern,ModeDecls) ->
10362 ConstraintPattern =.. [_|ArgModes]
10363 ;
10364 replicate(N,?,ArgModes)
10365 ).
10367 specialize_modes(Modes,I,SpecializedModes) :-
10368 split(Modes,I,Before,_At,After),
10369 append(Before,After,SpecializedModes).
10371 arg_types(C,N,TypeDecls,ArgTypes) :-
10372 functor(ConstraintPattern,C,N),
10373 ( memberchk(ConstraintPattern,TypeDecls) ->
10374 ConstraintPattern =.. [_|ArgTypes]
10375 ;
10376 replicate(N,any,ArgTypes)
10377 ).
10379 specialize_types(Types,I,SpecializedTypes) :-
10380 split(Types,I,Before,_At,After),
10381 append(Before,After,SpecializedTypes).
10382 % }}}
10384 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10385 % DISPATCHING RULES
10386 %
10387 % dispatching_rules(+dict,-newrules)
10389 % {{{
10390 dispatching_rules([],[]).
10391 dispatching_rules([CN-I-SFs|Dict], DispatchingRules) :-
10392 constraint_dispatching_rule(SFs,CN,I,DispatchingRules,RestDispatchingRules),
10393 dispatching_rules(Dict,RestDispatchingRules).
10395 constraint_dispatching_rule(SFs,CN,I,Rules,RestRules) :-
10396 ( I == 1 ->
10397 /* index on first argument */
10398 Rules0 = Rules,
10399 NCN = CN
10400 ;
10401 CN = C/N,
10402 /* reorder arguments for 1st argument indexing */
10403 functor(Head,C,N),
10404 Head =.. [_|Args],
10405 split(Args,I,BeforeArgs,IndexArg,AfterArgs),
10406 append([IndexArg|BeforeArgs],AfterArgs,ShuffledArgs),
10407 atom_concat(C,'_$shuffled',NC),
10408 Body =.. [NC|ShuffledArgs],
10409 [(Head :- Body)|Rules0] = Rules,
10410 NCN = NC / N
10411 ),
10412 dispatching_rule_term_cases(SFs,NCN,Rules0,RestRules).
10413 % dispatching_rule_cases(SFs,NCN,Rules0,RestRules).
10415 dispatching_rule_term_cases(SFs,NC/N,Rules,RestRules) :-
10416 once(pairup(Terms,Functors,SFs)),
10417 length(Terms,K),
10418 replicate(K,[],MorePatterns),
10419 Payload is N - 1,
10420 maplist(dispatching_action,Functors,Actions),
10421 dispatch_trie_index([Terms|MorePatterns],Payload,Actions,NC,Rules,RestRules).
10423 dispatching_action(Functor,PayloadArgs,Goal) :-
10424 Goal =.. [Functor|PayloadArgs].
10426 % dispatching_rule_cases([],C/N,Rules,RestRules) :-
10427 % functor(Head,C,N),
10428 % arg(1,Head,IndexArg),
10429 % Body = throw(wrong_argument(C/N,IndexArg)),
10430 % Rules = [(Head :- Body)|RestRules].
10431 % dispatching_rule_cases([Term-Name|SFs],C/N,[Rule|Rules],RestRules) :-
10432 % functor(Head,C,N),
10433 % Head =.. [_,IndexArg|RestArgs],
10434 % IndexArg = Term,
10435 % Body =.. [Name|RestArgs],
10436 % Rule = (Head :- !, Body),
10437 % dispatching_rule_special(SFs,C/N,Rules,RestRules).
10439 dispatch_trie_index([Patterns|MorePatterns],Payload,Actions,Prefix,Clauses,Tail) :-
10440 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,Actions,Clauses,Tail).
10442 dispatch_trie_step([],_,_,_,[],[],L,L) :- !.
10443 % length MorePatterns == length Patterns == length Results
10444 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,Actions,Clauses,T) :-
10445 writeln(dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,Actions,Clauses,T)),
10446 MorePatterns = [List|_],
10447 length(List,N),
10448 aggregate_all(set(F/A),
10449 ( member(Pattern,Patterns),
10450 functor(Pattern,F,A)
10451 ),
10452 FAs),
10453 N1 is N + 1,
10454 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,T).
10456 dispatch_trie_step_cases([],_,_,_,_,_,_,_,Clauses,Clauses).
10457 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,Tail) :-
10458 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses,Clauses1),
10459 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,Actions,Symbol,Prefix,Clauses1,Tail).
10461 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10462 Clause = (Head :- Body),
10463 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10464 N1 is N + Payload,
10465 functor(Head,Symbol,N1),
10466 arg(1,Head,IndexPattern),
10467 Head =.. [_,_|RestArgs],
10468 length(PayloadArgs,Payload),
10469 once(append(Vs,PayloadArgs,RestArgs)),
10470 /* IndexPattern = F(...) */
10471 functor(IndexPattern,F,A),
10472 IndexPattern =.. [_|Args],
10473 append(Args,RestArgs,RecArgs),
10474 ( RecArgs == PayloadArgs ->
10475 /* nothing more to match on */
10476 List = Tail,
10477 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10478 MoreActions = [Action],
10479 call(Action,PayloadArgs,Body)
10480 ; /* more things to match on */
10481 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10482 ( MoreActions = [OneMoreAction] ->
10483 /* only one more thing to match on */
10484 List = Tail,
10485 call(OneMoreAction,PayloadArgs,Body)
10486 ;
10487 /* more than one thing to match on */
10488 /* [ x1,..., xn]
10489 [xs1,...,xsn]
10490 */
10491 pairup(Cases,MoreCases,CasePairs),
10492 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10493 append(Args,Vs,[First|Rest]),
10494 First-Rest = CommonPatternPair,
10495 gensym(Prefix,RSymbol),
10496 append(DiffVars,PayloadArgs,RecCallVars),
10497 Body =.. [RSymbol|RecCallVars],
10498 findall(CH-CT,member([CH|CT],Differences),CPairs),
10499 once(pairup(CHs,CTs,CPairs)),
10500 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MoreActions,List,Tail)
10501 )
10502 ).
10505 % split(list,int,before,at,after).
10507 split([X|Xs],I,Before,At,After) :-
10508 ( I == 1 ->
10509 Before = [],
10510 At = X,
10511 After = Xs
10512 ;
10513 J is I - 1,
10514 Before = [X|RBefore],
10515 split(Xs,J,RBefore,At,After)
10516 ).
10518 % }}}
10519 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10520 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10521 %
10522 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10523 %
10524 % dict :== list(functor/arity-int-list(term-functor))
10526 % {{{
10527 flatten_rules(Rules,Dict,FlatRules) :-
10528 flatten_rules1(Rules,Dict,FlatRulesList),
10529 flatten(FlatRulesList,FlatRules).
10531 flatten_rules1([],_,[]).
10532 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10533 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10534 flatten_rules1(Rules,Dict,FlatRulesList).
10536 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10537 flatten_rule(Rule,Dict,NRule).
10538 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10539 flatten_rule(Rule,Dict,NRule).
10540 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10541 flatten_heads(H,Dict,NH),
10542 flatten_body(B,Dict,NB).
10543 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10544 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10545 flatten_body(B,Dict,NB).
10546 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10547 flatten_heads(H,Dict,NH),
10548 flatten_body(B,Dict,NB).
10550 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10551 flatten_heads(H1,Dict,NH1),
10552 flatten_heads(H2,Dict,NH2).
10553 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10554 flatten_heads(H,Dict,NH).
10555 flatten_heads(H,Dict,NH) :-
10556 ( functor(H,C,N),
10557 memberchk(C/N-I-SFs,Dict) ->
10558 H =.. [_|AllArgs],
10559 split(AllArgs,I,PreArgs,Arg,PostArgs),
10560 member(Term-Name,SFs),
10561 Arg = Term,
10562 append(PreArgs,PostArgs,FlatArgs),
10563 NH =.. [Name|FlatArgs]
10564 ;
10565 NH = H
10566 ).
10568 flatten_body(Body,Dict,NBody) :-
10569 conj2list(Body,Goals),
10570 maplist(flatten_goal(Dict),Goals,NGoals),
10571 list2conj(NGoals,NBody).
10573 flatten_goal(Dict,Goal,NGoal) :-
10574 ( is_specializable_goal(Goal,Dict,ArgPos)
10575 ->
10576 specialize_goal(Goal,ArgPos,NGoal)
10577 ; nonvar(Goal),
10578 Goal = Mod : TheGoal,
10579 get_target_module(Module),
10580 Mod == Module,
10581 is_specializable_goal(TheGoal,Dict,ArgPos)
10582 ->
10583 specialize_goal(TheGoal,ArgPos,NTheGoal),
10584 NGoal = Mod : NTheGoal
10585 ;
10586 NGoal = Goal
10587 ).
10589 is_specializable_goal(Goal,Dict,ArgPos) :-
10590 nonvar(Goal),
10591 functor(Goal,C,N),
10592 memberchk(C/N-ArgPos-_,Dict),
10593 arg(ArgPos,Goal,Arg),
10594 ground(Arg).
10597 specialize_goal(Goal,ArgPos,NGoal) :-
10598 functor(Goal,C,N),
10599 Goal =.. [_|Args],
10600 split(Args,ArgPos,Before,Arg,After),
10601 append(Before,After,NArgs),
10602 flat_spec(C/N,ArgPos,Arg,_-Functor),
10603 NGoal =.. [Functor|NArgs].
10604 % }}}
10606 % }}}
10607 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10608 dump_code(Clauses) :-
10609 ( chr_pp_flag(dump,on) ->
10610 maplist(portray_clause,Clauses)
10611 % member(Clause,Clauses),
10612 % copy_term_nat(Clause,NClause),
10613 % portray_clause(NClause),
10614 % fail
10615 ;
10616 true
10617 ).
10619 chr_banner :-
10620 chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]).