| blob | 15795f2484ce738dab82b3ccb26cca9036baa91c |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% TODO {{{
52 %%
53 %% URGENTLY TODO
54 %%
55 %% * add mode checking to debug mode
56 %% * add groundness info to a.i.-based observation analysis
57 %% * proper fd/index analysis
58 %% * re-add generation checking
59 %% * untangle CHR-level and target source-level generation & optimization
60 %%
61 %% AGGRESSIVE OPTIMISATION IDEAS
62 %%
63 %% * analyze history usage to determine whether/when
64 %% cheaper suspension is possible:
65 %% don't use history when all partners are passive and self never triggers
66 %% * store constraint unconditionally for unconditional propagation rule,
67 %% if first, i.e. without checking history and set trigger cont to next occ
68 %% * get rid of suspension passing for never triggered constraints,
69 %% up to allocation occurrence
70 %% * get rid of call indirection for never triggered constraints
71 %% up to first allocation occurrence.
72 %% * get rid of unnecessary indirection if last active occurrence
73 %% before unconditional removal is head2, e.g.
74 %% a \ b <=> true.
75 %% a <=> true.
76 %% * Eliminate last clause of never stored constraint, if its body
77 %% is fail, e.g.
78 %% a ...
79 %% a <=> fail.
80 %% * Specialize lookup operations and indexes for functional dependencies.
81 %%
82 %% MORE TODO
83 %%
84 %% * map A \ B <=> true | true rules
85 %% onto efficient code that empties the constraint stores of B
86 %% in O(1) time for ground constraints where A and B do not share
87 %% any variables
88 %% * ground matching seems to be not optimized for compound terms
89 %% in case of simpagation_head2 and propagation occurrences
90 %% * analysis for storage delaying (see primes for case)
91 %% * internal constraints declaration + analyses?
92 %% * Do not store in global variable store if not necessary
93 %% NOTE: affects show_store/1
94 %% * var_assoc multi-level store: variable - ground
95 %% * Do not maintain/check unnecessary propagation history
96 %% for reasons of anti-monotony
97 %% * Strengthen storage analysis for propagation rules
98 %% reason about bodies of rules only containing constraints
99 %% -> fixpoint with observation analysis
100 %% * instantiation declarations
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
103 %%
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * fd -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
112 %% ...
113 %% if( (
114 %% generator_n(Y),
115 %% test(X,Y)
116 %% ),
117 %% true,
118 %% ('_$cutto'(CP_1), fail)
119 %% ),
120 %% ...
121 %%
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
129 %% }}}
130 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
131 :- module(chr_translate,
132 [ chr_translate/2 % +Decls, -TranslatedDecls
133 , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls
134 ]).
135 %% SWI begin {{{
136 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
137 :- use_module(library(ordsets)).
138 :- use_module(library(aggregate)).
139 :- use_module(library(apply_macros)).
140 :- use_module(library(occurs)).
141 :- use_module(library(assoc)).
142 %% SWI end }}}
144 % imports and operators {{{
145 :- use_module(hprolog).
146 :- use_module(pairlist).
147 :- use_module(a_star).
148 :- use_module(listmap).
149 :- use_module(clean_code).
150 :- use_module(builtins).
151 :- use_module(find).
152 :- use_module(binomialheap).
153 :- use_module(guard_entailment).
154 :- use_module(chr_compiler_options).
155 :- use_module(chr_compiler_utility).
156 :- use_module(chr_compiler_errors).
157 :- include(chr_op).
158 :- op(1150, fx, chr_type).
159 :- op(1150, fx, chr_declaration).
160 :- op(1130, xfx, --->).
161 :- op(980, fx, (+)).
162 :- op(980, fx, (-)).
163 :- op(980, fx, (?)).
164 :- op(1150, fx, constraints).
165 :- op(1150, fx, chr_constraint).
166 % }}}
168 :- chr_option(debug,off).
169 :- chr_option(optimize,full).
170 :- chr_option(check_guard_bindings,off).
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 % Type Declarations {{{
174 :- chr_type list(T) ---> [] ; [T|list(T)].
176 :- chr_type list == list(any).
178 :- chr_type mode ---> (+) ; (-) ; (?).
180 :- chr_type maybe(T) ---> yes(T) ; no.
182 :- chr_type constraint ---> any / any.
184 :- chr_type module_name == any.
186 :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
187 :- chr_type rule ---> rule(list(any),list(any),goal,goal).
188 :- chr_type idspair ---> ids(list(id),list(id)).
190 :- chr_type pragma_type ---> passive(id)
191 ; mpassive(list(id))
192 ; already_in_heads
193 ; already_in_heads(id)
194 ; no_history
195 ; history(history_name,list(id)).
196 :- chr_type history_name== any.
198 :- chr_type rule_name == any.
199 :- chr_type rule_nb == natural.
200 :- chr_type id == natural.
201 :- chr_type occurrence == int.
203 :- chr_type goal == any.
205 :- chr_type store_type ---> default
206 ; multi_store(list(store_type))
207 ; multi_hash(list(list(int)))
208 ; multi_inthash(list(list(int)))
209 ; global_singleton
210 ; global_ground
211 % EXPERIMENTAL STORES
212 ; atomic_constants(list(int),list(any),coverage)
213 ; ground_constants(list(int),list(any),coverage)
214 ; var_assoc_store(int,list(int))
215 ; identifier_store(int)
216 ; type_indexed_identifier_store(int,any).
217 :- chr_type coverage ---> complete ; incomplete.
218 % }}}
219 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
221 %------------------------------------------------------------------------------%
222 :- chr_constraint chr_source_file/1.
223 :- chr_option(mode,chr_source_file(+)).
224 :- chr_option(type_declaration,chr_source_file(module_name)).
225 %------------------------------------------------------------------------------%
226 chr_source_file(_) \ chr_source_file(_) <=> true.
228 %------------------------------------------------------------------------------%
229 :- chr_constraint get_chr_source_file/1.
230 :- chr_option(mode,get_chr_source_file(-)).
231 :- chr_option(type_declaration,get_chr_source_file(module_name)).
232 %------------------------------------------------------------------------------%
233 chr_source_file(Mod) \ get_chr_source_file(Query)
234 <=> Query = Mod .
235 get_chr_source_file(Query)
236 <=> Query = user.
239 %------------------------------------------------------------------------------%
240 :- chr_constraint target_module/1.
241 :- chr_option(mode,target_module(+)).
242 :- chr_option(type_declaration,target_module(module_name)).
243 %------------------------------------------------------------------------------%
244 target_module(_) \ target_module(_) <=> true.
246 %------------------------------------------------------------------------------%
247 :- chr_constraint get_target_module/1.
248 :- chr_option(mode,get_target_module(-)).
249 :- chr_option(type_declaration,get_target_module(module_name)).
250 %------------------------------------------------------------------------------%
251 target_module(Mod) \ get_target_module(Query)
252 <=> Query = Mod .
253 get_target_module(Query)
254 <=> Query = user.
256 %------------------------------------------------------------------------------%
257 :- chr_constraint line_number/2.
258 :- chr_option(mode,line_number(+,+)).
259 :- chr_option(type_declaration,line_number(rule_nb,int)).
260 %------------------------------------------------------------------------------%
261 line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
263 %------------------------------------------------------------------------------%
264 :- chr_constraint get_line_number/2.
265 :- chr_option(mode,get_line_number(+,-)).
266 :- chr_option(type_declaration,get_line_number(rule_nb,int)).
267 %------------------------------------------------------------------------------%
268 line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
269 get_line_number(RuleNb,Q) <=> Q = 0. % no line number available
271 :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule
272 :- chr_option(mode,indexed_argument(+,+)).
273 :- chr_option(type_declaration,indexed_argument(constraint,int)).
275 :- chr_constraint is_indexed_argument/2.
276 :- chr_option(mode,is_indexed_argument(+,+)).
277 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
279 :- chr_constraint constraint_mode/2.
280 :- chr_option(mode,constraint_mode(+,+)).
281 :- chr_option(type_declaration,constraint_mode(constraint,list(mode))).
283 :- chr_constraint get_constraint_mode/2.
284 :- chr_option(mode,get_constraint_mode(+,-)).
285 :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))).
287 :- chr_constraint may_trigger/1.
288 :- chr_option(mode,may_trigger(+)).
289 :- chr_option(type_declaration,may_trigger(constraint)).
291 :- chr_constraint only_ground_indexed_arguments/1.
292 :- chr_option(mode,only_ground_indexed_arguments(+)).
293 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
295 :- chr_constraint none_suspended_on_variables/0.
297 :- chr_constraint are_none_suspended_on_variables/0.
299 :- chr_constraint store_type/2.
300 :- chr_option(mode,store_type(+,+)).
301 :- chr_option(type_declaration,store_type(constraint,store_type)).
303 :- chr_constraint get_store_type/2.
304 :- chr_option(mode,get_store_type(+,?)).
305 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
307 :- chr_constraint update_store_type/2.
308 :- chr_option(mode,update_store_type(+,+)).
309 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
311 :- chr_constraint actual_store_types/2.
312 :- chr_option(mode,actual_store_types(+,+)).
313 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
315 :- chr_constraint assumed_store_type/2.
316 :- chr_option(mode,assumed_store_type(+,+)).
317 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
319 :- chr_constraint validate_store_type_assumption/1.
320 :- chr_option(mode,validate_store_type_assumption(+)).
321 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
323 :- chr_constraint rule_count/1.
324 :- chr_option(mode,rule_count(+)).
325 :- chr_option(type_declaration,rule_count(natural)).
327 :- chr_constraint inc_rule_count/1.
328 :- chr_option(mode,inc_rule_count(-)).
329 :- chr_option(type_declaration,inc_rule_count(natural)).
331 rule_count(_) \ rule_count(_)
332 <=> true.
333 rule_count(C), inc_rule_count(NC)
334 <=> NC is C + 1, rule_count(NC).
335 inc_rule_count(NC)
336 <=> NC = 1, rule_count(NC).
338 :- chr_constraint passive/2.
339 :- chr_option(mode,passive(+,+)).
341 :- chr_constraint is_passive/2.
342 :- chr_option(mode,is_passive(+,+)).
344 :- chr_constraint any_passive_head/1.
345 :- chr_option(mode,any_passive_head(+)).
347 :- chr_constraint new_occurrence/4.
348 :- chr_option(mode,new_occurrence(+,+,+,+)).
350 :- chr_constraint occurrence/5.
351 :- chr_option(mode,occurrence(+,+,+,+,+)).
352 :- chr_type occurrence_type ---> simplification ; propagation.
353 :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)).
355 :- chr_constraint get_occurrence/4.
356 :- chr_option(mode,get_occurrence(+,+,-,-)).
358 :- chr_constraint get_occurrence_from_id/4.
359 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
361 :- chr_constraint max_occurrence/2.
362 :- chr_option(mode,max_occurrence(+,+)).
364 :- chr_constraint get_max_occurrence/2.
365 :- chr_option(mode,get_max_occurrence(+,-)).
367 :- chr_constraint allocation_occurrence/2.
368 :- chr_option(mode,allocation_occurrence(+,+)).
370 :- chr_constraint get_allocation_occurrence/2.
371 :- chr_option(mode,get_allocation_occurrence(+,-)).
373 :- chr_constraint rule/2.
374 :- chr_option(mode,rule(+,+)).
375 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
377 :- chr_constraint get_rule/2.
378 :- chr_option(mode,get_rule(+,-)).
379 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
381 :- chr_constraint least_occurrence/2.
382 :- chr_option(mode,least_occurrence(+,+)).
383 :- chr_option(type_declaration,least_occurrence(any,list)).
385 :- chr_constraint is_least_occurrence/1.
386 :- chr_option(mode,is_least_occurrence(+)).
389 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
390 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
391 is_indexed_argument(_,_) <=> fail.
393 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
395 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
396 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
397 Q = Mode.
398 get_constraint_mode(FA,Q) <=>
399 FA = _ / N,
400 replicate(N,(?),Q).
402 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
404 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
405 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
406 nth1(I,Mode,M),
407 M \== (+) |
408 is_stored(FA).
409 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
411 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
412 <=>
413 nth1(I,Mode,M),
414 M \== (+)
415 |
416 fail.
417 only_ground_indexed_arguments(_) <=>
418 true.
420 none_suspended_on_variables \ none_suspended_on_variables <=> true.
421 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
422 are_none_suspended_on_variables <=> fail.
423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
424 % STORE TYPES
425 %
426 % The functionality for inspecting and deciding on the different types of constraint
427 % store / indexes for constraints.
429 store_type(FA,StoreType)
430 ==> chr_pp_flag(verbose,on)
431 |
432 format('The indexes for ~w are:\n',[FA]),
433 format_storetype(StoreType).
434 % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]).
436 format_storetype(multi_store(StoreTypes)) :- !,
437 maplist(format_storetype,StoreTypes).
438 format_storetype(atomic_constants(Index,Constants,_)) :-
439 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
440 format_storetype(ground_constants(Index,Constants,_)) :-
441 format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]).
442 format_storetype(StoreType) :-
443 format('\t* ~w\n',[StoreType]).
446 % 1. Inspection
447 % ~~~~~~~~~~~~~
448 %
449 %
451 get_store_type_normal @
452 store_type(FA,Store) \ get_store_type(FA,Query)
453 <=> Query = Store.
455 get_store_type_assumed @
456 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
457 <=> Query = Store.
459 get_store_type_default @
460 get_store_type(_,Query)
461 <=> Query = default.
463 % 2. Store type registration
464 % ~~~~~~~~~~~~~~~~~~~~~~~~~~
466 actual_store_types(C,STs) \ update_store_type(C,ST)
467 <=> memberchk(ST,STs) | true.
468 update_store_type(C,ST), actual_store_types(C,STs)
469 <=>
470 actual_store_types(C,[ST|STs]).
471 update_store_type(C,ST)
472 <=>
473 actual_store_types(C,[ST]).
475 % 3. Final decision on store types
476 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys)
479 <=>
480 true % chr_pp_flag(experiment,on)
481 |
482 delete(STs,multi_hash([Index]),STs0),
483 Index = [IndexPos],
484 ( get_constraint_arg_type(C,IndexPos,Type),
485 enumerated_atomic_type(Type,Atoms) ->
486 /* use the type constants rather than the collected keys */
487 Constants = Atoms,
488 Completeness = complete
489 ;
490 Constants = Keys,
491 Completeness = incomplete
492 ),
493 actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]).
494 validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0)
495 <=>
496 true % chr_pp_flag(experiment,on)
497 |
498 ( Index = [IndexPos],
499 get_constraint_arg_type(C,IndexPos,Type),
500 ( is_chr_constants_type(Type,Key,_) -> get_chr_constants(Key,Constants)
501 ; Type = chr_enum(Constants) -> true
502 )
503 ->
504 Completeness = complete
505 ;
506 Constants = Constants0,
507 Completeness = incomplete
508 ),
509 delete(STs,multi_hash([Index]),STs0),
510 actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]).
512 get_constraint_arg_type(C,Pos,Type) :-
513 get_constraint_type(C,Types),
514 nth1(Pos,Types,Type0),
515 unalias_type(Type0,Type).
517 validate_store_type_assumption(C) \ actual_store_types(C,STs)
518 <=>
519 % chr_pp_flag(experiment,on),
520 memberchk(multi_hash([[Index]]),STs),
521 get_constraint_type(C,Types),
522 nth1(Index,Types,Type),
523 enumerated_atomic_type(Type,Atoms)
524 |
525 delete(STs,multi_hash([[Index]]),STs0),
526 actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]).
527 validate_store_type_assumption(C) \ actual_store_types(C,STs)
528 <=>
529 memberchk(multi_hash([[Index]]),STs),
530 get_constraint_arg_type(C,Index,Type),
531 ( Type = chr_enum(Constants) -> true
532 ; is_chr_constants_type(Type,Key,_) -> get_chr_constants(Key,Constants)
533 )
534 |
535 delete(STs,multi_hash([[Index]]),STs0),
536 actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]).
537 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
538 <=>
539 ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) ->
540 Stores = [global_ground|STs]
541 ;
542 Stores = STs
543 ),
544 store_type(C,multi_store(Stores)).
545 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
546 <=>
547 store_type(C,multi_store(STs)).
548 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
549 <=>
550 chr_pp_flag(debugable,on)
551 |
552 store_type(C,default).
553 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
554 <=> store_type(C,global_ground).
555 validate_store_type_assumption(C)
556 <=> true.
558 partial_store(ground_constants(_,_,incomplete)).
559 partial_store(atomic_constants(_,_,incomplete)).
561 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
562 passive(R,ID) \ passive(R,ID) <=> true.
564 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
565 is_passive(_,_) <=> fail.
567 passive(RuleNb,_) \ any_passive_head(RuleNb)
568 <=> true.
569 any_passive_head(_)
570 <=> fail.
571 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
573 max_occurrence(C,N) \ max_occurrence(C,M)
574 <=> N >= M | true.
576 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
577 NO is MO + 1,
578 occurrence(C,NO,RuleNb,ID,Type),
579 max_occurrence(C,NO).
580 new_occurrence(C,RuleNb,ID,_) <=>
581 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
583 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
584 <=> Q = MON.
585 get_max_occurrence(C,Q)
586 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
588 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
589 <=> Rule = QRule, ID = QID.
590 get_occurrence(C,O,_,_)
591 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
593 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
594 <=> QC = C, QON = ON.
595 get_occurrence_from_id(C,O,_,_)
596 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
598 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
599 % Late allocation
601 late_allocation_analysis(Cs) :-
602 ( chr_pp_flag(late_allocation,on) ->
603 maplist(late_allocation, Cs)
604 ;
605 true
606 ).
608 late_allocation(C) :- late_allocation(C,0).
609 late_allocation(C,O) :- allocation_occurrence(C,O), !.
610 late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO).
612 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
614 allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0).
616 rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==>
617 \+ is_passive(RuleNb,Id),
618 Type == propagation,
619 ( stored_in_guard_before_next_kept_occurrence(C,O) ->
620 true
621 ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule
622 is_observed(C,O)
623 ; is_least_occurrence(RuleNb) -> % propagation rule
624 is_observed(C,O)
625 ;
626 true
627 ).
629 stored_in_guard_before_next_kept_occurrence(C,O) :-
630 chr_pp_flag(store_in_guards, on),
631 NO is O + 1,
632 stored_in_guard_lookahead(C,NO).
634 :- chr_constraint stored_in_guard_lookahead/2.
635 :- chr_option(mode, stored_in_guard_lookahead(+,+)).
637 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=>
638 NO is O + 1, stored_in_guard_lookahead(C,NO).
639 occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=>
640 Type == simplification,
641 ( is_stored_in_guard(C,RuleNb) ->
642 true
643 ;
644 NO is O + 1, stored_in_guard_lookahead(C,NO)
645 ).
646 stored_in_guard_lookahead(_,_) <=> fail.
649 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
650 \ least_occurrence(RuleNb,[ID|IDs])
651 <=> AO >= O, \+ may_trigger(C) |
652 least_occurrence(RuleNb,IDs).
653 rule(RuleNb,Rule), passive(RuleNb,ID)
654 \ least_occurrence(RuleNb,[ID|IDs])
655 <=> least_occurrence(RuleNb,IDs).
657 rule(RuleNb,Rule)
658 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
659 least_occurrence(RuleNb,IDs).
661 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
662 <=> true.
663 is_least_occurrence(_)
664 <=> fail.
666 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
667 <=> Q = O.
668 get_allocation_occurrence(_,Q)
669 <=> chr_pp_flag(late_allocation,off), Q=0.
670 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
672 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
673 <=> Q = Rule.
674 get_rule(_,_)
675 <=> fail.
677 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
679 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
680 %
681 % Default store constraint index assignment.
683 :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex)
684 :- chr_option(mode,constraint_index(+,+)).
685 :- chr_option(type_declaration,constraint_index(constraint,int)).
687 :- chr_constraint get_constraint_index/2.
688 :- chr_option(mode,get_constraint_index(+,-)).
689 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
691 :- chr_constraint get_indexed_constraint/2.
692 :- chr_option(mode,get_indexed_constraint(+,-)).
693 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
695 :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
696 :- chr_option(mode,max_constraint_index(+)).
697 :- chr_option(type_declaration,max_constraint_index(int)).
699 :- chr_constraint get_max_constraint_index/1.
700 :- chr_option(mode,get_max_constraint_index(-)).
701 :- chr_option(type_declaration,get_max_constraint_index(int)).
703 constraint_index(C,Index) \ get_constraint_index(C,Query)
704 <=> Query = Index.
705 get_constraint_index(C,Query)
706 <=> fail.
708 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
709 <=> Q = C.
710 get_indexed_constraint(Index,Q)
711 <=> fail.
713 max_constraint_index(Index) \ get_max_constraint_index(Query)
714 <=> Query = Index.
715 get_max_constraint_index(Query)
716 <=> Query = 0.
718 set_constraint_indices(Constraints) :-
719 set_constraint_indices(Constraints,1).
720 set_constraint_indices([],M) :-
721 N is M - 1,
722 max_constraint_index(N).
723 set_constraint_indices([C|Cs],N) :-
724 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
725 ; get_store_type(C,var_assoc_store(_,_))) ->
726 constraint_index(C,N),
727 M is N + 1,
728 set_constraint_indices(Cs,M)
729 ;
730 set_constraint_indices(Cs,N)
731 ).
733 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
734 % Identifier Indexes
736 :- chr_constraint identifier_size/1.
737 :- chr_option(mode,identifier_size(+)).
738 :- chr_option(type_declaration,identifier_size(natural)).
740 identifier_size(_) \ identifier_size(_)
741 <=>
742 true.
744 :- chr_constraint get_identifier_size/1.
745 :- chr_option(mode,get_identifier_size(-)).
746 :- chr_option(type_declaration,get_identifier_size(natural)).
748 identifier_size(Size) \ get_identifier_size(Q)
749 <=>
750 Q = Size.
752 get_identifier_size(Q)
753 <=>
754 Q = 1.
756 :- chr_constraint identifier_index/3.
757 :- chr_option(mode,identifier_index(+,+,+)).
758 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
760 identifier_index(C,I,_) \ identifier_index(C,I,_)
761 <=>
762 true.
764 :- chr_constraint get_identifier_index/3.
765 :- chr_option(mode,get_identifier_index(+,+,-)).
766 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
768 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
769 <=>
770 Q = II.
771 identifier_size(Size), get_identifier_index(C,I,Q)
772 <=>
773 NSize is Size + 1,
774 identifier_index(C,I,NSize),
775 identifier_size(NSize),
776 Q = NSize.
777 get_identifier_index(C,I,Q)
778 <=>
779 identifier_index(C,I,2),
780 identifier_size(2),
781 Q = 2.
783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
784 % Type Indexed Identifier Indexes
786 :- chr_constraint type_indexed_identifier_size/2.
787 :- chr_option(mode,type_indexed_identifier_size(+,+)).
788 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
790 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
791 <=>
792 true.
794 :- chr_constraint get_type_indexed_identifier_size/2.
795 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
796 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
798 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
799 <=>
800 Q = Size.
802 get_type_indexed_identifier_size(IndexType,Q)
803 <=>
804 Q = 1.
806 :- chr_constraint type_indexed_identifier_index/4.
807 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
808 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
810 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
811 <=>
812 true.
814 :- chr_constraint get_type_indexed_identifier_index/4.
815 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
816 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
818 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
819 <=>
820 Q = II.
821 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
822 <=>
823 NSize is Size + 1,
824 type_indexed_identifier_index(IndexType,C,I,NSize),
825 type_indexed_identifier_size(IndexType,NSize),
826 Q = NSize.
827 get_type_indexed_identifier_index(IndexType,C,I,Q)
828 <=>
829 type_indexed_identifier_index(IndexType,C,I,2),
830 type_indexed_identifier_size(IndexType,2),
831 Q = 2.
833 type_indexed_identifier_structure(IndexType,Structure) :-
834 type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
835 get_type_indexed_identifier_size(IndexType,Arity),
836 functor(Structure,Functor,Arity).
837 type_indexed_identifier_name(IndexType,Prefix,Name) :-
838 ( atom(IndexType) ->
839 IndexTypeName = IndexType
840 ;
841 term_to_atom(IndexType,IndexTypeName)
842 ),
843 atom_concat_list([Prefix,'_',IndexTypeName],Name).
845 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
850 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
851 %%
852 %% Translation
854 chr_translate(Declarations,NewDeclarations) :-
855 chr_translate_line_info(Declarations,'bootstrap',NewDeclarations).
857 chr_translate_line_info(Declarations0,File,NewDeclarations) :-
858 chr_banner,
859 restart_after_flattening(Declarations0,Declarations),
860 init_chr_pp_flags,
861 chr_source_file(File),
862 /* sort out the interesting stuff from the input */
863 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
864 chr_compiler_options:sanity_check,
866 dump_code(Declarations),
868 check_declared_constraints(Constraints0),
869 generate_show_constraint(Constraints0,Constraints,Rules0,Rules1),
870 add_constraints(Constraints),
871 add_rules(Rules1),
872 generate_never_stored_rules(Constraints,NewRules),
873 add_rules(NewRules),
874 append(Rules1,NewRules,Rules),
875 chr_analysis(Rules,Constraints,Declarations),
876 time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
877 time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
878 phase_end(validate_store_type_assumptions),
879 used_states_known,
880 time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
881 insert_declarations(OtherClauses, Clauses0),
882 chr_module_declaration(CHRModuleDeclaration),
883 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
884 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
885 append([Clauses0,GeneratedClauses], NewDeclarations),
886 dump_code(NewDeclarations),
887 !. /* cut choicepoint of restart_after_flattening */
889 chr_analysis(Rules,Constraints,Declarations) :-
890 check_rules(Rules,Constraints),
891 time('type checking',chr_translate:static_type_check),
892 /* constants */
893 collect_constants(Rules,Constraints,Declarations),
894 add_occurrences(Rules),
895 time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
896 time('set semantics',chr_translate:set_semantics_rules(Rules)),
897 time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
898 time('guard simplification',chr_translate:guard_simplification),
899 time('late storage',chr_translate:storage_analysis(Constraints)),
900 time('observation',chr_translate:observation_analysis(Constraints)),
901 time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
902 time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
903 partial_wake_analysis,
904 time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
905 time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
906 time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)),
907 time('continuation analysis',chr_translate:continuation_analysis(Constraints)).
909 store_management_preds(Constraints,Clauses) :-
910 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
911 generate_attr_unify_hook(AttrUnifyHookClauses),
912 generate_attach_increment(AttachIncrementClauses),
913 generate_extra_clauses(Constraints,ExtraClauses),
914 generate_insert_delete_constraints(Constraints,DeleteClauses),
915 generate_attach_code(Constraints,StoreClauses),
916 generate_counter_code(CounterClauses),
917 generate_dynamic_type_check_clauses(TypeCheckClauses),
918 append([AttachAConstraintClauses
919 ,AttachIncrementClauses
920 ,AttrUnifyHookClauses
921 ,ExtraClauses
922 ,DeleteClauses
923 ,StoreClauses
924 ,CounterClauses
925 ,TypeCheckClauses
926 ]
927 ,Clauses).
930 insert_declarations(Clauses0, Clauses) :-
931 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
932 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
934 auxiliary_module(chr_hashtable_store).
935 auxiliary_module(chr_integertable_store).
936 auxiliary_module(chr_assoc_store).
938 generate_counter_code(Clauses) :-
939 ( chr_pp_flag(store_counter,on) ->
940 Clauses = [
941 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
942 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
943 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
944 (:- '$counter_init'('$insert_counter')),
945 (:- '$counter_init'('$delete_counter')),
946 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
947 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
948 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
949 ]
950 ;
951 Clauses = []
952 ).
954 % for systems with multifile declaration
955 chr_module_declaration(CHRModuleDeclaration) :-
956 get_target_module(Mod),
957 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
958 CHRModuleDeclaration = [
959 (:- multifile chr:'$chr_module'/1),
960 chr:'$chr_module'(Mod)
961 ]
962 ;
963 CHRModuleDeclaration = []
964 ).
967 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
968 %%
969 %% Partitioning of clauses into constraint declarations, chr rules and other
970 %% clauses
972 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
973 %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
974 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
975 partition_clauses([],[],[],[]).
976 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
977 ( parse_rule(Clause,Rule) ->
978 ConstraintDeclarations = RestConstraintDeclarations,
979 Rules = [Rule|RestRules],
980 OtherClauses = RestOtherClauses
981 ; is_declaration(Clause,ConstraintDeclaration) ->
982 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
983 Rules = RestRules,
984 OtherClauses = RestOtherClauses
985 ; is_module_declaration(Clause,Mod) ->
986 target_module(Mod),
987 ConstraintDeclarations = RestConstraintDeclarations,
988 Rules = RestRules,
989 OtherClauses = [Clause|RestOtherClauses]
990 ; is_type_definition(Clause) ->
991 ConstraintDeclarations = RestConstraintDeclarations,
992 Rules = RestRules,
993 OtherClauses = RestOtherClauses
994 ; is_chr_declaration(Clause) ->
995 ConstraintDeclarations = RestConstraintDeclarations,
996 Rules = RestRules,
997 OtherClauses = RestOtherClauses
998 ; Clause = (handler _) ->
999 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
1000 ConstraintDeclarations = RestConstraintDeclarations,
1001 Rules = RestRules,
1002 OtherClauses = RestOtherClauses
1003 ; Clause = (rules _) ->
1004 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
1005 ConstraintDeclarations = RestConstraintDeclarations,
1006 Rules = RestRules,
1007 OtherClauses = RestOtherClauses
1008 ; Clause = option(OptionName,OptionValue) ->
1009 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
1010 handle_option(OptionName,OptionValue),
1011 ConstraintDeclarations = RestConstraintDeclarations,
1012 Rules = RestRules,
1013 OtherClauses = RestOtherClauses
1014 ; Clause = (:-chr_option(OptionName,OptionValue)) ->
1015 handle_option(OptionName,OptionValue),
1016 ConstraintDeclarations = RestConstraintDeclarations,
1017 Rules = RestRules,
1018 OtherClauses = RestOtherClauses
1019 ; Clause = ('$chr_compiled_with_version'(_)) ->
1020 ConstraintDeclarations = RestConstraintDeclarations,
1021 Rules = RestRules,
1022 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
1023 ; ConstraintDeclarations = RestConstraintDeclarations,
1024 Rules = RestRules,
1025 OtherClauses = [Clause|RestOtherClauses]
1026 ),
1027 partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
1029 '$chr_compiled_with_version'(2).
1031 is_declaration(D, Constraints) :- %% constraint declaration
1032 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
1033 conj2list(Cs,Constraints0)
1034 ;
1035 ( D = (:- Decl) ->
1036 Decl =.. [constraints,Cs]
1037 ;
1038 D =.. [constraints,Cs]
1039 ),
1040 conj2list(Cs,Constraints0),
1041 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
1042 ),
1043 extract_type_mode(Constraints0,Constraints).
1045 extract_type_mode([],[]).
1046 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
1047 extract_type_mode([C0|R],[ConstraintSymbol|R2]) :-
1048 ( C0 = C # Annotation ->
1049 functor(C,F,A),
1050 extract_annotation(Annotation,F/A)
1051 ;
1052 C0 = C,
1053 functor(C,F,A)
1054 ),
1055 ConstraintSymbol = F/A,
1056 C =.. [_|Args],
1057 extract_types_and_modes(Args,ArgTypes,ArgModes),
1058 assert_constraint_type(ConstraintSymbol,ArgTypes),
1059 constraint_mode(ConstraintSymbol,ArgModes),
1060 extract_type_mode(R,R2).
1062 extract_annotation(stored,Symbol) :-
1063 stored_assertion(Symbol).
1064 extract_annotation(default(Goal),Symbol) :-
1065 never_stored_default(Symbol,Goal).
1067 extract_types_and_modes([],[],[]).
1068 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
1069 extract_type_and_mode(X,T,M),
1070 extract_types_and_modes(R,R2,R3).
1072 extract_type_and_mode(+(T),T,(+)) :- !.
1073 extract_type_and_mode(?(T),T,(?)) :- !.
1074 extract_type_and_mode(-(T),T,(-)) :- !.
1075 extract_type_and_mode((+),any,(+)) :- !.
1076 extract_type_and_mode((?),any,(?)) :- !.
1077 extract_type_and_mode((-),any,(-)) :- !.
1078 extract_type_and_mode(Illegal,_,_) :-
1079 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
1081 is_chr_declaration(Declaration) :-
1082 Declaration = (:- chr_declaration Decl),
1083 ( Decl = (Pattern ---> Information) ->
1084 background_info(Pattern,Information)
1085 ; Decl = Information ->
1086 background_info([Information])
1087 ).
1088 is_type_definition(Declaration) :-
1089 is_type_definition(Declaration,Result),
1090 assert_type_definition(Result).
1092 assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList).
1093 assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name).
1095 is_type_definition(Declaration,Result) :-
1096 ( Declaration = (:- TDef) ->
1097 true
1098 ;
1099 Declaration = TDef
1100 ),
1101 TDef =.. [chr_type,TypeDef],
1102 ( TypeDef = (Name ---> Def) ->
1103 tdisj2list(Def,DefList),
1104 Result = typedef(Name,DefList)
1105 ; TypeDef = (Alias == Name) ->
1106 Result = alias(Alias,Name)
1107 ;
1108 Result = typedef(TypeDef,[]),
1109 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
1110 ).
1112 %% tdisj2list(+Goal,-ListOfGoals) is det.
1113 %
1114 % no removal of fails, e.g. :- type bool ---> true ; fail.
1115 tdisj2list(Conj,L) :-
1116 tdisj2list(Conj,L,[]).
1118 tdisj2list(Conj,L,T) :-
1119 Conj = (G1;G2), !,
1120 tdisj2list(G1,L,T1),
1121 tdisj2list(G2,T1,T).
1122 tdisj2list(G,[G | T],T).
1125 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1126 %% parse_rule(+term,-pragma_rule) is semidet.
1127 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1128 parse_rule(RI,R) :- %% name @ rule
1129 RI = (Name @ RI2), !,
1130 rule(RI2,yes(Name),R).
1131 parse_rule(RI,R) :-
1132 rule(RI,no,R).
1134 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1135 %% parse_rule(+term,-pragma_rule) is semidet.
1136 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
1137 rule(RI,Name,R) :-
1138 RI = (RI2 pragma P), !, %% pragmas
1139 ( var(P) ->
1140 Ps = [_] % intercept variable
1141 ;
1142 conj2list(P,Ps)
1143 ),
1144 inc_rule_count(RuleCount),
1145 R = pragma(R1,IDs,Ps,Name,RuleCount),
1146 is_rule(RI2,R1,IDs,R).
1147 rule(RI,Name,R) :-
1148 inc_rule_count(RuleCount),
1149 R = pragma(R1,IDs,[],Name,RuleCount),
1150 is_rule(RI,R1,IDs,R).
1152 is_rule(RI,R,IDs,RC) :- %% propagation rule
1153 RI = (H ==> B), !,
1154 conj2list(H,Head2i),
1155 get_ids(Head2i,IDs2,Head2,RC),
1156 IDs = ids([],IDs2),
1157 ( B = (G | RB) ->
1158 R = rule([],Head2,G,RB)
1159 ;
1160 R = rule([],Head2,true,B)
1161 ).
1162 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
1163 RI = (H <=> B), !,
1164 ( B = (G | RB) ->
1165 Guard = G,
1166 Body = RB
1167 ; Guard = true,
1168 Body = B
1169 ),
1170 ( H = (H1 \ H2) ->
1171 conj2list(H1,Head2i),
1172 conj2list(H2,Head1i),
1173 get_ids(Head2i,IDs2,Head2,0,N,RC),
1174 get_ids(Head1i,IDs1,Head1,N,_,RC),
1175 IDs = ids(IDs1,IDs2)
1176 ; conj2list(H,Head1i),
1177 Head2 = [],
1178 get_ids(Head1i,IDs1,Head1,RC),
1179 IDs = ids(IDs1,[])
1180 ),
1181 R = rule(Head1,Head2,Guard,Body).
1183 get_ids(Cs,IDs,NCs,RC) :-
1184 get_ids(Cs,IDs,NCs,0,_,RC).
1186 get_ids([],[],[],N,N,_).
1187 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
1188 ( C = (NC # N1) ->
1189 ( var(N1) ->
1190 N1 = N
1191 ;
1192 check_direct_pragma(N1,N,RC)
1193 )
1194 ;
1195 NC = C
1196 ),
1197 M is N + 1,
1198 get_ids(Cs,IDs,NCs, M,NN,RC).
1200 check_direct_pragma(passive,Id,PragmaRule) :- !,
1201 PragmaRule = pragma(_,_,_,_,RuleNb),
1202 passive(RuleNb,Id).
1203 check_direct_pragma(Abbrev,Id,PragmaRule) :-
1204 ( direct_pragma(FullPragma),
1205 atom_concat(Abbrev,Remainder,FullPragma) ->
1206 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
1207 ;
1208 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
1209 ).
1211 direct_pragma(passive).
1213 is_module_declaration((:- module(Mod)),Mod).
1214 is_module_declaration((:- module(Mod,_)),Mod).
1216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1219 % Add constraints
1220 add_constraints([]).
1221 add_constraints([C|Cs]) :-
1222 max_occurrence(C,0),
1223 C = _/A,
1224 length(Mode,A),
1225 set_elems(Mode,?),
1226 constraint_mode(C,Mode),
1227 add_constraints(Cs).
1229 % Add rules
1230 add_rules([]).
1231 add_rules([Rule|Rules]) :-
1232 Rule = pragma(_,_,_,_,RuleNb),
1233 rule(RuleNb,Rule),
1234 add_rules(Rules).
1236 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1239 %% Some input verification:
1241 check_declared_constraints(Constraints) :-
1242 tree_set_empty(Acc),
1243 check_declared_constraints(Constraints,Acc).
1245 check_declared_constraints([],_).
1246 check_declared_constraints([C|Cs],Acc) :-
1247 ( tree_set_memberchk(C,Acc) ->
1248 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1249 ;
1250 true
1251 ),
1252 tree_set_add(Acc,C,NAcc),
1253 check_declared_constraints(Cs,NAcc).
1255 %% - all constraints in heads are declared constraints
1256 %% - all passive pragmas refer to actual head constraints
1258 check_rules([],_).
1259 check_rules([PragmaRule|Rest],Decls) :-
1260 check_rule(PragmaRule,Decls),
1261 check_rules(Rest,Decls).
1263 check_rule(PragmaRule,Decls) :-
1264 check_rule_indexing(PragmaRule),
1265 check_trivial_propagation_rule(PragmaRule),
1266 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1267 Rule = rule(H1,H2,_,_),
1268 append(H1,H2,HeadConstraints),
1269 check_head_constraints(HeadConstraints,Decls,PragmaRule),
1270 check_pragmas(Pragmas,PragmaRule).
1272 % Make all heads passive in trivial propagation rule
1273 % ... ==> ... | true.
1274 check_trivial_propagation_rule(PragmaRule) :-
1275 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1276 ( Rule = rule([],_,_,true) ->
1277 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1278 set_all_passive(RuleNb)
1279 ;
1280 true
1281 ).
1283 check_head_constraints([],_,_).
1284 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1285 functor(Constr,F,A),
1286 ( memberchk(F/A,Decls) ->
1287 check_head_constraints(Rest,Decls,PragmaRule)
1288 ;
1289 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1290 ).
1292 check_pragmas([],_).
1293 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1294 check_pragma(Pragma,PragmaRule),
1295 check_pragmas(Pragmas,PragmaRule).
1297 check_pragma(Pragma,PragmaRule) :-
1298 var(Pragma), !,
1299 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1300 check_pragma(passive(ID), PragmaRule) :-
1301 !,
1302 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1303 ( memberchk_eq(ID,IDs1) ->
1304 true
1305 ; memberchk_eq(ID,IDs2) ->
1306 true
1307 ;
1308 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1309 ),
1310 passive(RuleNb,ID).
1312 check_pragma(mpassive(IDs), PragmaRule) :-
1313 !,
1314 PragmaRule = pragma(_,_,_,_,RuleNb),
1315 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1316 maplist(passive(RuleNb),IDs).
1318 check_pragma(Pragma, PragmaRule) :-
1319 Pragma = already_in_heads,
1320 !,
1321 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1323 check_pragma(Pragma, PragmaRule) :-
1324 Pragma = already_in_head(_),
1325 !,
1326 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1328 check_pragma(Pragma, PragmaRule) :-
1329 Pragma = no_history,
1330 !,
1331 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1332 PragmaRule = pragma(_,_,_,_,N),
1333 no_history(N).
1335 check_pragma(Pragma, PragmaRule) :-
1336 Pragma = history(HistoryName,IDs),
1337 !,
1338 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1339 chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1340 ( IDs1 \== [] ->
1341 chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[])
1342 ; \+ atom(HistoryName) ->
1343 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb])
1344 ; \+ is_set(IDs) ->
1345 chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb])
1346 ; check_history_pragma_ids(IDs,IDs1,IDs2) ->
1347 history(RuleNb,HistoryName,IDs)
1348 ;
1349 chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb])
1350 ).
1351 check_pragma(Pragma,PragmaRule) :-
1352 Pragma = line_number(LineNumber),
1353 !,
1354 PragmaRule = pragma(_,_,_,_,RuleNb),
1355 line_number(RuleNb,LineNumber).
1357 check_history_pragma_ids([], _, _).
1358 check_history_pragma_ids([ID|IDs],IDs1,IDs2) :-
1359 ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ),
1360 check_history_pragma_ids(IDs,IDs1,IDs2).
1362 check_pragma(Pragma,PragmaRule) :-
1363 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1365 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1366 %% no_history(+RuleNb) is det.
1367 :- chr_constraint no_history/1.
1368 :- chr_option(mode,no_history(+)).
1369 :- chr_option(type_declaration,no_history(int)).
1371 %% has_no_history(+RuleNb) is semidet.
1372 :- chr_constraint has_no_history/1.
1373 :- chr_option(mode,has_no_history(+)).
1374 :- chr_option(type_declaration,has_no_history(int)).
1376 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1377 has_no_history(_) <=> fail.
1379 :- chr_constraint history/3.
1380 :- chr_option(mode,history(+,+,+)).
1381 :- chr_option(type_declaration,history(any,any,list)).
1383 :- chr_constraint named_history/3.
1385 history(RuleNb,_,_), history(RuleNb,_,_) ==>
1386 chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %'
1388 history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==>
1389 length(IDs1,L1), length(IDs2,L2),
1390 ( L1 \== L2 ->
1391 chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name])
1392 ;
1393 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2)
1394 ).
1396 test_named_history_id_pairs(_, [], _, []).
1397 test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :-
1398 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2),
1399 test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2).
1401 :- chr_constraint test_named_history_id_pair/4.
1402 :- chr_option(mode,test_named_history_id_pair(+,+,+,+)).
1404 occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_)
1405 \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true.
1406 test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=>
1407 chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]).
1409 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1410 named_history(_,_,_) <=> fail.
1412 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1415 format_rule(PragmaRule) :-
1416 PragmaRule = pragma(_,_,_,MaybeName,RuleNumber),
1417 ( MaybeName = yes(Name) ->
1418 write('rule '), write(Name)
1419 ;
1420 write('rule number '), write(RuleNumber)
1421 ),
1422 get_line_number(RuleNumber,LineNumber),
1423 write(' (line '),
1424 write(LineNumber),
1425 write(')').
1427 check_rule_indexing(PragmaRule) :-
1428 PragmaRule = pragma(Rule,_,_,_,_),
1429 Rule = rule(H1,H2,G,_),
1430 term_variables(H1-H2,HeadVars),
1431 remove_anti_monotonic_guards(G,HeadVars,NG),
1432 check_indexing(H1,NG-H2),
1433 check_indexing(H2,NG-H1),
1434 % EXPERIMENT
1435 ( chr_pp_flag(term_indexing,on) ->
1436 term_variables(NG,GuardVariables),
1437 append(H1,H2,Heads),
1438 check_specs_indexing(Heads,GuardVariables,Specs)
1439 ;
1440 true
1441 ).
1443 :- chr_constraint indexing_spec/2.
1444 :- chr_option(mode,indexing_spec(+,+)).
1446 :- chr_constraint get_indexing_spec/2.
1447 :- chr_option(mode,get_indexing_spec(+,-)).
1450 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1451 get_indexing_spec(_,Spec) <=> Spec = [].
1453 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1454 <=>
1455 append(Specs1,Specs2,Specs),
1456 indexing_spec(FA,Specs).
1458 remove_anti_monotonic_guards(G,Vars,NG) :-
1459 conj2list(G,GL),
1460 remove_anti_monotonic_guard_list(GL,Vars,NGL),
1461 list2conj(NGL,NG).
1463 remove_anti_monotonic_guard_list([],_,[]).
1464 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1465 ( G = var(X), memberchk_eq(X,Vars) ->
1466 NGs = RGs
1467 % TODO: this is not correct
1468 % ; G = functor(Term,Functor,Arity), % isotonic
1469 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1470 % NGs = RGs
1471 ;
1472 NGs = [G|RGs]
1473 ),
1474 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1476 check_indexing([],_).
1477 check_indexing([Head|Heads],Other) :-
1478 functor(Head,F,A),
1479 Head =.. [_|Args],
1480 term_variables(Heads-Other,OtherVars),
1481 check_indexing(Args,1,F/A,OtherVars),
1482 check_indexing(Heads,[Head|Other]).
1484 check_indexing([],_,_,_).
1485 check_indexing([Arg|Args],I,FA,OtherVars) :-
1486 ( is_indexed_argument(FA,I) ->
1487 true
1488 ; nonvar(Arg) ->
1489 indexed_argument(FA,I)
1490 ; % var(Arg) ->
1491 term_variables(Args,ArgsVars),
1492 append(ArgsVars,OtherVars,RestVars),
1493 ( memberchk_eq(Arg,RestVars) ->
1494 indexed_argument(FA,I)
1495 ;
1496 true
1497 )
1498 ),
1499 J is I + 1,
1500 term_variables(Arg,NVars),
1501 append(NVars,OtherVars,NOtherVars),
1502 check_indexing(Args,J,FA,NOtherVars).
1504 check_specs_indexing([],_,[]).
1505 check_specs_indexing([Head|Heads],Variables,Specs) :-
1506 Specs = [Spec|RSpecs],
1507 term_variables(Heads,OtherVariables,Variables),
1508 check_spec_indexing(Head,OtherVariables,Spec),
1509 term_variables(Head,NVariables,Variables),
1510 check_specs_indexing(Heads,NVariables,RSpecs).
1512 check_spec_indexing(Head,OtherVariables,Spec) :-
1513 functor(Head,F,A),
1514 Spec = spec(F,A,ArgSpecs),
1515 Head =.. [_|Args],
1516 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1517 indexing_spec(F/A,[ArgSpecs]).
1519 check_args_spec_indexing([],_,_,[]).
1520 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1521 term_variables(Args,Variables,OtherVariables),
1522 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1523 ArgSpecs = [ArgSpec|RArgSpecs]
1524 ;
1525 ArgSpecs = RArgSpecs
1526 ),
1527 J is I + 1,
1528 term_variables(Arg,NOtherVariables,OtherVariables),
1529 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1531 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1532 ( var(Arg) ->
1533 memberchk_eq(Arg,Variables),
1534 ArgSpec = specinfo(I,any,[])
1535 ;
1536 functor(Arg,F,A),
1537 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1538 Arg =.. [_|Args],
1539 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1540 ).
1542 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1544 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1545 % Occurrences
1547 add_occurrences([]).
1548 add_occurrences([Rule|Rules]) :-
1549 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1550 add_occurrences(H1,IDs1,simplification,Nb),
1551 add_occurrences(H2,IDs2,propagation,Nb),
1552 add_occurrences(Rules).
1554 add_occurrences([],[],_,_).
1555 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1556 functor(H,F,A),
1557 FA = F/A,
1558 new_occurrence(FA,RuleNb,ID,Type),
1559 add_occurrences(Hs,IDs,Type,RuleNb).
1561 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1563 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1564 % Observation Analysis
1565 %
1566 % CLASSIFICATION
1567 %
1568 %
1569 %
1570 %
1571 %
1572 %
1574 :- chr_constraint observation_analysis/1.
1575 :- chr_option(mode, observation_analysis(+)).
1577 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1578 PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1579 ( chr_pp_flag(store_in_guards, on) ->
1580 observation_analysis(RuleNb, Guard, guard, Cs)
1581 ;
1582 true
1583 ),
1584 observation_analysis(RuleNb, Body, body, Cs)
1586 pragma passive(Id).
1587 observation_analysis(_) <=> true.
1589 observation_analysis(RuleNb, Term, GB, Cs) :-
1590 ( all_spawned(RuleNb,GB) ->
1591 true
1592 ; var(Term) ->
1593 spawns_all(RuleNb,GB)
1594 ; Term = true ->
1595 true
1596 ; Term = fail ->
1597 true
1598 ; Term = '!' ->
1599 true
1600 ; Term = (T1,T2) ->
1601 observation_analysis(RuleNb,T1,GB,Cs),
1602 observation_analysis(RuleNb,T2,GB,Cs)
1603 ; Term = (T1;T2) ->
1604 observation_analysis(RuleNb,T1,GB,Cs),
1605 observation_analysis(RuleNb,T2,GB,Cs)
1606 ; Term = (T1->T2) ->
1607 observation_analysis(RuleNb,T1,GB,Cs),
1608 observation_analysis(RuleNb,T2,GB,Cs)
1609 ; Term = (\+ T) ->
1610 observation_analysis(RuleNb,T,GB,Cs)
1611 ; functor(Term,F,A), memberchk(F/A,Cs) ->
1612 spawns(RuleNb,GB,F/A)
1613 ; Term = (_ = _) ->
1614 spawns_all_triggers(RuleNb,GB)
1615 ; Term = (_ is _) ->
1616 spawns_all_triggers(RuleNb,GB)
1617 ; builtin_binds_b(Term,Vars) ->
1618 ( Vars == [] ->
1619 true
1620 ;
1621 spawns_all_triggers(RuleNb,GB)
1622 )
1623 ;
1624 spawns_all(RuleNb,GB)
1625 ).
1627 :- chr_constraint spawns/3.
1628 :- chr_option(mode, spawns(+,+,+)).
1629 :- chr_type spawns_type ---> guard ; body.
1630 :- chr_option(type_declaration,spawns(any,spawns_type,any)).
1632 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1633 :- chr_option(mode, spawns_all(+,+)).
1634 :- chr_option(type_declaration,spawns_all(any,spawns_type)).
1635 :- chr_option(mode, spawns_all_triggers(+,+)).
1636 :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)).
1638 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1639 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1640 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1641 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1642 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1643 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1645 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1646 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1647 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1648 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1650 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1651 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1653 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1654 \
1655 spawns(RuleNb1,GB,C1)
1656 <=>
1657 \+ is_passive(RuleNb2,O)
1658 |
1659 spawns_all(RuleNb1,GB)
1660 pragma
1661 passive(Id).
1663 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1664 ==>
1665 \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early...
1666 \+ is_passive(RuleNb2,O), may_trigger(C1)
1667 |
1668 spawns_all_triggers_implies_spawns_all
1669 pragma
1670 passive(Id).
1672 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1673 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1674 spawns_all_triggers_implies_spawns_all \
1675 spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1677 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1678 \
1679 spawns(RuleNb1,GB,C1)
1680 <=>
1681 may_trigger(C1),
1682 \+ is_passive(RuleNb2,O)
1683 |
1684 spawns_all_triggers(RuleNb1,GB)
1685 pragma
1686 passive(Id).
1688 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id,
1689 spawns(RuleNb1,GB,C1)
1690 ==>
1691 \+ may_trigger(C1),
1692 \+ is_passive(RuleNb2,O)
1693 |
1694 spawns_all_triggers(RuleNb1,GB)
1695 pragma
1696 passive(Id).
1698 % a bit dangerous this rule: could start propagating too much too soon?
1699 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1700 spawns(RuleNb1,GB,C1)
1701 ==>
1702 RuleNb1 \== RuleNb2, C1 \== C2,
1703 \+ is_passive(RuleNb2,O)
1704 |
1705 spawns(RuleNb1,GB,C2)
1706 pragma
1707 passive(Id).
1709 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1710 spawns_all_triggers(RuleNb1,GB)
1711 ==>
1712 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1713 |
1714 spawns(RuleNb1,GB,C2)
1715 pragma
1716 passive(Id).
1719 :- chr_constraint all_spawned/2.
1720 :- chr_option(mode, all_spawned(+,+)).
1721 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1722 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1723 all_spawned(RuleNb,GB) <=> fail.
1726 % Overview of the supported queries:
1727 % is_observed(+functor/artiy, +occurrence_number, +(guard;body))
1728 % only succeeds if the occurrence is observed by the
1729 % guard resp. body (depending on the last argument) of its rule
1730 % is_observed(+functor/artiy, +occurrence_number, -)
1731 % succeeds if the occurrence is observed by either the guard or
1732 % the body of its rule
1733 % NOTE: the last argument is NOT bound by this query
1734 %
1735 % do_is_observed(+functor/artiy,+rule_number,+(guard;body))
1736 % succeeds if the given constraint is observed by the given
1737 % guard resp. body
1738 % do_is_observed(+functor/artiy,+rule_number)
1739 % succeeds if the given constraint is observed by the given
1740 % rule (either its guard or its body)
1743 is_observed(C,O) :-
1744 is_observed(C,O,_),
1745 ai_is_observed(C,O).
1747 is_stored_in_guard(C,RuleNb) :-
1748 chr_pp_flag(store_in_guards, on),
1749 do_is_observed(C,RuleNb,guard).
1751 :- chr_constraint is_observed/3.
1752 :- chr_option(mode, is_observed(+,+,+)).
1753 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1754 is_observed(_,_,_) <=> fail. % this will not happen in practice
1757 :- chr_constraint do_is_observed/3.
1758 :- chr_option(mode, do_is_observed(+,+,?)).
1759 :- chr_constraint do_is_observed/2.
1760 :- chr_option(mode, do_is_observed(+,+)).
1762 do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb).
1764 % (1) spawns_all
1765 % a constraint C is observed if the GB of the rule it occurs in spawns all,
1766 % and some non-passive occurrence of some (possibly other) constraint
1767 % exists in a rule (could be same rule) with at least one occurrence of C
1769 spawns_all(RuleNb,GB),
1770 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1771 \
1772 do_is_observed(C,RuleNb,GB)
1773 <=>
1774 \+ is_passive(RuleNb2,O)
1775 |
1776 true.
1778 spawns_all(RuleNb,_),
1779 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1780 \
1781 do_is_observed(C,RuleNb)
1782 <=>
1783 \+ is_passive(RuleNb2,O)
1784 |
1785 true.
1787 % (2) spawns
1788 % a constraint C is observed if the GB of the rule it occurs in spawns a
1789 % constraint C2 that occurs non-passively in a rule (possibly the same rule)
1790 % as an occurrence of C
1792 spawns(RuleNb,GB,C2),
1793 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1794 \
1795 do_is_observed(C,RuleNb,GB)
1796 <=>
1797 \+ is_passive(RuleNb2,O)
1798 |
1799 true.
1801 spawns(RuleNb,_,C2),
1802 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1803 \
1804 do_is_observed(C,RuleNb)
1805 <=>
1806 \+ is_passive(RuleNb2,O)
1807 |
1808 true.
1810 % (3) spawns_all_triggers
1811 % a constraint C is observed if the GB of the rule it occurs in spawns all triggers
1812 % and some non-passive occurrence of some (possibly other) constraint that may trigger
1813 % exists in a rule (could be same rule) with at least one occurrence of C
1815 spawns_all_triggers(RuleNb,GB),
1816 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1817 \
1818 do_is_observed(C,RuleNb,GB)
1819 <=>
1820 \+ is_passive(RuleNb2,O), may_trigger(C2)
1821 |
1822 true.
1824 spawns_all_triggers(RuleNb,_),
1825 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1826 \
1827 do_is_observed(C,RuleNb)
1828 <=>
1829 \+ is_passive(RuleNb2,O), may_trigger(C2)
1830 |
1831 true.
1833 % (4) conservativeness
1834 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1835 do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off).
1838 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1840 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1842 %%
1843 %% Generated predicates
1844 %% attach_$CONSTRAINT
1845 %% attach_increment
1846 %% detach_$CONSTRAINT
1847 %% attr_unify_hook
1849 %% attach_$CONSTRAINT
1850 generate_attach_detach_a_constraint_all([],[]).
1851 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1852 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1853 generate_attach_a_constraint(Constraint,Clauses1),
1854 generate_detach_a_constraint(Constraint,Clauses2)
1855 ;
1856 Clauses1 = [],
1857 Clauses2 = []
1858 ),
1859 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1860 append([Clauses1,Clauses2,Clauses3],Clauses).
1862 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1863 generate_attach_a_constraint_nil(Constraint,Clause1),
1864 generate_attach_a_constraint_cons(Constraint,Clause2).
1866 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1867 make_name('attach_',FA,Name),
1868 Atom =.. [Name,Vars,Susp].
1870 generate_attach_a_constraint_nil(FA,Clause) :-
1871 Clause = (Head :- true),
1872 attach_constraint_atom(FA,[],_,Head).
1874 generate_attach_a_constraint_cons(FA,Clause) :-
1875 Clause = (Head :- Body),
1876 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1877 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1878 Body = ( AttachBody, Subscribe, RecursiveCall ),
1879 get_max_constraint_index(N),
1880 ( N == 1 ->
1881 generate_attach_body_1(FA,Var,Susp,AttachBody)
1882 ;
1883 generate_attach_body_n(FA,Var,Susp,AttachBody)
1884 ),
1885 % SWI-Prolog specific code
1886 chr_pp_flag(solver_events,NMod),
1887 ( NMod \== none ->
1888 Args = [[Var|_],Susp],
1889 get_target_module(Mod),
1890 use_auxiliary_predicate(run_suspensions),
1891 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1892 ;
1893 Subscribe = true
1894 ).
1896 generate_attach_body_1(FA,Var,Susp,Body) :-
1897 get_target_module(Mod),
1898 Body =
1899 ( get_attr(Var, Mod, Susps) ->
1900 put_attr(Var, Mod, [Susp|Susps])
1901 ;
1902 put_attr(Var, Mod, [Susp])
1903 ).
1905 generate_attach_body_n(F/A,Var,Susp,Body) :-
1906 get_constraint_index(F/A,Position),
1907 get_max_constraint_index(Total),
1908 get_target_module(Mod),
1909 add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr),
1910 singleton_attr(Total,Susp,Position,NewAttr3),
1911 Body =
1912 ( get_attr(Var,Mod,TAttr) ->
1913 AddGoal,
1914 put_attr(Var,Mod,NTAttr)
1915 ;
1916 put_attr(Var,Mod,NewAttr3)
1917 ), !.
1919 %% detach_$CONSTRAINT
1920 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1921 generate_detach_a_constraint_nil(Constraint,Clause1),
1922 generate_detach_a_constraint_cons(Constraint,Clause2).
1924 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1925 make_name('detach_',FA,Name),
1926 Atom =.. [Name,Vars,Susp].
1928 generate_detach_a_constraint_nil(FA,Clause) :-
1929 Clause = ( Head :- true),
1930 detach_constraint_atom(FA,[],_,Head).
1932 generate_detach_a_constraint_cons(FA,Clause) :-
1933 Clause = (Head :- Body),
1934 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1935 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1936 Body = ( DetachBody, RecursiveCall ),
1937 get_max_constraint_index(N),
1938 ( N == 1 ->
1939 generate_detach_body_1(FA,Var,Susp,DetachBody)
1940 ;
1941 generate_detach_body_n(FA,Var,Susp,DetachBody)
1942 ).
1944 generate_detach_body_1(FA,Var,Susp,Body) :-
1945 get_target_module(Mod),
1946 Body =
1947 ( get_attr(Var,Mod,Susps) ->
1948 'chr sbag_del_element'(Susps,Susp,NewSusps),
1949 ( NewSusps == [] ->
1950 del_attr(Var,Mod)
1951 ;
1952 put_attr(Var,Mod,NewSusps)
1953 )
1954 ;
1955 true
1956 ).
1958 generate_detach_body_n(F/A,Var,Susp,Body) :-
1959 get_constraint_index(F/A,Position),
1960 get_max_constraint_index(Total),
1961 rem_attr(Total,Var,Susp,Position,TAttr,RemGoal),
1962 get_target_module(Mod),
1963 Body =
1964 ( get_attr(Var,Mod,TAttr) ->
1965 RemGoal
1966 ;
1967 true
1968 ), !.
1970 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1971 %-------------------------------------------------------------------------------
1972 %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1973 :- chr_constraint generate_indexed_variables_body/4.
1974 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1975 :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)).
1976 %-------------------------------------------------------------------------------
1977 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1978 get_indexing_spec(F/A,Specs),
1979 ( chr_pp_flag(term_indexing,on) ->
1980 spectermvars(Specs,Args,F,A,Body,Vars)
1981 ;
1982 get_constraint_type_det(F/A,ArgTypes),
1983 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1984 ( MaybeBody == empty ->
1985 Body = true,
1986 Vars = []
1987 ; N == 0 ->
1988 ( Args = [Term] ->
1989 true
1990 ;
1991 Term =.. [term|Args]
1992 ),
1993 Body = term_variables(Term,Vars)
1994 ;
1995 MaybeBody = Body
1996 )
1997 ).
1998 generate_indexed_variables_body(FA,_,_,_) <=>
1999 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
2000 %===============================================================================
2002 create_indexed_variables_body([],[],[],_,_,_,empty,0).
2003 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
2004 J is I + 1,
2005 create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
2006 ( Mode == (?),
2007 is_indexed_argument(FA,I) ->
2008 ( atomic_type(Type) ->
2009 Body =
2010 (
2011 ( var(V) ->
2012 Vars = [V|Tail]
2013 ;
2014 Vars = Tail
2015 ),
2016 Continuation
2017 ),
2018 ( RBody == empty ->
2019 Continuation = true, Tail = []
2020 ;
2021 Continuation = RBody
2022 )
2023 ;
2024 ( RBody == empty ->
2025 Body = term_variables(V,Vars)
2026 ;
2027 Body = (term_variables(V,Vars,Tail),RBody)
2028 )
2029 ),
2030 N = M
2031 ; Mode == (-), is_indexed_argument(FA,I) ->
2032 ( RBody == empty ->
2033 Body = (Vars = [V])
2034 ;
2035 Body = (Vars = [V|Tail],RBody)
2036 ),
2037 N is M + 1
2038 ;
2039 Vars = Tail,
2040 Body = RBody,
2041 N is M + 1
2042 ).
2043 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2044 % EXPERIMENTAL
2045 spectermvars(Specs,Args,F,A,Goal,Vars) :-
2046 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
2048 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
2049 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
2050 Goal = (ArgGoal,RGoal),
2051 argspecs(Specs,I,TempArgSpecs,RSpecs),
2052 merge_argspecs(TempArgSpecs,ArgSpecs),
2053 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
2054 J is I + 1,
2055 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
2057 argspecs([],_,[],[]).
2058 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
2059 argspecs(Rest,I,ArgSpecs,RestSpecs).
2060 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
2061 ( I == J ->
2062 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
2063 ( Specs = [] ->
2064 RRestSpecs = RestSpecs
2065 ;
2066 RestSpecs = [Specs|RRestSpecs]
2067 )
2068 ;
2069 ArgSpecs = RArgSpecs,
2070 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
2071 ),
2072 argspecs(Rest,I,RArgSpecs,RRestSpecs).
2074 merge_argspecs(In,Out) :-
2075 sort(In,Sorted),
2076 merge_argspecs_(Sorted,Out).
2078 merge_argspecs_([],[]).
2079 merge_argspecs_([X],R) :- !, R = [X].
2080 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
2081 ( (F1 == any ; F2 == any) ->
2082 merge_argspecs_([specinfo(I,any,[])|Rest],R)
2083 ; F1 == F2 ->
2084 append(A1,A2,A),
2085 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
2086 ;
2087 R = [specinfo(I,F1,A1)|RR],
2088 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
2089 ).
2091 arggoal(List,Arg,Goal,L,T) :-
2092 ( List == [] ->
2093 L = T,
2094 Goal = true
2095 ; List = [specinfo(_,any,_)] ->
2096 Goal = term_variables(Arg,L,T)
2097 ;
2098 Goal =
2099 ( var(Arg) ->
2100 L = [Arg|T]
2101 ;
2102 Cases
2103 ),
2104 arggoal_cases(List,Arg,L,T,Cases)
2105 ).
2107 arggoal_cases([],_,L,T,L=T).
2108 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
2109 ( ArgSpecs == [] ->
2110 Cases = RCases
2111 ; ArgSpecs == [[]] ->
2112 Cases = RCases
2113 ; FA = F/A ->
2114 Cases = (Case ; RCases),
2115 functor(Term,F,A),
2116 Term =.. [_|Args],
2117 Case = (Arg = Term -> ArgsGoal),
2118 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
2119 ),
2120 arggoal_cases(Rest,Arg,L,T,RCases).
2121 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2123 generate_extra_clauses(Constraints,List) :-
2124 generate_activate_clauses(Constraints,List,Tail0),
2125 generate_remove_clauses(Constraints,Tail0,Tail1),
2126 generate_allocate_clauses(Constraints,Tail1,Tail2),
2127 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
2128 generate_novel_production(Tail3,Tail4),
2129 generate_extend_history(Tail4,Tail5),
2130 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
2131 generate_empty_named_history_initialisations(Tail6,Tail7),
2132 Tail7 = [].
2134 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2135 % remove_constraint_internal/[1/3]
2137 generate_remove_clauses([],List,List).
2138 generate_remove_clauses([C|Cs],List,Tail) :-
2139 generate_remove_clause(C,List,List1),
2140 generate_remove_clauses(Cs,List1,Tail).
2142 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
2143 uses_state(Constraint,removed),
2144 ( chr_pp_flag(inline_insertremove,off) ->
2145 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2146 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
2147 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
2148 ;
2149 delay_phase_end(validate_store_type_assumptions,
2150 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
2151 )
2152 ).
2154 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
2155 make_name('$remove_constraint_internal_',Constraint,Name),
2156 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
2157 Goal =.. [Name, Susp,Delete]
2158 ;
2159 Goal =.. [Name,Susp,Agenda,Delete]
2160 ).
2162 generate_remove_clause(Constraint,List,Tail) :-
2163 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
2164 List = [RemoveClause|Tail],
2165 RemoveClause = (Head :- RemoveBody),
2166 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
2167 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
2168 ;
2169 List = Tail
2170 ).
2172 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
2173 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2174 ( Role == active ->
2175 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
2176 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2177 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
2178 ; Role == partner ->
2179 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
2180 GetStateValue = true,
2181 MaybeDelete = DeleteYes
2182 ),
2183 RemoveBody =
2184 (
2185 GetState,
2186 GetStateValue,
2187 UpdateState,
2188 MaybeDelete
2189 )
2190 ;
2191 static_suspension_term(Constraint,Susp2),
2192 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
2193 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
2194 ( chr_pp_flag(debugable,on) ->
2195 Constraint = Functor / _,
2196 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
2197 ;
2198 true
2199 ),
2200 ( Role == active ->
2201 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
2202 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2203 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
2204 ; Role == partner ->
2205 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
2206 GetStateValue = true,
2207 MaybeDelete = (IndexedVariablesBody, DeleteYes)
2208 ),
2209 RemoveBody =
2210 (
2211 Susp = Susp2,
2212 GetStateValue,
2213 UpdateState,
2214 MaybeDelete
2215 )
2216 ).
2218 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2219 % activate_constraint/4
2221 generate_activate_clauses([],List,List).
2222 generate_activate_clauses([C|Cs],List,Tail) :-
2223 generate_activate_clause(C,List,List1),
2224 generate_activate_clauses(Cs,List1,Tail).
2226 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
2227 ( chr_pp_flag(inline_insertremove,off) ->
2228 use_auxiliary_predicate(activate_constraint,Constraint),
2229 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
2230 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
2231 ;
2232 delay_phase_end(validate_store_type_assumptions,
2233 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
2234 )
2235 ).
2237 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
2238 make_name('$activate_constraint_',Constraint,Name),
2239 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
2240 Goal =.. [Name,Store, Susp]
2241 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2242 Goal =.. [Name,Store, Susp, Generation]
2243 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
2244 Goal =.. [Name,Store, Vars, Susp, Generation]
2245 ;
2246 Goal =.. [Name,Store, Vars, Susp]
2247 ).
2249 generate_activate_clause(Constraint,List,Tail) :-
2250 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
2251 List = [Clause|Tail],
2252 Clause = (Head :- Body),
2253 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
2254 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
2255 ;
2256 List = Tail
2257 ).
2259 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
2260 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
2261 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2262 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
2263 ;
2264 GenerationHandling = true
2265 ),
2266 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
2267 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
2268 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
2269 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
2270 ;
2271 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
2272 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
2273 ( chr_pp_flag(guard_locks,off) ->
2274 NoneLocked = true
2275 ;
2276 NoneLocked = 'chr none_locked'( Vars)
2277 ),
2278 if_used_state(Constraint,not_stored_yet,
2279 ( State == not_stored_yet ->
2280 ArgumentsGoal,
2281 IndexedVariablesBody,
2282 NoneLocked,
2283 StoreYes
2284 ;
2285 % Vars = [],
2286 StoreNo
2287 ),
2288 % (Vars = [],StoreNo),StoreVarsGoal)
2289 StoreNo,StoreVarsGoal)
2290 ),
2291 Body =
2292 (
2293 GetState,
2294 GetStateValue,
2295 UpdateState,
2296 GenerationHandling,
2297 StoreVarsGoal
2298 ).
2299 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2300 % allocate_constraint/4
2302 generate_allocate_clauses([],List,List).
2303 generate_allocate_clauses([C|Cs],List,Tail) :-
2304 generate_allocate_clause(C,List,List1),
2305 generate_allocate_clauses(Cs,List1,Tail).
2307 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2308 uses_state(Constraint,not_stored_yet),
2309 ( chr_pp_flag(inline_insertremove,off) ->
2310 use_auxiliary_predicate(allocate_constraint,Constraint),
2311 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2312 ;
2313 Goal = (Susp = Suspension, Goal0),
2314 delay_phase_end(validate_store_type_assumptions,
2315 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2316 )
2317 ).
2319 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2320 make_name('$allocate_constraint_',Constraint,Name),
2321 Goal =.. [Name,Susp|Args].
2323 generate_allocate_clause(Constraint,List,Tail) :-
2324 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2325 List = [Clause|Tail],
2326 Clause = (Head :- Body),
2327 Constraint = _/A,
2328 length(Args,A),
2329 allocate_constraint_atom(Constraint,Susp,Args,Head),
2330 allocate_constraint_body(Constraint,Susp,Args,Body)
2331 ;
2332 List = Tail
2333 ).
2335 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2336 static_suspension_term(Constraint,Suspension),
2337 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2338 ( chr_pp_flag(debugable,on) ->
2339 Constraint = Functor / _,
2340 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2341 ;
2342 true
2343 ),
2344 ( chr_pp_flag(debugable,on) ->
2345 ( may_trigger(Constraint) ->
2346 append(Args,[Susp],VarsSusp),
2347 build_head(F,A,[0],VarsSusp, ContinuationGoal),
2348 get_target_module(Mod),
2349 Continuation = Mod : ContinuationGoal
2350 ;
2351 Continuation = true
2352 ),
2353 Init = (Susp = Suspension),
2354 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2355 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2356 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2357 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2358 Susp = Suspension, Init = true, CreateContinuation = true
2359 ;
2360 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2361 ),
2362 ( uses_history(Constraint) ->
2363 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2364 ;
2365 CreateHistory = true
2366 ),
2367 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2368 ( has_suspension_field(Constraint,id) ->
2369 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2370 gen_id(Id,GenID)
2371 ;
2372 GenID = true
2373 ),
2374 Body =
2375 (
2376 Init,
2377 CreateContinuation,
2378 CreateGeneration,
2379 CreateHistory,
2380 CreateState,
2381 GenID
2382 ).
2384 gen_id(Id,'chr gen_id'(Id)).
2385 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2386 % insert_constraint_internal
2388 generate_insert_constraint_internal_clauses([],List,List).
2389 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2390 generate_insert_constraint_internal_clause(C,List,List1),
2391 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2393 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2394 ( chr_pp_flag(inline_insertremove,off) ->
2395 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2396 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2397 ;
2398 delay_phase_end(validate_store_type_assumptions,
2399 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2400 )
2401 ).
2404 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2405 insert_constraint_internal_constraint_name(Constraint,Name),
2406 ( chr_pp_flag(debugable,on) ->
2407 Goal =.. [Name, Vars, Self, Closure | Args]
2408 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2409 Goal =.. [Name,Self | Args]
2410 ;
2411 Goal =.. [Name,Vars, Self | Args]
2412 ).
2414 insert_constraint_internal_constraint_name(Constraint,Name) :-
2415 make_name('$insert_constraint_internal_',Constraint,Name).
2417 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2418 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2419 List = [Clause|Tail],
2420 Clause = (Head :- Body),
2421 Constraint = _/A,
2422 length(Args,A),
2423 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2424 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2425 ;
2426 List = Tail
2427 ).
2430 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2431 static_suspension_term(Constraint,Suspension),
2432 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2433 ( chr_pp_flag(debugable,on) ->
2434 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2435 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2436 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2437 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2438 ;
2439 CreateGeneration = true
2440 ),
2441 ( chr_pp_flag(debugable,on) ->
2442 Constraint = Functor / _,
2443 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2444 ;
2445 true
2446 ),
2447 ( uses_history(Constraint) ->
2448 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2449 ;
2450 CreateHistory = true
2451 ),
2452 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2453 List = [Clause|Tail],
2454 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2455 suspension_term_base_fields(Constraint,BaseFields),
2456 ( has_suspension_field(Constraint,id) ->
2457 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2458 gen_id(Id,GenID)
2459 ;
2460 GenID = true
2461 ),
2462 Body =
2463 (
2464 Susp = Suspension,
2465 CreateState,
2466 CreateGeneration,
2467 CreateHistory,
2468 GenID
2469 )
2470 ;
2471 ( has_suspension_field(Constraint,id) ->
2472 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2473 gen_id(Id,GenID)
2474 ;
2475 GenID = true
2476 ),
2477 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2478 ( chr_pp_flag(guard_locks,off) ->
2479 NoneLocked = true
2480 ;
2481 NoneLocked = 'chr none_locked'( Vars)
2482 ),
2483 Body =
2484 (
2485 Susp = Suspension,
2486 IndexedVariablesBody,
2487 NoneLocked,
2488 CreateState,
2489 CreateGeneration,
2490 CreateHistory,
2491 GenID
2492 )
2493 ).
2495 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2496 % novel_production/2
2498 generate_novel_production(List,Tail) :-
2499 ( is_used_auxiliary_predicate(novel_production) ->
2500 List = [Clause|Tail],
2501 Clause =
2502 (
2503 '$novel_production'( Self, Tuple) :-
2504 % arg( 3, Self, Ref), % ARGXXX
2505 % 'chr get_mutable'( History, Ref),
2506 arg( 3, Self, History), % ARGXXX
2507 ( hprolog:get_ds( Tuple, History, _) ->
2508 fail
2509 ;
2510 true
2511 )
2512 )
2513 ;
2514 List = Tail
2515 ).
2517 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2518 % extend_history/2
2520 generate_extend_history(List,Tail) :-
2521 ( is_used_auxiliary_predicate(extend_history) ->
2522 List = [Clause|Tail],
2523 Clause =
2524 (
2525 '$extend_history'( Self, Tuple) :-
2526 % arg( 3, Self, Ref), % ARGXXX
2527 % 'chr get_mutable'( History, Ref),
2528 arg( 3, Self, History), % ARGXXX
2529 hprolog:put_ds( Tuple, History, x, NewHistory),
2530 setarg( 3, Self, NewHistory) % ARGXXX
2531 )
2532 ;
2533 List = Tail
2534 ).
2536 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2537 %
2538 :- chr_constraint
2539 empty_named_history_initialisations/2,
2540 generate_empty_named_history_initialisation/1,
2541 find_empty_named_histories/0.
2543 generate_empty_named_history_initialisations(List, Tail) :-
2544 empty_named_history_initialisations(List, Tail),
2545 find_empty_named_histories.
2547 find_empty_named_histories, history(_, Name, []) ==>
2548 generate_empty_named_history_initialisation(Name).
2550 generate_empty_named_history_initialisation(Name) \
2551 generate_empty_named_history_initialisation(Name) <=> true.
2552 generate_empty_named_history_initialisation(Name) \
2553 empty_named_history_initialisations(List, Tail) # Passive
2554 <=>
2555 empty_named_history_global_variable(Name, GlobalVariable),
2556 List = [(:- nb_setval(GlobalVariable, 0))|Rest],
2557 empty_named_history_initialisations(Rest, Tail)
2558 pragma passive(Passive).
2560 find_empty_named_histories \
2561 generate_empty_named_history_initialisation(_) # Passive <=> true
2562 pragma passive(Passive).
2564 find_empty_named_histories,
2565 empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail
2566 pragma passive(Passive).
2568 find_empty_named_histories <=>
2569 chr_error(internal, 'find_empty_named_histories was not removed', []).
2572 empty_named_history_global_variable(Name, GlobalVariable) :-
2573 atom_concat('chr empty named history ', Name, GlobalVariable).
2575 empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :-
2576 empty_named_history_global_variable(Name, GlobalVariable).
2578 empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :-
2579 empty_named_history_global_variable(Name, GlobalVariable).
2582 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2583 % run_suspensions/2
2585 generate_run_suspensions_clauses([],List,List).
2586 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2587 generate_run_suspensions_clause(C,List,List1),
2588 generate_run_suspensions_clauses(Cs,List1,Tail).
2590 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2591 make_name('$run_suspensions_',Constraint,Name),
2592 Goal =.. [Name,Suspensions].
2594 generate_run_suspensions_clause(Constraint,List,Tail) :-
2595 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2596 List = [Clause1,Clause2|Tail],
2597 run_suspensions_goal(Constraint,[],Clause1),
2598 ( chr_pp_flag(debugable,on) ->
2599 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2600 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2601 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2602 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2603 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2604 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2605 Clause2 =
2606 (
2607 Clause2Head :-
2608 GetState,
2609 GetStateValue,
2610 ( State==active ->
2611 UpdateState,
2612 GetGeneration,
2613 GetGenerationValue,
2614 Generation is Gen+1,
2615 UpdateGeneration,
2616 GetContinuation,
2617 (
2618 'chr debug_event'(wake(Suspension)),
2619 call(Continuation)
2620 ;
2621 'chr debug_event'(fail(Suspension)), !,
2622 fail
2623 ),
2624 (
2625 'chr debug_event'(exit(Suspension))
2626 ;
2627 'chr debug_event'(redo(Suspension)),
2628 fail
2629 ),
2630 GetPost,
2631 GetPostValue,
2632 ( Post==triggered ->
2633 UpdatePost % catching constraints that did not do anything
2634 ;
2635 true
2636 )
2637 ;
2638 true
2639 ),
2640 Clause2Recursion
2641 )
2642 ;
2643 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2644 static_suspension_term(Constraint,SuspensionTerm),
2645 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2646 append(Arguments,[Suspension],VarsSusp),
2647 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2648 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2649 ( uses_field(Constraint,generation) ->
2650 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2651 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2652 ;
2653 GenerationHandling = true
2654 ),
2655 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2656 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2657 if_used_state(Constraint,removed,
2658 ( GetState,
2659 ( State==active
2660 -> ReactivateConstraint
2661 ; true)
2662 ),ReactivateConstraint,CondReactivate),
2663 ReactivateConstraint =
2664 (
2665 UpdateState,
2666 GenerationHandling,
2667 Continuation,
2668 GetPostState,
2669 ( Post==triggered ->
2670 UpdatePostState % catching constraints that did not do anything
2671 ;
2672 true
2673 )
2674 ),
2675 Clause2 =
2676 (
2677 Clause2Head :-
2678 Suspension = SuspensionTerm,
2679 CondReactivate,
2680 Clause2Recursion
2681 )
2682 )
2683 ;
2684 List = Tail
2685 ).
2687 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2689 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2690 generate_attach_increment(Clauses) :-
2691 get_max_constraint_index(N),
2692 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2693 Clauses = [Clause1,Clause2],
2694 generate_attach_increment_empty(Clause1),
2695 ( N == 1 ->
2696 generate_attach_increment_one(Clause2)
2697 ;
2698 generate_attach_increment_many(N,Clause2)
2699 )
2700 ;
2701 Clauses = []
2702 ).
2704 generate_attach_increment_empty((attach_increment([],_) :- true)).
2706 generate_attach_increment_one(Clause) :-
2707 Head = attach_increment([Var|Vars],Susps),
2708 get_target_module(Mod),
2709 ( chr_pp_flag(guard_locks,off) ->
2710 NotLocked = true
2711 ;
2712 NotLocked = 'chr not_locked'( Var)
2713 ),
2714 Body =
2715 (
2716 NotLocked,
2717 ( get_attr(Var,Mod,VarSusps) ->
2718 sort(VarSusps,SortedVarSusps),
2719 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2720 put_attr(Var,Mod,MergedSusps)
2721 ;
2722 put_attr(Var,Mod,Susps)
2723 ),
2724 attach_increment(Vars,Susps)
2725 ),
2726 Clause = (Head :- Body).
2728 generate_attach_increment_many(N,Clause) :-
2729 Head = attach_increment([Var|Vars],TAttr1),
2730 % writeln(merge_attributes_1_before),
2731 merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr),
2732 % writeln(merge_attributes_1_after),
2733 get_target_module(Mod),
2734 ( chr_pp_flag(guard_locks,off) ->
2735 NotLocked = true
2736 ;
2737 NotLocked = 'chr not_locked'( Var)
2738 ),
2739 Body =
2740 (
2741 NotLocked,
2742 ( get_attr(Var,Mod,TAttr2) ->
2743 MergeGoal,
2744 put_attr(Var,Mod,Attr)
2745 ;
2746 put_attr(Var,Mod,TAttr1)
2747 ),
2748 attach_increment(Vars,TAttr1)
2749 ),
2750 Clause = (Head :- Body).
2752 %% attr_unify_hook
2753 generate_attr_unify_hook(Clauses) :-
2754 get_max_constraint_index(N),
2755 ( N == 0 ->
2756 Clauses = []
2757 ;
2758 ( N == 1 ->
2759 generate_attr_unify_hook_one(Clauses)
2760 ;
2761 generate_attr_unify_hook_many(N,Clauses)
2762 )
2763 ).
2765 generate_attr_unify_hook_one([Clause]) :-
2766 Head = attr_unify_hook(Susps,Other),
2767 get_target_module(Mod),
2768 get_indexed_constraint(1,C),
2769 ( get_store_type(C,ST),
2770 ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) ->
2771 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2772 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2773 ( atomic_types_suspended_constraint(C) ->
2774 SortGoal1 = true,
2775 SortedSusps = Susps,
2776 SortGoal2 = true,
2777 SortedOtherSusps = OtherSusps,
2778 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2779 NonvarBody = true
2780 ;
2781 SortGoal1 = sort(Susps, SortedSusps),
2782 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2783 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2784 use_auxiliary_predicate(attach_increment),
2785 NonvarBody =
2786 ( compound(Other) ->
2787 term_variables(Other,OtherVars),
2788 attach_increment(OtherVars, SortedSusps)
2789 ;
2790 true
2791 )
2792 ),
2793 Body =
2794 (
2795 SortGoal1,
2796 ( var(Other) ->
2797 ( get_attr(Other,Mod,OtherSusps) ->
2798 SortGoal2,
2799 MergeGoal,
2800 put_attr(Other,Mod,NewSusps),
2801 WakeNewSusps
2802 ;
2803 put_attr(Other,Mod,SortedSusps),
2804 WakeSusps
2805 )
2806 ;
2807 NonvarBody,
2808 WakeSusps
2809 )
2810 ),
2811 Clause = (Head :- Body)
2812 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2813 make_run_suspensions(List,List,WakeNewSusps),
2814 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2815 Body =
2816 ( get_attr(Other,Mod,OtherSusps) ->
2817 MergeGoal,
2818 WakeNewSusps
2819 ;
2820 put_attr(Other,Mod,Susps)
2821 ),
2822 Clause = (Head :- Body)
2823 ).
2826 generate_attr_unify_hook_many(N,[Clause]) :-
2827 chr_pp_flag(dynattr,off), !,
2828 Head = attr_unify_hook(Attr,Other),
2829 get_target_module(Mod),
2830 make_attr(N,Mask,SuspsList,Attr),
2831 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2832 list2conj(SortGoalList,SortGoals),
2833 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2834 merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr),
2835 get_all_suspensions2(N,MergedAttr,MergedSuspsList),
2836 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2837 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2838 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2839 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2840 NonvarBody = true
2841 ;
2842 use_auxiliary_predicate(attach_increment),
2843 NonvarBody =
2844 ( compound(Other) ->
2845 term_variables(Other,OtherVars),
2846 attach_increment(OtherVars,SortedAttr)
2847 ;
2848 true
2849 )
2850 ),
2851 Body =
2852 (
2853 SortGoals,
2854 ( var(Other) ->
2855 ( get_attr(Other,Mod,TOtherAttr) ->
2856 MergeGoal,
2857 put_attr(Other,Mod,MergedAttr),
2858 WakeMergedSusps
2859 ;
2860 put_attr(Other,Mod,SortedAttr),
2861 WakeSortedSusps
2862 )
2863 ;
2864 NonvarBody,
2865 WakeSortedSusps
2866 )
2867 ),
2868 Clause = (Head :- Body).
2870 % NEW
2871 generate_attr_unify_hook_many(N,Clauses) :-
2872 Head = attr_unify_hook(Attr,Other),
2873 get_target_module(Mod),
2874 normalize_attr(Attr,NormalGoal,NormalAttr),
2875 normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr),
2876 merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr),
2877 make_run_suspensions(N),
2878 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2879 NonvarBody = true
2880 ;
2881 use_auxiliary_predicate(attach_increment),
2882 NonvarBody =
2883 ( compound(Other) ->
2884 term_variables(Other,OtherVars),
2885 attach_increment(OtherVars,NormalAttr)
2886 ;
2887 true
2888 )
2889 ),
2890 Body =
2891 (
2892 NormalGoal,
2893 ( var(Other) ->
2894 ( get_attr(Other,Mod,OtherAttr) ->
2895 NormalOtherGoal,
2896 MergeGoal,
2897 put_attr(Other,Mod,MergedAttr),
2898 '$dispatch_run_suspensions'(MergedAttr)
2899 ;
2900 put_attr(Other,Mod,NormalAttr),
2901 '$dispatch_run_suspensions'(NormalAttr)
2902 )
2903 ;
2904 NonvarBody,
2905 '$dispatch_run_suspensions'(NormalAttr)
2906 )
2907 ),
2908 Clause = (Head :- Body),
2909 Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers],
2910 DispatchList1 = ('$dispatch_run_suspensions'([])),
2911 DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)),
2912 run_suspensions_dispatchers(N,[],Dispatchers).
2914 % NEW
2915 run_suspensions_dispatchers(N,Acc,Dispatchers) :-
2916 ( N > 0 ->
2917 get_indexed_constraint(N,C),
2918 NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc],
2919 ( may_trigger(C) ->
2920 run_suspensions_goal(C,List,Body)
2921 ;
2922 Body = true
2923 ),
2924 M is N - 1,
2925 run_suspensions_dispatchers(M,NAcc,Dispatchers)
2926 ;
2927 Dispatchers = Acc
2928 ).
2930 % NEW
2931 make_run_suspensions(N) :-
2932 ( N > 0 ->
2933 ( get_indexed_constraint(N,C),
2934 may_trigger(C) ->
2935 use_auxiliary_predicate(run_suspensions,C)
2936 ;
2937 true
2938 ),
2939 M is N - 1,
2940 make_run_suspensions(M)
2941 ;
2942 true
2943 ).
2945 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2946 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2948 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2949 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2950 use_auxiliary_predicate(run_suspensions,C),
2951 ( wakes_partially(C) ->
2952 run_suspensions_goal(C,OneSusps,Goal)
2953 ;
2954 run_suspensions_goal(C,AllSusps,Goal)
2955 )
2956 ;
2957 Goal = true
2958 ).
2960 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2961 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2963 make_run_suspensions_loop([],[],_,true).
2964 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2965 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2966 J is I + 1,
2967 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2969 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2970 % $insert_in_store_F/A
2971 % $delete_from_store_F/A
2973 generate_insert_delete_constraints([],[]).
2974 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2975 ( is_stored(FA) ->
2976 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2977 ;
2978 Clauses = RestClauses
2979 ),
2980 generate_insert_delete_constraints(Rest,RestClauses).
2982 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2983 insert_constraint_clause(FA,Clauses,RestClauses1),
2984 delete_constraint_clause(FA,RestClauses1,RestClauses).
2986 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2987 % insert_in_store
2989 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2990 ( chr_pp_flag(inline_insertremove,off) ->
2991 use_auxiliary_predicate(insert_in_store,FA),
2992 insert_constraint_atom(FA,Susp,Goal)
2993 ;
2994 delay_phase_end(validate_store_type_assumptions,
2995 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2996 insert_constraint_direct_used_vars(UsedVars,Vars)
2997 )
2998 )
2999 ).
3001 insert_constraint_direct_used_vars([],_).
3002 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
3003 nth1(Index,Vars,Var),
3004 insert_constraint_direct_used_vars(Rest,Vars).
3006 insert_constraint_atom(FA,Susp,Call) :-
3007 make_name('$insert_in_store_',FA,Functor),
3008 Call =.. [Functor,Susp].
3010 insert_constraint_clause(C,Clauses,RestClauses) :-
3011 ( is_used_auxiliary_predicate(insert_in_store,C) ->
3012 Clauses = [Clause|RestClauses],
3013 Clause = (Head :- InsertCounterInc,VarsBody,Body),
3014 insert_constraint_atom(C,Susp,Head),
3015 insert_constraint_body(C,Susp,UsedVars,Body),
3016 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
3017 ( chr_pp_flag(store_counter,on) ->
3018 InsertCounterInc = '$insert_counter_inc'
3019 ;
3020 InsertCounterInc = true
3021 )
3022 ;
3023 Clauses = RestClauses
3024 ).
3026 insert_constraint_used_vars([],_,_,true).
3027 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
3028 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
3029 insert_constraint_used_vars(Rest,C,Susp,Goals).
3031 insert_constraint_body(C,Susp,UsedVars,Body) :-
3032 get_store_type(C,StoreType),
3033 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3035 insert_constraint_body(default,C,Susp,[],Body) :-
3036 global_list_store_name(C,StoreName),
3037 make_get_store_goal(StoreName,Store,GetStoreGoal),
3038 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3039 ( chr_pp_flag(debugable,on) ->
3040 Cell = [Susp|Store],
3041 Body =
3042 (
3043 GetStoreGoal,
3044 UpdateStoreGoal
3045 )
3046 ;
3047 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3048 Body =
3049 (
3050 GetStoreGoal,
3051 Cell = [Susp|Store],
3052 UpdateStoreGoal,
3053 ( Store = [NextSusp|_] ->
3054 SetGoal
3055 ;
3056 true
3057 )
3058 )
3059 ).
3060 % get_target_module(Mod),
3061 % get_max_constraint_index(Total),
3062 % ( Total == 1 ->
3063 % generate_attach_body_1(C,Store,Susp,AttachBody)
3064 % ;
3065 % generate_attach_body_n(C,Store,Susp,AttachBody)
3066 % ),
3067 % Body =
3068 % (
3069 % 'chr default_store'(Store),
3070 % AttachBody
3071 % ).
3072 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
3073 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
3074 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
3075 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
3076 sort_out_used_vars(MixedUsedVars,UsedVars).
3077 insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3078 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3079 constants_store_index_name(C,Index,IndexName),
3080 IndexLookup =.. [IndexName,Key,StoreName],
3081 Body =
3082 ( IndexLookup ->
3083 nb_getval(StoreName,Store),
3084 b_setval(StoreName,[Susp|Store])
3085 ;
3086 true
3087 ).
3088 insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :-
3089 multi_hash_key_direct(C,Index,Susp,Key,UsedVars),
3090 constants_store_index_name(C,Index,IndexName),
3091 IndexLookup =.. [IndexName,Key,StoreName],
3092 Body =
3093 ( IndexLookup ->
3094 nb_getval(StoreName,Store),
3095 b_setval(StoreName,[Susp|Store])
3096 ;
3097 true
3098 ).
3099 insert_constraint_body(global_ground,C,Susp,[],Body) :-
3100 global_ground_store_name(C,StoreName),
3101 make_get_store_goal(StoreName,Store,GetStoreGoal),
3102 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
3103 ( chr_pp_flag(debugable,on) ->
3104 Cell = [Susp|Store],
3105 Body =
3106 (
3107 GetStoreGoal,
3108 UpdateStoreGoal
3109 )
3110 ;
3111 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
3112 Body =
3113 (
3114 GetStoreGoal,
3115 Cell = [Susp|Store],
3116 UpdateStoreGoal,
3117 ( Store = [NextSusp|_] ->
3118 SetGoal
3119 ;
3120 true
3121 )
3122 )
3123 ).
3124 % global_ground_store_name(C,StoreName),
3125 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3126 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
3127 % Body =
3128 % (
3129 % GetStoreGoal, % nb_getval(StoreName,Store),
3130 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
3131 % ).
3132 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
3133 % TODO: generalize to more than one !!!
3134 get_target_module(Module),
3135 Body = ( get_attr(Variable,Module,AssocStore) ->
3136 insert_assoc_store(AssocStore,Key,Susp)
3137 ;
3138 new_assoc_store(AssocStore),
3139 put_attr(Variable,Module,AssocStore),
3140 insert_assoc_store(AssocStore,Key,Susp)
3141 ).
3143 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
3144 global_singleton_store_name(C,StoreName),
3145 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
3146 Body =
3147 (
3148 UpdateStoreGoal
3149 ).
3150 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
3151 maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies),
3152 list2conj(Bodies,Body),
3153 sort_out_used_vars(NestedUsedVars,UsedVars).
3154 insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :-
3155 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
3156 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
3157 UsedVars = [Index-Var],
3158 get_identifier_size(ISize),
3159 functor(Struct,struct,ISize),
3160 get_identifier_index(C,Index,IIndex),
3161 arg(IIndex,Struct,Susps),
3162 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3163 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
3164 UsedVars = [Index-Var],
3165 type_indexed_identifier_structure(IndexType,Struct),
3166 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3167 arg(IIndex,Struct,Susps),
3168 Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
3170 sort_out_used_vars(NestedUsedVars,UsedVars) :-
3171 flatten(NestedUsedVars,FlatUsedVars),
3172 sort(FlatUsedVars,SortedFlatUsedVars),
3173 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
3175 sort_out_used_vars1([],[]).
3176 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
3177 sort_out_used_vars1([I-X,J-Y|R],L) :-
3178 ( I == J ->
3179 X = Y,
3180 sort_out_used_vars1([I-X|R],L)
3181 ;
3182 L = [I-X|T],
3183 sort_out_used_vars1([J-Y|R],T)
3184 ).
3186 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
3187 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3188 multi_hash_store_name(FA,Index,StoreName),
3189 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3190 Body =
3191 (
3192 KeyBody,
3193 nb_getval(StoreName,Store),
3194 insert_iht(Store,Key,Susp)
3195 ),
3196 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
3198 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
3199 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
3200 multi_hash_store_name(FA,Index,StoreName),
3201 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
3202 make_get_store_goal(StoreName,Store,GetStoreGoal),
3203 ( chr_pp_flag(ht_removal,on)
3204 -> ht_prev_field(Index,PrevField),
3205 set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result,
3206 SetGoal),
3207 Body =
3208 (
3209 GetStoreGoal,
3210 insert_ht(Store,Key,Susp,Result),
3211 ( Result = [_,NextSusp|_]
3212 -> SetGoal
3213 ; true
3214 )
3215 )
3216 ; Body =
3217 (
3218 GetStoreGoal,
3219 insert_ht(Store,Key,Susp)
3220 )
3221 ),
3222 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
3224 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3225 % Delete
3227 delete_constraint_clause(C,Clauses,RestClauses) :-
3228 ( is_used_auxiliary_predicate(delete_from_store,C) ->
3229 Clauses = [Clause|RestClauses],
3230 Clause = (Head :- Body),
3231 delete_constraint_atom(C,Susp,Head),
3232 C = F/A,
3233 functor(Head,F,A),
3234 delete_constraint_body(C,Head,Susp,[],Body)
3235 ;
3236 Clauses = RestClauses
3237 ).
3239 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
3240 functor(Head,F,A),
3241 C = F/A,
3242 ( chr_pp_flag(inline_insertremove,off) ->
3243 use_auxiliary_predicate(delete_from_store,C),
3244 delete_constraint_atom(C,Susp,Goal)
3245 ;
3246 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
3247 ).
3249 delete_constraint_atom(C,Susp,Atom) :-
3250 make_name('$delete_from_store_',C,Functor),
3251 Atom =.. [Functor,Susp].
3254 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
3255 Body = (CounterBody,DeleteBody),
3256 ( chr_pp_flag(store_counter,on) ->
3257 CounterBody = '$delete_counter_inc'
3258 ;
3259 CounterBody = true
3260 ),
3261 get_store_type(C,StoreType),
3262 delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
3264 delete_constraint_body(default,C,_,Susp,_,Body) :-
3265 ( chr_pp_flag(debugable,on) ->
3266 global_list_store_name(C,StoreName),
3267 make_get_store_goal(StoreName,Store,GetStoreGoal),
3268 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3269 Body =
3270 (
3271 GetStoreGoal, % nb_getval(StoreName,Store),
3272 'chr sbag_del_element'(Store,Susp,NStore),
3273 UpdateStoreGoal % b_setval(StoreName,NStore)
3274 )
3275 ;
3276 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3277 global_list_store_name(C,StoreName),
3278 make_get_store_goal(StoreName,Store,GetStoreGoal),
3279 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3280 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3281 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3282 Body =
3283 (
3284 GetGoal,
3285 ( var(PredCell) ->
3286 GetStoreGoal, % nb_getval(StoreName,Store),
3287 Store = [_|Tail],
3288 UpdateStoreGoal,
3289 ( Tail = [NextSusp|_] ->
3290 SetGoal1
3291 ;
3292 true
3293 )
3294 ;
3295 PredCell = [_,_|Tail],
3296 setarg(2,PredCell,Tail),
3297 ( Tail = [NextSusp|_] ->
3298 SetGoal2
3299 ;
3300 true
3301 )
3302 )
3303 )
3304 ).
3305 % get_target_module(Mod),
3306 % get_max_constraint_index(Total),
3307 % ( Total == 1 ->
3308 % generate_detach_body_1(C,Store,Susp,DetachBody),
3309 % Body =
3310 % (
3311 % 'chr default_store'(Store),
3312 % DetachBody
3313 % )
3314 % ;
3315 % generate_detach_body_n(C,Store,Susp,DetachBody),
3316 % Body =
3317 % (
3318 % 'chr default_store'(Store),
3319 % DetachBody
3320 % )
3321 % ).
3322 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
3323 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
3324 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
3325 generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
3326 delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3327 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3328 constants_store_index_name(C,Index,IndexName),
3329 IndexLookup =.. [IndexName,Key,StoreName],
3330 Body =
3331 ( KeyBody,
3332 ( IndexLookup ->
3333 nb_getval(StoreName,Store),
3334 'chr sbag_del_element'(Store,Susp,NStore),
3335 b_setval(StoreName,NStore)
3336 ;
3337 true
3338 )).
3339 delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :-
3340 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3341 constants_store_index_name(C,Index,IndexName),
3342 IndexLookup =.. [IndexName,Key,StoreName],
3343 Body =
3344 ( KeyBody,
3345 ( IndexLookup ->
3346 nb_getval(StoreName,Store),
3347 'chr sbag_del_element'(Store,Susp,NStore),
3348 b_setval(StoreName,NStore)
3349 ;
3350 true
3351 )).
3352 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
3353 ( chr_pp_flag(debugable,on) ->
3354 global_ground_store_name(C,StoreName),
3355 make_get_store_goal(StoreName,Store,GetStoreGoal),
3356 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3357 Body =
3358 (
3359 GetStoreGoal, % nb_getval(StoreName,Store),
3360 'chr sbag_del_element'(Store,Susp,NStore),
3361 UpdateStoreGoal % b_setval(StoreName,NStore)
3362 )
3363 ;
3364 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
3365 global_ground_store_name(C,StoreName),
3366 make_get_store_goal(StoreName,Store,GetStoreGoal),
3367 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
3368 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
3369 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
3370 Body =
3371 (
3372 GetGoal,
3373 ( var(PredCell) ->
3374 GetStoreGoal, % nb_getval(StoreName,Store),
3375 Store = [_|Tail],
3376 UpdateStoreGoal,
3377 ( Tail = [NextSusp|_] ->
3378 SetGoal1
3379 ;
3380 true
3381 )
3382 ;
3383 PredCell = [_,_|Tail],
3384 setarg(2,PredCell,Tail),
3385 ( Tail = [NextSusp|_] ->
3386 SetGoal2
3387 ;
3388 true
3389 )
3390 )
3391 )
3392 ).
3393 % global_ground_store_name(C,StoreName),
3394 % make_get_store_goal(StoreName,Store,GetStoreGoal),
3395 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
3396 % Body =
3397 % (
3398 % GetStoreGoal, % nb_getval(StoreName,Store),
3399 % 'chr sbag_del_element'(Store,Susp,NStore),
3400 % UpdateStoreGoal % b_setval(StoreName,NStore)
3401 % ).
3402 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
3403 get_target_module(Module),
3404 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
3405 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
3406 Body = (
3407 VariableGoal,
3408 get_attr(Variable,Module,AssocStore),
3409 KeyGoal,
3410 delete_assoc_store(AssocStore,Key,Susp)
3411 ).
3412 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
3413 global_singleton_store_name(C,StoreName),
3414 make_update_store_goal(StoreName,[],UpdateStoreGoal),
3415 Body =
3416 (
3417 UpdateStoreGoal % b_setval(StoreName,[])
3418 ).
3419 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
3420 maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies),
3421 list2conj(Bodies,Body).
3422 delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :-
3423 delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body).
3424 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
3425 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3426 get_identifier_size(ISize),
3427 functor(Struct,struct,ISize),
3428 get_identifier_index(C,Index,IIndex),
3429 arg(IIndex,Struct,Susps),
3430 Body = (
3431 VariableGoal,
3432 Variable = Struct,
3433 'chr sbag_del_element'(Susps,Susp,NSusps),
3434 setarg(IIndex,Variable,NSusps)
3435 ).
3436 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
3437 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal),
3438 type_indexed_identifier_structure(IndexType,Struct),
3439 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3440 arg(IIndex,Struct,Susps),
3441 Body = (
3442 VariableGoal,
3443 Variable = Struct,
3444 'chr sbag_del_element'(Susps,Susp,NSusps),
3445 setarg(IIndex,Variable,NSusps)
3446 ).
3448 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
3449 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
3450 multi_hash_store_name(FA,Index,StoreName),
3451 multi_hash_key(FA,Index,Susp,KeyBody,Key),
3452 Body =
3453 (
3454 KeyBody,
3455 nb_getval(StoreName,Store),
3456 delete_iht(Store,Key,Susp)
3457 ),
3458 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
3459 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
3460 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
3461 multi_hash_store_name(C,Index,StoreName),
3462 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3463 make_get_store_goal(StoreName,Store,GetStoreGoal),
3464 ( chr_pp_flag(ht_removal,on)
3465 -> ht_prev_field(Index,PrevField),
3466 get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal),
3467 set_dynamic_suspension_term_field(PrevField,C,NextSusp,_,
3468 SetGoal1),
3469 set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev,
3470 SetGoal2),
3471 Body =
3472 (
3473 GetGoal,
3474 ( var(Prev)
3475 -> GetStoreGoal,
3476 KeyBody,
3477 delete_first_ht(Store,Key,Values),
3478 ( Values = [NextSusp|_]
3479 -> SetGoal1
3480 ; true
3481 )
3482 ; Prev = [_,_|Values],
3483 setarg(2,Prev,Values),
3484 ( Values = [NextSusp|_]
3485 -> SetGoal2
3486 ; true
3487 )
3488 )
3489 )
3490 ; Body =
3491 (
3492 KeyBody,
3493 GetStoreGoal, % nb_getval(StoreName,Store),
3494 delete_ht(Store,Key,Susp)
3495 )
3496 ),
3497 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3499 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3501 :- chr_constraint
3502 module_initializer/1,
3503 module_initializers/1.
3505 module_initializers(G), module_initializer(Initializer) <=>
3506 G = (Initializer,Initializers),
3507 module_initializers(Initializers).
3509 module_initializers(G) <=>
3510 G = true.
3512 generate_attach_code(Constraints,Clauses) :-
3513 enumerate_stores_code(Constraints,Enumerate),
3514 append(Enumerate,L,Clauses),
3515 generate_attach_code(Constraints,L,T),
3516 module_initializers(Initializers),
3517 prolog_global_variables_code(PrologGlobalVariables),
3518 % Do not rename or the 'chr_initialization' predicate
3519 % without warning SSS
3520 T = [('$chr_initialization' :- Initializers),(:- initialization '$chr_initialization')|PrologGlobalVariables].
3522 generate_attach_code([],L,L).
3523 generate_attach_code([C|Cs],L,T) :-
3524 get_store_type(C,StoreType),
3525 generate_attach_code(StoreType,C,L,L1),
3526 generate_attach_code(Cs,L1,T).
3528 generate_attach_code(default,C,L,T) :-
3529 global_list_store_initialisation(C,L,T).
3530 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3531 multi_inthash_store_initialisations(Indexes,C,L,L1),
3532 multi_inthash_via_lookups(Indexes,C,L1,T).
3533 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3534 multi_hash_store_initialisations(Indexes,C,L,L1),
3535 multi_hash_lookups(Indexes,C,L1,T).
3536 generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :-
3537 constants_initializers(C,Index,Constants),
3538 atomic_constants_code(C,Index,Constants,L,T).
3539 generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :-
3540 constants_initializers(C,Index,Constants),
3541 ground_constants_code(C,Index,Constants,L,T).
3542 generate_attach_code(global_ground,C,L,T) :-
3543 global_ground_store_initialisation(C,L,T).
3544 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3545 use_auxiliary_module(chr_assoc_store).
3546 generate_attach_code(global_singleton,C,L,T) :-
3547 global_singleton_store_initialisation(C,L,T).
3548 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3549 multi_store_generate_attach_code(StoreTypes,C,L,T).
3550 generate_attach_code(identifier_store(Index),C,L,T) :-
3551 get_identifier_index(C,Index,IIndex),
3552 ( IIndex == 2 ->
3553 get_identifier_size(ISize),
3554 functor(Struct,struct,ISize),
3555 Struct =.. [_,Label|Stores],
3556 set_elems(Stores,[]),
3557 Clause1 = new_identifier(Label,Struct),
3558 functor(Struct2,struct,ISize),
3559 arg(1,Struct2,Label2),
3560 Clause2 =
3561 ( user:portray(Struct2) :-
3562 write('<id:'),
3563 print(Label2),
3564 write('>')
3565 ),
3566 functor(Struct3,struct,ISize),
3567 arg(1,Struct3,Label3),
3568 Clause3 = identifier_label(Struct3,Label3),
3569 L = [Clause1,Clause2,Clause3|T]
3570 ;
3571 L = T
3572 ).
3573 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3574 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3575 ( IIndex == 2 ->
3576 identifier_store_initialization(IndexType,L,L1),
3577 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3578 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3579 get_type_indexed_identifier_size(IndexType,ISize),
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3581 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3582 type_indexed_identifier_structure(IndexType,Struct),
3583 Struct =.. [_,Label|Stores],
3584 set_elems(Stores,[]),
3585 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3586 Clause1 =.. [Name1,Label,Struct],
3587 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3588 Goal1 =.. [Name1,Label1b,S1b],
3589 type_indexed_identifier_structure(IndexType,Struct1b),
3590 Struct1b =.. [_,Label1b|Stores1b],
3591 set_elems(Stores1b,[]),
3592 Expansion1 = (S1b = Struct1b),
3593 Clause1b = user:goal_expansion(Goal1,Expansion1),
3594 % writeln(Clause1-Clause1b),
3595 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3596 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3597 type_indexed_identifier_structure(IndexType,Struct2),
3598 arg(1,Struct2,Label2),
3599 Clause2 =
3600 ( user:portray(Struct2) :-
3601 write('<id:'),
3602 print(Label2),
3603 write('>')
3604 ),
3605 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3606 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3607 type_indexed_identifier_structure(IndexType,Struct3),
3608 arg(1,Struct3,Label3),
3609 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3610 Clause3 =.. [Name3,Struct3,Label3],
3611 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3612 Goal3b =.. [Name3,S3b,L3b],
3613 type_indexed_identifier_structure(IndexType,Struct3b),
3614 arg(1,Struct3b,L3b),
3615 Expansion3b = (S3 = Struct3b),
3616 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3617 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3618 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3619 identifier_store_name(IndexType,GlobalVariable),
3620 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3621 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3622 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3623 Clause4 =
3624 ( LookupAtom :-
3625 nb_getval(GlobalVariable,HT),
3626 ( lookup_ht(HT,X,[IX]) ->
3627 true
3628 ;
3629 NewIdentifierGoal,
3630 insert_ht(HT,X,IX)
3631 )
3632 ),
3633 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3634 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3635 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3636 ;
3637 L = T
3638 ).
3640 constants_initializers(C,Index,Constants) :-
3641 maplist(constant_initializer(C,Index),Constants).
3643 constant_initializer(C,Index,Constant) :-
3644 constants_store_name(C,Index,Constant,StoreName),
3645 module_initializer(nb_setval(StoreName,[])).
3647 lookup_identifier_atom(Key,X,IX,Atom) :-
3648 atom_concat('lookup_identifier_',Key,LookupFunctor),
3649 Atom =.. [LookupFunctor,X,IX].
3651 identifier_label_atom(IndexType,IX,X,Atom) :-
3652 type_indexed_identifier_name(IndexType,identifier_label,Name),
3653 Atom =.. [Name,IX,X].
3655 multi_store_generate_attach_code([],_,L,L).
3656 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3657 generate_attach_code(ST,C,L,L1),
3658 multi_store_generate_attach_code(STs,C,L1,T).
3660 multi_inthash_store_initialisations([],_,L,L).
3661 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3662 use_auxiliary_module(chr_integertable_store),
3663 multi_hash_store_name(FA,Index,StoreName),
3664 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3665 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3666 L1 = L,
3667 multi_inthash_store_initialisations(Indexes,FA,L1,T).
3668 multi_hash_store_initialisations([],_,L,L).
3669 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3670 use_auxiliary_module(chr_hashtable_store),
3671 multi_hash_store_name(FA,Index,StoreName),
3672 prolog_global_variable(StoreName),
3673 make_init_store_goal(StoreName,HT,InitStoreGoal),
3674 module_initializer((new_ht(HT),InitStoreGoal)),
3675 L1 = L,
3676 multi_hash_store_initialisations(Indexes,FA,L1,T).
3678 global_list_store_initialisation(C,L,T) :-
3679 ( is_stored(C) ->
3680 global_list_store_name(C,StoreName),
3681 prolog_global_variable(StoreName),
3682 make_init_store_goal(StoreName,[],InitStoreGoal),
3683 module_initializer(InitStoreGoal)
3684 ;
3685 true
3686 ),
3687 L = T.
3688 global_ground_store_initialisation(C,L,T) :-
3689 global_ground_store_name(C,StoreName),
3690 prolog_global_variable(StoreName),
3691 make_init_store_goal(StoreName,[],InitStoreGoal),
3692 module_initializer(InitStoreGoal),
3693 L = T.
3694 global_singleton_store_initialisation(C,L,T) :-
3695 global_singleton_store_name(C,StoreName),
3696 prolog_global_variable(StoreName),
3697 make_init_store_goal(StoreName,[],InitStoreGoal),
3698 module_initializer(InitStoreGoal),
3699 L = T.
3700 identifier_store_initialization(IndexType,L,T) :-
3701 use_auxiliary_module(chr_hashtable_store),
3702 identifier_store_name(IndexType,StoreName),
3703 prolog_global_variable(StoreName),
3704 make_init_store_goal(StoreName,HT,InitStoreGoal),
3705 module_initializer((new_ht(HT),InitStoreGoal)),
3706 L = T.
3709 multi_inthash_via_lookups([],_,L,L).
3710 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3711 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3712 multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body),
3713 L = [(Head :- Body)|L1],
3714 multi_inthash_via_lookups(Indexes,C,L1,T).
3715 multi_hash_lookups([],_,L,L).
3716 multi_hash_lookups([Index|Indexes],C,L,T) :-
3717 multi_hash_lookup_head(C,Index,Key,SuspsList,Head),
3718 multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body),
3719 L = [(Head :- Body)|L1],
3720 multi_hash_lookups(Indexes,C,L1,T).
3722 multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :-
3723 multi_hash_lookup_name(ConstraintSymbol,Index,Name),
3724 Head =.. [Name,Key,SuspsList].
3726 %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det.
3727 %
3728 % Returns goal that performs hash table lookup.
3729 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3730 % INLINED:
3731 get_store_type(ConstraintSymbol,multi_store(Stores)),
3732 ( memberchk(atomic_constants(Index,Constants,_),Stores) ->
3733 ( ground(Key) ->
3734 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3735 Goal = nb_getval(StoreName,SuspsList)
3736 ;
3737 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3738 Lookup =.. [IndexName,Key,StoreName],
3739 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3740 )
3741 ; memberchk(ground_constants(Index,Constants,_),Stores) ->
3742 ( ground(Key) ->
3743 constants_store_name(ConstraintSymbol,Index,Key,StoreName),
3744 Goal = nb_getval(StoreName,SuspsList)
3745 ;
3746 constants_store_index_name(ConstraintSymbol,Index,IndexName),
3747 Lookup =.. [IndexName,Key,StoreName],
3748 Goal = (Lookup, nb_getval(StoreName,SuspsList))
3749 )
3750 ; memberchk(multi_hash([Index]),Stores) ->
3751 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3752 make_get_store_goal(StoreName,HT,GetStoreGoal),
3753 ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) ->
3754 Goal =
3755 (
3756 GetStoreGoal, % nb_getval(StoreName,HT),
3757 HashCall, % hash_term(Key,Hash),
3758 lookup_ht1(HT,Hash,Key,SuspsList)
3759 )
3760 ;
3761 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3762 Goal =
3763 (
3764 GetStoreGoal, % nb_getval(StoreName,HT),
3765 Lookup
3766 )
3767 )
3768 ; HashType == inthash ->
3769 multi_hash_store_name(ConstraintSymbol,Index,StoreName),
3770 make_get_store_goal(StoreName,HT,GetStoreGoal),
3771 lookup_hash_call(HashType,HT,Key,SuspsList,Lookup),
3772 Goal =
3773 (
3774 GetStoreGoal, % nb_getval(StoreName,HT),
3775 Lookup
3776 )
3777 % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol])
3778 % find alternative index
3779 % -> SubIndex + RestIndex
3780 % -> SubKey + RestKeys
3781 % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal),
3782 % instantiate rest goal?
3783 % Goal = (SubGoal,RestGoal)
3784 ).
3787 lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)).
3788 lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)).
3790 specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :-
3791 ( ground(Key) ->
3792 % This is based on a property of SWI-Prolog's
3793 % hash_term/2 predicate:
3794 % the hash value is stable over repeated invocations
3795 % of SWI-Prolog
3796 hash_term(Key,Hash),
3797 Call = true
3798 ; Index = [IndexPos],
3799 get_constraint_type(Constraint,ArgTypes),
3800 nth1(IndexPos,ArgTypes,Type),
3801 unalias_type(Type,NormalType),
3802 memberchk_eq(NormalType,[int,natural]) ->
3803 ( NormalType == int ->
3804 Call = (Hash is abs(Key))
3805 ;
3806 Hash = Key,
3807 Call = true
3808 )
3809 ;
3810 nonvar(Key),
3811 specialize_hash_term(Key,NewKey),
3812 NewKey \== Key,
3813 Call = hash_term(NewKey,Hash)
3814 ).
3816 specialize_hash_term(Term,NewTerm) :-
3817 ( ground(Term) ->
3818 hash_term(Term,NewTerm)
3819 ; var(Term) ->
3820 NewTerm = Term
3821 ;
3822 Term =.. [F|Args],
3823 maplist(specialize_hash_term,Args,NewArgs),
3824 NewTerm =.. [F|NewArgs]
3825 ).
3827 multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :-
3828 % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]),
3829 ( /* chr_pp_flag(experiment,off) ->
3830 true
3831 ; */ atomic(Key) ->
3832 actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key])
3833 ; ground(Key) ->
3834 actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key])
3835 ;
3836 ( Index = [Pos],
3837 get_constraint_arg_type(ConstraintSymbol,Pos,Type),
3838 is_chr_constants_type(Type,_,_)
3839 ->
3840 true
3841 ;
3842 actual_non_ground_multi_hash_key(ConstraintSymbol,Index)
3843 )
3844 ),
3845 delay_phase_end(validate_store_type_assumptions,
3846 multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)).
3848 :- chr_constraint actual_atomic_multi_hash_keys/3.
3849 :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)).
3851 :- chr_constraint actual_ground_multi_hash_keys/3.
3852 :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)).
3854 :- chr_constraint actual_non_ground_multi_hash_key/2.
3855 :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)).
3857 /*
3858 actual_atomic_multi_hash_keys(C,Index,Keys)
3859 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3861 actual_ground_multi_hash_keys(C,Index,Keys)
3862 ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]).
3864 actual_non_ground_multi_hash_key(C,Index)
3865 ==> format('Keys: ~w - ~w : N/A\n', [C,Index]).
3866 */
3867 actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3868 <=> append(Keys1,Keys2,Keys0),
3869 sort(Keys0,Keys),
3870 actual_atomic_multi_hash_keys(C,Index,Keys).
3872 actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2)
3873 <=> append(Keys1,Keys2,Keys0),
3874 sort(Keys0,Keys),
3875 actual_ground_multi_hash_keys(C,Index,Keys).
3877 actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2)
3878 <=> append(Keys1,Keys2,Keys0),
3879 sort(Keys0,Keys),
3880 actual_ground_multi_hash_keys(C,Index,Keys).
3882 actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index)
3883 <=> true.
3885 actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_)
3886 <=> true.
3888 actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_)
3889 <=> true.
3891 %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name)
3892 %
3893 % Returns predicate name of hash table lookup predicate.
3894 multi_hash_lookup_name(F/A,Index,Name) :-
3895 atom_concat_list(Index,IndexName),
3896 atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name).
3898 multi_hash_store_name(F/A,Index,Name) :-
3899 get_target_module(Mod),
3900 atom_concat_list(Index,IndexName),
3901 atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name).
3903 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3904 ( Index = [I] ->
3905 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3906 ;
3907 maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies),
3908 Key =.. [k|Keys],
3909 list2conj(Bodies,KeyBody)
3910 ).
3912 get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :-
3913 get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal).
3915 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3916 ( Index = [I] ->
3917 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody)
3918 ;
3919 maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies),
3920 Key =.. [k|Keys],
3921 list2conj(Bodies,KeyBody)
3922 ).
3924 get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :-
3925 arg(Index,Head,OriginalArg),
3926 ( term_variables(OriginalArg,OriginalVars),
3927 copy_term_nat(OriginalArg-OriginalVars,Arg-Vars),
3928 translate(OriginalVars,VarDict,Vars) ->
3929 Goal = true
3930 ;
3931 functor(Head,F,A),
3932 C = F/A,
3933 get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3934 ).
3936 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3937 ( Index = [I] ->
3938 UsedVars = [I-Key]
3939 ;
3940 pairup(Index,Keys,UsedVars),
3941 Key =.. [k|Keys]
3942 ).
3944 multi_hash_key_args(Index,Head,KeyArgs) :-
3945 maplist(arg1(Head),Index,KeyArgs).
3947 %-------------------------------------------------------------------------------
3948 atomic_constants_code(C,Index,Constants,L,T) :-
3949 constants_store_index_name(C,Index,IndexName),
3950 maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses),
3951 append(Clauses,T,L).
3953 atomic_constant_code(C,Index,IndexName,Constant,Clause) :-
3954 constants_store_name(C,Index,Constant,StoreName),
3955 Clause =.. [IndexName,Constant,StoreName].
3957 %-------------------------------------------------------------------------------
3958 ground_constants_code(C,Index,Terms,L,T) :-
3959 constants_store_index_name(C,Index,IndexName),
3960 maplist(constants_store_name(C,Index),Terms,StoreNames),
3961 length(Terms,N),
3962 replicate(N,[],More),
3963 trie_index([Terms|More],StoreNames,IndexName,L,T).
3965 constants_store_name(F/A,Index,Term,Name) :-
3966 get_target_module(Mod),
3967 term_to_atom(Term,Constant),
3968 term_to_atom(Index,IndexAtom),
3969 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name).
3971 constants_store_index_name(F/A,Index,Name) :-
3972 get_target_module(Mod),
3973 term_to_atom(Index,IndexAtom),
3974 atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name).
3976 % trie index code {{{
3977 trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :-
3978 trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail).
3980 trie_step([],_,_,[],[],L,L) :- !.
3981 % length MorePatterns == length Patterns == length Results
3982 trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :-
3983 MorePatterns = [List|_],
3984 length(List,N),
3985 aggregate_all(set(F/A),
3986 ( member(Pattern,Patterns),
3987 functor(Pattern,F,A)
3988 ),
3989 FAs),
3990 N1 is N + 1,
3991 trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T).
3993 trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses).
3994 trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :-
3995 trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1),
3996 trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail).
3998 trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :-
3999 Clause = (Head :- Body),
4000 /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */
4001 N1 is N + 1,
4002 functor(Head,Symbol,N1),
4003 arg(1,Head,IndexPattern),
4004 Head =.. [_,_|RestArgs],
4005 once(append(Vs,[Result],RestArgs)),
4006 /* IndexPattern = F() */
4007 functor(IndexPattern,F,A),
4008 IndexPattern =.. [_|Args],
4009 append(Args,RestArgs,RecArgs),
4010 ( RecArgs == [Result] ->
4011 /* nothing more to match on */
4012 List = Tail,
4013 Body = true,
4014 rec_cases(Patterns,_,Results,F/A,_,_,MoreResults),
4015 MoreResults = [Result]
4016 ; /* more things to match on */
4017 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults),
4018 ( MoreCases = [OneMoreCase] ->
4019 /* only one more thing to match on */
4020 List = Tail,
4021 Body = true,
4022 append([Cases,OneMoreCase,MoreResults],RecArgs)
4023 ;
4024 /* more than one thing to match on */
4025 /* [ x1,..., xn]
4026 [xs1,...,xsn]
4027 */
4028 pairup(Cases,MoreCases,CasePairs),
4029 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
4030 append(Args,Vs,[First|Rest]),
4031 First-Rest = CommonPatternPair,
4032 % Body = RSymbol(DiffVars,Result)
4033 gensym(Prefix,RSymbol),
4034 append(DiffVars,[Result],RecCallVars),
4035 Body =.. [RSymbol|RecCallVars],
4036 maplist(head_tail,Differences,CHs,CTs),
4037 trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail)
4038 )
4039 ).
4041 head_tail([H|T],H,T).
4043 rec_cases([],[],[],_,[],[],[]).
4044 rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :-
4045 ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) ->
4046 Cases = [Case|NCases],
4047 MoreCases = [MoreCase|NMoreCases],
4048 MoreResults = [Result|NMoreResults],
4049 rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults)
4050 ;
4051 rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults)
4052 ).
4053 % }}}
4055 %% common_pattern(+terms,-term,-vars,-differences) is det.
4056 common_pattern(Ts,T,Vars,Differences) :-
4057 fold1(gct,Ts,T),
4058 term_variables(T,Vars),
4059 findall(Vars,member(T,Ts),Differences).
4061 gct(T1,T2,T) :-
4062 gct_(T1,T2,T,[],_).
4064 gct_(T1,T2,T,Dict0,Dict) :-
4065 ( nonvar(T1),
4066 nonvar(T2),
4067 functor(T1,F1,A1),
4068 functor(T2,F2,A2),
4069 F1 == F2,
4070 A1 == A2 ->
4071 functor(T,F1,A1),
4072 T1 =.. [_|Args1],
4073 T2 =.. [_|Args2],
4074 T =.. [_|Args],
4075 maplist_dcg(gct_,Args1,Args2,Args,Dict0,Dict)
4076 ;
4077 /* T is a variable */
4078 ( lookup_eq(Dict0,T1+T2,T) ->
4079 /* we already have a variable for this difference */
4080 Dict = Dict0
4081 ;
4082 /* T is a fresh variable */
4083 Dict = [(T1+T2)-T|Dict0]
4084 )
4085 ).
4088 fold1(P,[Head|Tail],Result) :-
4089 fold(Tail,P,Head,Result).
4091 fold([],_,Acc,Acc).
4092 fold([X|Xs],P,Acc,Res) :-
4093 call(P,X,Acc,NAcc),
4094 fold(Xs,P,NAcc,Res).
4096 maplist_dcg(P,L1,L2,L) -->
4097 maplist_dcg_(L1,L2,L,P).
4099 maplist_dcg_([],[],[],_) --> [].
4100 maplist_dcg_([X|Xs],[Y|Ys],[Z|Zs],P) -->
4101 call(P,X,Y,Z),
4102 maplist_dcg_(Xs,Ys,Zs,P).
4104 %-------------------------------------------------------------------------------
4105 global_list_store_name(F/A,Name) :-
4106 get_target_module(Mod),
4107 atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name).
4108 global_ground_store_name(F/A,Name) :-
4109 get_target_module(Mod),
4110 atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name).
4111 global_singleton_store_name(F/A,Name) :-
4112 get_target_module(Mod),
4113 atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name).
4115 identifier_store_name(TypeName,Name) :-
4116 get_target_module(Mod),
4117 atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name).
4119 :- chr_constraint prolog_global_variable/1.
4120 :- chr_option(mode,prolog_global_variable(+)).
4122 :- chr_constraint prolog_global_variables/1.
4123 :- chr_option(mode,prolog_global_variables(-)).
4125 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
4127 prolog_global_variables(List), prolog_global_variable(Name) <=>
4128 List = [Name|Tail],
4129 prolog_global_variables(Tail).
4130 prolog_global_variables(List) <=> List = [].
4132 %% SWI begin
4133 prolog_global_variables_code(Code) :-
4134 prolog_global_variables(Names),
4135 ( Names == [] ->
4136 Code = []
4137 ;
4138 maplist(wrap_in_functor('$chr_prolog_global_variable'),Names,NameDeclarations),
4139 Code = [(:- dynamic user:exception/3),
4140 (:- multifile user:exception/3),
4141 (user:exception(undefined_global_variable,Name,retry) :-
4142 (
4143 '$chr_prolog_global_variable'(Name),
4144 '$chr_initialization'
4145 )
4146 )
4147 |
4148 NameDeclarations
4149 ]
4150 ).
4151 %% SWI end
4152 %% SICStus begin
4153 % prolog_global_variables_code([]).
4154 %% SICStus end
4155 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4156 %sbag_member_call(S,L,sysh:mem(S,L)).
4157 sbag_member_call(S,L,'chr sbag_member'(S,L)).
4158 %sbag_member_call(S,L,member(S,L)).
4159 update_mutable_call(A,B,'chr update_mutable'( A, B)).
4160 %update_mutable_call(A,B,setarg(1, B, A)).
4161 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
4162 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
4164 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
4165 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4166 % create_get_mutable(Value,Field,Get1).
4167 %
4168 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
4169 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
4170 % update_mutable_call(NewValue,Field,Set).
4171 %
4172 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
4173 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
4174 % create_get_mutable_ref(Value,Field,Get1),
4175 % update_mutable_call(NewValue,Field,Set).
4176 %
4177 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
4178 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4179 % create_mutable_call(Value,Field,Create).
4180 %
4181 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4182 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
4183 % create_get_mutable(Value,Field,Get).
4184 %
4185 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
4186 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
4187 % create_get_mutable_ref(Value,Field,Get),
4188 % update_mutable_call(NewValue,Field,Set).
4190 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
4191 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
4193 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
4194 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4196 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
4197 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
4198 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4200 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4201 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4203 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
4204 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
4206 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
4207 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
4208 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
4210 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4212 enumerate_stores_code(Constraints,[Clause|List]) :-
4213 Head = '$enumerate_constraints'(Constraint),
4214 Clause = ( Head :- Body),
4215 enumerate_store_bodies(Constraints,Constraint,List),
4216 ( List = [] ->
4217 Body = fail
4218 ;
4219 Body = ( nonvar(Constraint) ->
4220 functor(Constraint,Functor,_),
4221 '$enumerate_constraints'(Functor,Constraint)
4222 ;
4223 '$enumerate_constraints'(_,Constraint)
4224 )
4225 ).
4227 enumerate_store_bodies([],_,[]).
4228 enumerate_store_bodies([C|Cs],Constraint,L) :-
4229 ( is_stored(C) ->
4230 get_store_type(C,StoreType),
4231 ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) ->
4232 true
4233 ;
4234 chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C])
4235 ),
4236 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
4237 C = F/_,
4238 Constraint0 =.. [F|Arguments],
4239 Head = '$enumerate_constraints'(F,Constraint),
4240 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
4241 L = [(Head :- Body)|T]
4242 ;
4243 L = T
4244 ),
4245 enumerate_store_bodies(Cs,Constraint,T).
4247 enumerate_store_body(default,C,Susp,Body) :-
4248 global_list_store_name(C,StoreName),
4249 sbag_member_call(Susp,List,Sbag),
4250 make_get_store_goal(StoreName,List,GetStoreGoal),
4251 Body =
4252 (
4253 GetStoreGoal, % nb_getval(StoreName,List),
4254 Sbag
4255 ).
4256 % get_constraint_index(C,Index),
4257 % get_target_module(Mod),
4258 % get_max_constraint_index(MaxIndex),
4259 % Body1 =
4260 % (
4261 % 'chr default_store'(GlobalStore),
4262 % get_attr(GlobalStore,Mod,Attr)
4263 % ),
4264 % ( MaxIndex > 1 ->
4265 % NIndex is Index + 1,
4266 % sbag_member_call(Susp,List,Sbag),
4267 % Body2 =
4268 % (
4269 % arg(NIndex,Attr,List),
4270 % Sbag
4271 % )
4272 % ;
4273 % sbag_member_call(Susp,Attr,Sbag),
4274 % Body2 = Sbag
4275 % ),
4276 % Body = (Body1,Body2).
4277 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
4278 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
4279 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
4280 multi_hash_enumerate_store_body(Index,C,Susp,Body).
4281 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :-
4282 Completeness == complete, % fail if incomplete
4283 maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts),
4284 list2disj(Disjuncts, Disjunction),
4285 Body = ( Disjunction, member(Susp,Susps) ).
4286 enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :-
4287 constants_store_name(C,Index,Constant,StoreName).
4289 enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :-
4290 enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body).
4291 enumerate_store_body(global_ground,C,Susp,Body) :-
4292 global_ground_store_name(C,StoreName),
4293 sbag_member_call(Susp,List,Sbag),
4294 make_get_store_goal(StoreName,List,GetStoreGoal),
4295 Body =
4296 (
4297 GetStoreGoal, % nb_getval(StoreName,List),
4298 Sbag
4299 ).
4300 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
4301 Body = fail.
4302 enumerate_store_body(global_singleton,C,Susp,Body) :-
4303 global_singleton_store_name(C,StoreName),
4304 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4305 Body =
4306 (
4307 GetStoreGoal, % nb_getval(StoreName,Susp),
4308 Susp \== []
4309 ).
4310 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
4311 ( memberchk(global_ground,STs) ->
4312 enumerate_store_body(global_ground,C,Susp,Body)
4313 ;
4314 once((
4315 member(ST,STs),
4316 enumerate_store_body(ST,C,Susp,Body)
4317 ))
4318 ).
4319 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
4320 Body = fail.
4321 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
4322 Body = fail.
4324 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
4325 multi_hash_store_name(C,I,StoreName),
4326 B =
4327 (
4328 nb_getval(StoreName,HT),
4329 value_iht(HT,Susp)
4330 ).
4331 multi_hash_enumerate_store_body(I,C,Susp,B) :-
4332 multi_hash_store_name(C,I,StoreName),
4333 make_get_store_goal(StoreName,HT,GetStoreGoal),
4334 B =
4335 (
4336 GetStoreGoal, % nb_getval(StoreName,HT),
4337 value_ht(HT,Susp)
4338 ).
4340 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4341 % BACKGROUND INFORMATION (declared using :- chr_declaration)
4342 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4344 :- chr_constraint
4345 background_info/1,
4346 background_info/2,
4347 get_bg_info/1,
4348 get_bg_info/2,
4349 get_bg_info_answer/1.
4351 background_info(X), background_info(Y) <=>
4352 append(X,Y,XY), background_info(XY).
4353 background_info(X) \ get_bg_info(Q) <=> Q=X.
4354 get_bg_info(Q) <=> Q = [].
4356 background_info(T,I), get_bg_info(A,Q) ==>
4357 copy_term_nat(T,T1),
4358 subsumes_chk(T1,A)
4359 |
4360 copy_term_nat(T-I,A-X),
4361 get_bg_info_answer([X]).
4362 get_bg_info_answer(X), get_bg_info_answer(Y) <=>
4363 append(X,Y,XY), get_bg_info_answer(XY).
4365 get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id).
4366 get_bg_info(_,Q) <=> Q=[]. % no info found on this term
4368 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4371 :- chr_constraint
4372 prev_guard_list/8,
4373 prev_guard_list/6,
4374 simplify_guards/1,
4375 set_all_passive/1.
4377 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)).
4378 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)).
4379 :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)).
4380 :- chr_option(mode,simplify_guards(+)).
4381 :- chr_option(mode,set_all_passive(+)).
4383 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4384 % GUARD SIMPLIFICATION
4385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4386 % If the negation of the guards of earlier rules entails (part of)
4387 % the current guard, the current guard can be simplified. We can only
4388 % use earlier rules with a head that matches if the head of the current
4389 % rule does, and which make it impossible for the current rule to match
4390 % if they fire (i.e. they shouldn't be propagation rules and their
4391 % head constraints must be subsets of those of the current rule).
4392 % At this point, we know for sure that the negation of the guard
4393 % of such a rule has to be true (otherwise the earlier rule would have
4394 % fired, because of the refined operational semantics), so we can use
4395 % that information to simplify the guard by replacing all entailed
4396 % conditions by true/0. As a consequence, the never-stored analysis
4397 % (in a further phase) will detect more cases of never-stored constraints.
4398 %
4399 % e.g. c(X),d(Y) <=> X > 0 | ...
4400 % e(X) <=> X < 0 | ...
4401 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
4402 % \____________/
4403 % true
4405 guard_simplification :-
4406 ( chr_pp_flag(guard_simplification,on) ->
4407 precompute_head_matchings,
4408 simplify_guards(1)
4409 ;
4410 true
4411 ).
4413 % for every rule, we create a prev_guard_list where the last argument
4414 % eventually is a list of the negations of earlier guards
4415 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
4416 <=>
4417 Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb),
4418 append(Head1,Head2,Heads),
4419 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
4420 tree_set_empty(Done),
4421 multiple_occ_constraints_checked(Done),
4422 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
4424 append(IDs1,IDs2,IDs),
4425 findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData),
4426 empty_q(EmptyHeap),
4427 insert_list_q(HeapData,EmptyHeap,Heap),
4428 next_prev_rule(Heap,_,Heap1),
4429 next_prev_rule(Heap1,PrevRuleNb,NHeap),
4430 prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
4431 NextRule is RuleNb+1,
4432 simplify_guards(NextRule).
4434 next_prev_rule(Heap,RuleNb,NHeap) :-
4435 ( find_min_q(Heap,_-Priority) ->
4436 Priority = (-RuleNb),
4437 normalize_heap(Heap,Priority,NHeap)
4438 ;
4439 RuleNb = 0,
4440 NHeap = Heap
4441 ).
4443 normalize_heap(Heap,Priority,NHeap) :-
4444 ( find_min_q(Heap,_-Priority) ->
4445 delete_min_q(Heap,Heap1,tuple(C,O,_)-_),
4446 ( O > 1 ->
4447 NO is O -1,
4448 get_occurrence(C,NO,RuleNb,_),
4449 insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2)
4450 ;
4451 Heap2 = Heap1
4452 ),
4453 normalize_heap(Heap2,Priority,NHeap)
4454 ;
4455 NHeap = Heap
4456 ).
4458 % no more rule
4459 simplify_guards(_)
4460 <=>
4461 true.
4463 % The negation of the guard of a non-propagation rule is added
4464 % if its kept head constraints are a subset of the kept constraints of
4465 % the rule we're working on, and its removed head constraints (at least one)
4466 % are a subset of the removed constraints.
4468 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH)
4469 <=>
4470 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb
4471 H1 \== [],
4472 make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings),
4473 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
4474 |
4475 append(H1,H2,Heads),
4476 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
4477 append(GuardList,DerivedInfo,GL1),
4478 normalize_conj_list(GL1,GL),
4479 append(GH_New1,GH,GH1),
4480 normalize_conj_list(GH1,GH_New),
4481 next_prev_rule(Heap,PrevPrevRuleNb,NHeap),
4482 % PrevPrevRuleNb is PrevRuleNb-1,
4483 prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New).
4485 % if this isn't the case, we skip this one and try the next rule
4486 prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH)
4487 <=>
4488 ( N > 0 ->
4489 next_prev_rule(Heap,N1,NHeap),
4490 % N1 is N-1,
4491 prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH)
4492 ;
4493 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4494 ).
4496 prev_guard_list(RuleNb,H,G,GuardList,M,GH)
4497 <=>
4498 GH \== []
4499 |
4500 head_types_modes_condition(GH,H,TypeInfo),
4501 conj2list(TypeInfo,TI),
4502 term_variables(H,HeadVars),
4503 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
4504 normalize_conj_list(Info,InfoL),
4505 append(H,InfoL,RelevantTerms),
4506 add_background_info([G|RelevantTerms],BGInfo),
4507 append(InfoL,BGInfo,AllInfo_),
4508 normalize_conj_list(AllInfo_,AllInfo),
4509 prev_guard_list(RuleNb,H,G,AllInfo,M,[]).
4511 head_types_modes_condition([],H,true).
4512 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
4513 types_modes_condition(H,GH,TI1),
4514 head_types_modes_condition(GHs,H,TI2).
4516 add_background_info(Term,Info) :-
4517 get_bg_info(GeneralInfo),
4518 add_background_info2(Term,TermInfo),
4519 append(GeneralInfo,TermInfo,Info).
4521 add_background_info2(X,[]) :- var(X), !.
4522 add_background_info2([],[]) :- !.
4523 add_background_info2([X|Xs],Info) :- !,
4524 add_background_info2(X,Info1),
4525 add_background_info2(Xs,Infos),
4526 append(Info1,Infos,Info).
4528 add_background_info2(X,Info) :-
4529 (functor(X,_,A), A>0 ->
4530 X =.. [_|XArgs],
4531 add_background_info2(XArgs,XArgInfo)
4532 ;
4533 XArgInfo = []
4534 ),
4535 get_bg_info(X,XInfo),
4536 append(XInfo,XArgInfo,Info).
4538 %%
4539 % when all earlier guards are added or skipped, we simplify the guard.
4540 % if it's different from the original one, we change the rule
4542 prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule)
4543 <=>
4544 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4545 G \== true, % let's not try to simplify this ;)
4546 append(M,GuardList,Info),
4547 (% if guard + context is a contradiction, it should be simplified to "fail"
4548 conj2list(G,GL), append(Info,GL,GuardWithContext),
4549 guard_entailment:entails_guard(GuardWithContext,fail) ->
4550 SimpleGuard = fail
4551 ;
4552 % otherwise we try to remove redundant conjuncts
4553 simplify_guard(G,B,Info,SimpleGuard,NB)
4554 ),
4555 G \== SimpleGuard % only do this if we can change the guard
4556 |
4557 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
4558 prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]).
4560 %% normalize_conj_list(+List,-NormalList) is det.
4561 %
4562 % Removes =true= elements and flattens out conjunctions.
4564 normalize_conj_list(List,NormalList) :-
4565 list2conj(List,Conj),
4566 conj2list(Conj,NormalList).
4568 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4569 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
4570 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4572 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
4573 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
4574 copy_term(PrevMatchings-PrevGuard,FreshMatchings),
4575 variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
4576 append(Renaming1,ExtraRenaming,Renaming2),
4577 list2conj(PrevMatchings,Match),
4578 negate_b(Match,HeadsDontMatch),
4579 make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
4580 list2conj(HeadsMatch,HeadsMatchBut),
4581 term_variables(Renaming2,RenVars),
4582 term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
4583 new_vars(MGVars,RenVars,ExtraRenaming2),
4584 append(Renaming2,ExtraRenaming2,Renaming),
4585 ( PrevGuard == true -> % true can't fail
4586 Info_ = HeadsDontMatch
4587 ;
4588 negate_b(PrevGuard,TheGuardFailed),
4589 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
4590 ),
4591 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
4592 copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
4593 copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
4594 list2conj(RenamedMatchings_,RenamedMatchings),
4595 apply_guard_wrt_term(H,RenamedG2,GH2),
4596 apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
4597 compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
4599 simplify_guard(G,B,Info,SG,NB) :-
4600 conj2list(G,LG),
4601 % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl,
4602 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
4603 list2conj(SGL,SG).
4606 new_vars([],_,[]).
4607 new_vars([A|As],RV,ER) :-
4608 ( memberchk_eq(A,RV) ->
4609 new_vars(As,RV,ER)
4610 ;
4611 ER = [A-NewA,NewA-A|ER2],
4612 new_vars(As,RV,ER2)
4613 ).
4615 %% head_subset(+Subset,+MultiSet,-Renaming) is nondet.
4616 %
4617 % check if a list of constraints is a subset of another list of constraints
4618 % (multiset-subset), meanwhile computing a variable renaming to convert
4619 % one into the other.
4620 head_subset(H,Head,Renaming) :-
4621 head_subset(H,Head,Renaming,[],_).
4623 head_subset([],Remainder,Renaming,Renaming,Remainder).
4624 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
4625 head_member(MultiSet,X,NAcc,Acc,Remainder1),
4626 head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
4628 % check if A is in the list, remove it from Headleft
4629 head_member([X|Xs],A,Renaming,Acc,Remainder) :-
4630 ( variable_replacement(A,X,Acc,Renaming),
4631 Remainder = Xs
4632 ;
4633 Remainder = [X|RRemainder],
4634 head_member(Xs,A,Renaming,Acc,RRemainder)
4635 ).
4636 %-------------------------------------------------------------------------------%
4637 % memoing code to speed up repeated computation
4639 :- chr_constraint precompute_head_matchings/0.
4641 rule(RuleNb,PragmaRule), precompute_head_matchings ==>
4642 PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb),
4643 append(H1,H2,Heads),
4644 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings),
4645 copy_term_nat(MatchingFreeHeads-Matchings,A-B),
4646 make_head_matchings_explicit_memo_table(RuleNb,A,B).
4648 precompute_head_matchings <=> true.
4650 :- chr_constraint make_head_matchings_explicit_memo_table/3.
4651 :- chr_constraint make_head_matchings_explicit_memo_lookup/3.
4653 :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)).
4654 :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)).
4656 make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \
4657 make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2)
4658 <=>
4659 Q1 = NHeads,
4660 Q2 = Matchings.
4661 make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail.
4663 make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :-
4664 make_head_matchings_explicit_memo_lookup(RuleNb,A,B),
4665 copy_term_nat(A-B,MatchingFreeHeads-Matchings).
4666 %-------------------------------------------------------------------------------%
4668 make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :-
4669 extract_arguments(Heads,Arguments),
4670 make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings),
4671 substitute_arguments(Heads,FreeVariables,MatchingFreeHeads).
4673 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
4674 extract_arguments(Heads,Arguments),
4675 make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
4676 substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
4678 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
4679 extract_arguments(Heads,Arguments1),
4680 extract_arguments(MatchingFreeHeads,Arguments2),
4681 make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
4683 %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
4684 %
4685 % Returns list of arguments of given list of constraints.
4686 extract_arguments([],[]).
4687 extract_arguments([Constraint|Constraints],AllArguments) :-
4688 Constraint =.. [_|Arguments],
4689 append(Arguments,RestArguments,AllArguments),
4690 extract_arguments(Constraints,RestArguments).
4692 %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
4693 %
4694 % Substitutes arguments of constraints with those in the given list.
4696 substitute_arguments([],[],[]).
4697 substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :-
4698 functor(Constraint,F,N),
4699 split_at(N,Variables,Arguments,RestVariables),
4700 NConstraint =.. [F|Arguments],
4701 substitute_arguments(Constraints,RestVariables,NConstraints).
4703 make_matchings_explicit([],[],_,MC,MC,[]).
4704 make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :-
4705 ( var(Arg) ->
4706 ( memberchk_eq(Arg,VarAcc) ->
4707 list2disj(MatchingCondition,MatchingCondition_disj),
4708 Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ??
4709 NVarAcc = VarAcc
4710 ;
4711 Matchings = RestMatchings,
4712 NewVar = Arg,
4713 NVarAcc = [Arg|VarAcc]
4714 ),
4715 MatchingCondition2 = MatchingCondition
4716 ;
4717 functor(Arg,F,A),
4718 Arg =.. [F|RecArgs],
4719 make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings),
4720 FlatArg =.. [F|RecVars],
4721 ( RecMatchings == [] ->
4722 Matchings = [functor(NewVar,F,A)|RestMatchings]
4723 ;
4724 list2conj(RecMatchings,ArgM_conj),
4725 list2disj(MatchingCondition,MatchingCondition_disj),
4726 ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj),
4727 Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings]
4728 ),
4729 MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_],
4730 term_variables(Args,ArgVars),
4731 append(ArgVars,VarAcc,NVarAcc)
4732 ),
4733 make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings).
4736 %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
4737 %
4738 % Returns list of new variables and list of pairwise unifications between given list and variables.
4740 make_matchings_explicit_not_negated([],[],[]).
4741 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
4742 Matchings = [Var = X|RMatchings],
4743 make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
4745 %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
4746 %
4747 % (Partially) applies substitutions of =Goal= to given list.
4749 apply_guard_wrt_term([],_Guard,[]).
4750 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
4751 ( var(Term) ->
4752 apply_guard_wrt_variable(Guard,Term,NTerm)
4753 ;
4754 Term =.. [F|HArgs],
4755 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
4756 NTerm =.. [F|NewHArgs]
4757 ),
4758 apply_guard_wrt_term(RH,Guard,RGH).
4760 %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
4761 %
4762 % (Partially) applies goal =Guard= wrt variable.
4764 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
4765 apply_guard_wrt_variable(Guard1,Variable,NVariable1),
4766 apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
4767 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
4768 ( Guard = (X = Y), Variable == X ->
4769 NVariable = Y
4770 ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
4771 functor(NVariable,Functor,Arity)
4772 ;
4773 NVariable = Variable
4774 ).
4777 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4778 % ALWAYS FAILING GUARDS
4779 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4781 prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule)
4782 ==>
4783 chr_pp_flag(check_impossible_rules,on),
4784 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
4785 conj2list(G,GL),
4786 append(M,GuardList,Info),
4787 append(Info,GL,GuardWithContext),
4788 guard_entailment:entails_guard(GuardWithContext,fail)
4789 |
4790 chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
4791 set_all_passive(RuleNb).
4793 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4794 % HEAD SIMPLIFICATION
4795 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4797 % now we check the head matchings (guard may have been simplified meanwhile)
4798 prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
4799 <=>
4800 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
4801 simplify_heads(M,GuardList,G,B,NewM,NewB),
4802 NewM \== [],
4803 extract_arguments(Head1,VH1),
4804 extract_arguments(Head2,VH2),
4805 extract_arguments(H,VH),
4806 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
4807 substitute_arguments(Head1,H1,NewH1),
4808 substitute_arguments(Head2,H2,NewH2),
4809 append(NewB,NewB_,NewBody),
4810 list2conj(NewBody,BodyMatchings),
4811 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
4812 (Head1 \== NewH1 ; Head2 \== NewH2 )
4813 |
4814 rule(RuleNb,NewRule).
4816 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4817 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
4818 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4820 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
4821 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
4822 ( NH == M ->
4823 H2_ = M,
4824 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
4825 ;
4826 (M = functor(X,F,A), NH == X ->
4827 length(A_args,A),
4828 (var(H2) ->
4829 NewB1 = [],
4830 H2_ =.. [F|A_args]
4831 ;
4832 H2 =.. [F|OrigArgs],
4833 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4834 H2_ =.. [F|A_args_]
4835 ),
4836 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
4837 append(NewB1,NewB2,NewB)
4838 ;
4839 H2_ = H2,
4840 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
4841 )
4842 ).
4844 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
4845 ( NH == M ->
4846 H1_ = M,
4847 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
4848 ;
4849 (M = functor(X,F,A), NH == X ->
4850 length(A_args,A),
4851 (var(H1) ->
4852 NewB1 = [],
4853 H1_ =.. [F|A_args]
4854 ;
4855 H1 =.. [F|OrigArgs],
4856 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
4857 H1_ =.. [F|A_args_]
4858 ),
4859 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
4860 append(NewB1,NewB2,NewB)
4861 ;
4862 H1_ = H1,
4863 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
4864 )
4865 ).
4867 use_same_args([],[],[],_,_,[]).
4868 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4869 var(OA),!,
4870 Out = OA,
4871 use_same_args(ROA,RNA,ROut,G,Body,NewB).
4872 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
4873 nonvar(OA),!,
4874 ( common_variables(OA,Body) ->
4875 NewB = [NA = OA|NextB]
4876 ;
4877 NewB = NextB
4878 ),
4879 Out = NA,
4880 use_same_args(ROA,RNA,ROut,G,Body,NextB).
4883 simplify_heads([],_GuardList,_G,_Body,[],[]).
4884 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
4885 M = (A = B),
4886 ( (nonvar(B) ; common_variables(B,RM-GuardList)),
4887 guard_entailment:entails_guard(GuardList,(A=B)) ->
4888 ( common_variables(B,G-RM-GuardList) ->
4889 NewB = NextB,
4890 NewM = NextM
4891 ;
4892 ( common_variables(B,Body) ->
4893 NewB = [A = B|NextB]
4894 ;
4895 NewB = NextB
4896 ),
4897 NewM = [A|NextM]
4898 )
4899 ;
4900 ( nonvar(B), functor(B,BFu,BAr),
4901 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
4902 NewB = NextB,
4903 ( common_variables(B,G-RM-GuardList) ->
4904 NewM = NextM
4905 ;
4906 NewM = [functor(A,BFu,BAr)|NextM]
4907 )
4908 ;
4909 NewM = NextM,
4910 NewB = NextB
4911 )
4912 ),
4913 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
4915 common_variables(B,G) :-
4916 term_variables(B,BVars),
4917 term_variables(G,GVars),
4918 intersect_eq(BVars,GVars,L),
4919 L \== [].
4922 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
4923 set_all_passive(_) <=> true.
4927 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4928 % OCCURRENCE SUBSUMPTION
4929 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4931 :- chr_constraint
4932 first_occ_in_rule/4,
4933 next_occ_in_rule/6.
4935 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4936 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4938 :- chr_constraint multiple_occ_constraints_checked/1.
4939 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4941 prev_guard_list(RuleNb,H,G,GuardList,M,[]),
4942 occurrence(C,O,RuleNb,ID,_),
4943 occurrence(C,O2,RuleNb,ID2,_),
4944 rule(RuleNb,Rule)
4945 \
4946 multiple_occ_constraints_checked(Done)
4947 <=>
4948 O < O2,
4949 chr_pp_flag(occurrence_subsumption,on),
4950 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb
4951 H1 \== [],
4952 \+ tree_set_memberchk(C,Done)
4953 |
4954 first_occ_in_rule(RuleNb,C,O,ID),
4955 tree_set_add(Done,C,NDone),
4956 multiple_occ_constraints_checked(NDone).
4958 % Find first occurrence of constraint =C= in rule =RuleNb=
4959 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4960 <=>
4961 O < O2
4962 |
4963 first_occ_in_rule(RuleNb,C,O,ID).
4965 first_occ_in_rule(RuleNb,C,O,ID_o1)
4966 <=>
4967 C = F/A,
4968 functor(FreshHead,F,A),
4969 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4971 % Skip passive occurrences.
4972 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4973 <=>
4974 O2 is O+1
4975 |
4976 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4978 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)
4979 <=>
4980 O2 is O+1,
4981 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4982 |
4983 append(H1,H2,Heads),
4984 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4985 ( ExtraCond == [chr_pp_void_info] ->
4986 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4987 ;
4988 append(ExtraCond,Cond,NewCond),
4989 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4990 copy_term(GuardList,FGuardList),
4991 variable_replacement(GuardList,FGuardList,GLRepl),
4992 copy_with_variable_replacement(GuardList,GuardList2,Repl),
4993 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4994 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4995 append(NewCond,GuardList2,BigCond),
4996 append(BigCond,GuardList3,BigCond2),
4997 copy_with_variable_replacement(M,M2,Repl),
4998 copy_with_variable_replacement(M,M3,Repl2),
4999 append(M3,BigCond2,BigCond3),
5000 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
5001 list2conj(CheckCond,OccSubsum),
5002 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
5003 ( OccSubsum \= chr_pp_void_info ->
5004 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
5005 passive(RuleNb,ID_o2)
5006 ;
5007 true
5008 )
5009 ;
5010 true
5011 ),!,
5012 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
5013 ).
5016 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
5017 <=>
5018 true.
5020 prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
5021 <=>
5022 true.
5024 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
5025 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
5026 append(ID2,ID1,IDs),
5027 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
5028 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
5029 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
5030 copy_with_variable_replacement(G,FG,Repl),
5031 extract_explicit_matchings(FG,FG2),
5032 negate_b(FG2,NotFG),
5033 copy_with_variable_replacement(MPCond,FMPCond,Repl),
5034 ( subsumes(FH,FH2) ->
5035 FailCond = [(NotFG;FMPCond)]
5036 ;
5037 % in this case, not much can be done
5038 % e.g. c(f(...)), c(g(...)) <=> ...
5039 FailCond = [chr_pp_void_info]
5040 ).
5042 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
5043 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
5044 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
5045 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
5046 Cond = (chr_pp_not_in_store(H);Cond1),
5047 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
5049 extract_explicit_matchings((A,B),D) :- !,
5050 ( extract_explicit_matchings(A) ->
5051 extract_explicit_matchings(B,D)
5052 ;
5053 D = (A,E),
5054 extract_explicit_matchings(B,E)
5055 ).
5056 extract_explicit_matchings(A,D) :- !,
5057 ( extract_explicit_matchings(A) ->
5058 D = true
5059 ;
5060 D = A
5061 ).
5063 extract_explicit_matchings(A=B) :-
5064 var(A), var(B), !, A=B.
5065 extract_explicit_matchings(A==B) :-
5066 var(A), var(B), !, A=B.
5068 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5069 % TYPE INFORMATION
5070 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5072 :- chr_constraint
5073 type_definition/2,
5074 type_alias/2,
5075 constraint_type/2,
5076 get_type_definition/2,
5077 get_constraint_type/2.
5080 :- chr_option(mode,type_definition(?,?)).
5081 :- chr_option(mode,get_type_definition(?,?)).
5082 :- chr_option(mode,type_alias(?,?)).
5083 :- chr_option(mode,constraint_type(+,+)).
5084 :- chr_option(mode,get_constraint_type(+,-)).
5086 assert_constraint_type(Constraint,ArgTypes) :-
5087 ( ground(ArgTypes) ->
5088 constraint_type(Constraint,ArgTypes)
5089 ;
5090 chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint])
5091 ).
5093 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5094 % Consistency checks of type aliases
5096 type_alias(T1,T2) <=>
5097 var(T1)
5098 |
5099 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5101 type_alias(T1,T2) <=>
5102 var(T2)
5103 |
5104 chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]).
5106 type_alias(T,T2) <=>
5107 functor(T,F,A),
5108 functor(T2,F,A),
5109 copy_term((T,T2),(X,Y)), subsumes(X,Y)
5110 |
5111 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
5113 type_alias(T1,A1), type_alias(T2,A2) <=>
5114 functor(T1,F,A),
5115 functor(T2,F,A),
5116 \+ (T1\=T2)
5117 |
5118 copy_term_nat(T1,T1_),
5119 copy_term_nat(T2,T2_),
5120 T1_ = T2_,
5121 chr_error(type_error,
5122 '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_]).
5124 type_alias(T,B) \ type_alias(X,T2) <=>
5125 functor(T,F,A),
5126 functor(T2,F,A),
5127 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),
5128 subsumes(T1,T3)
5129 |
5130 % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
5131 type_alias(X2,D1).
5133 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5134 % Consistency checks of type definitions
5136 type_definition(T1,_), type_definition(T2,_)
5137 <=>
5138 functor(T1,F,A), functor(T2,F,A)
5139 |
5140 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
5142 type_definition(T1,_), type_alias(T2,_)
5143 <=>
5144 functor(T1,F,A), functor(T2,F,A)
5145 |
5146 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
5148 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5149 %% get_type_definition(+Type,-Definition) is semidet.
5150 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5152 get_type_definition(T,Def)
5153 <=>
5154 \+ ground(T)
5155 |
5156 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
5158 type_alias(T,D) \ get_type_definition(T2,Def)
5159 <=>
5160 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5161 copy_term_nat((T,D),(T1,D1)),T1=T2
5162 |
5163 ( get_type_definition(D1,Def) ->
5164 true
5165 ;
5166 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
5167 ).
5169 type_definition(T,D) \ get_type_definition(T2,Def)
5170 <=>
5171 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
5172 copy_term_nat((T,D),(T1,D1)),T1=T2
5173 |
5174 Def = D1.
5176 get_type_definition(Type,Def)
5177 <=>
5178 atomic_builtin_type(Type,_,_)
5179 |
5180 Def = [Type].
5182 get_type_definition(Type,Def)
5183 <=>
5184 compound_builtin_type(Type,_,_,_)
5185 |
5186 Def = [Type].
5188 get_type_definition(X,Y) <=> fail.
5190 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5191 %% get_type_definition_det(+Type,-Definition) is det.
5192 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5193 get_type_definition_det(Type,Definition) :-
5194 ( get_type_definition(Type,Definition) ->
5195 true
5196 ;
5197 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
5198 ).
5200 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5201 %% get_constraint_type(+ConstraintSymbol,-Types) is semidet.
5202 %
5203 % Return argument types of =ConstraintSymbol=, but fails if none where
5204 % declared.
5205 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5206 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
5207 get_constraint_type(_,_) <=> fail.
5209 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5210 %% get_constraint_type_det(+ConstraintSymbol,-Types) is det.
5211 %
5212 % Like =get_constraint_type/2=, but returns list of =any= types when
5213 % no types are declared.
5214 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5215 get_constraint_type_det(ConstraintSymbol,Types) :-
5216 ( get_constraint_type(ConstraintSymbol,Types) ->
5217 true
5218 ;
5219 ConstraintSymbol = _ / N,
5220 replicate(N,any,Types)
5221 ).
5222 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5223 %% unalias_type(+Alias,-Type) is det.
5224 %
5225 % Follows alias chain until base type is reached.
5226 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5227 :- chr_constraint unalias_type/2.
5229 unalias_var @
5230 unalias_type(Alias,BaseType)
5231 <=>
5232 var(Alias)
5233 |
5234 BaseType = Alias.
5236 unalias_alias @
5237 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
5238 <=>
5239 nonvar(AliasProtoType),
5240 nonvar(Alias),
5241 functor(AliasProtoType,F,A),
5242 functor(Alias,F,A),
5243 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
5244 Alias = AliasInstance
5245 |
5246 unalias_type(Type,BaseType).
5248 unalias_type_definition @
5249 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
5250 <=>
5251 nonvar(ProtoType),
5252 nonvar(Alias),
5253 functor(ProtoType,F,A),
5254 functor(Alias,F,A)
5255 |
5256 BaseType = Alias.
5258 unalias_atomic_builtin @
5259 unalias_type(Alias,BaseType)
5260 <=>
5261 atomic_builtin_type(Alias,_,_)
5262 |
5263 BaseType = Alias.
5265 unalias_compound_builtin @
5266 unalias_type(Alias,BaseType)
5267 <=>
5268 compound_builtin_type(Alias,_,_,_)
5269 |
5270 BaseType = Alias.
5272 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5273 %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
5274 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5275 :- chr_constraint types_modes_condition/3.
5276 :- chr_option(mode,types_modes_condition(+,+,?)).
5277 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
5279 types_modes_condition([],[],T) <=> T=true.
5281 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
5282 <=>
5283 functor(Head,F,A)
5284 |
5285 Head =.. [_|Args],
5286 Condition = (ModesCondition, TypesCondition, RestCondition),
5287 modes_condition(Modes,Args,ModesCondition),
5288 get_constraint_type_det(F/A,Types),
5289 UnrollHead =.. [_|RealArgs],
5290 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
5291 types_modes_condition(Heads,UnrollHeads,RestCondition).
5293 types_modes_condition([Head|_],_,_)
5294 <=>
5295 functor(Head,F,A),
5296 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
5299 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5300 %% modes_condition(+Modes,+Args,-Condition) is det.
5301 %
5302 % Return =Condition= on =Args= that checks =Modes=.
5303 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5304 modes_condition([],[],true).
5305 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
5306 ( Mode == (+) ->
5307 Condition = ( ground(Arg) , RCondition )
5308 ; Mode == (-) ->
5309 Condition = ( var(Arg) , RCondition )
5310 ;
5311 Condition = RCondition
5312 ),
5313 modes_condition(Modes,Args,RCondition).
5315 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5316 %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
5317 %
5318 % Return =Condition= on =Args= that checks =Types= given =Modes=.
5319 % =UnrollArgs= controls the depth of type definition unrolling.
5320 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5321 types_condition([],[],[],[],true).
5322 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
5323 ( Mode == (-) ->
5324 TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition
5325 ;
5326 get_type_definition_det(Type,Def),
5327 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
5328 ( Mode == (+) ->
5329 TypeConditionList = TypeConditionList1
5330 ;
5331 TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
5332 )
5333 ),
5334 list2disj(TypeConditionList,DisjTypeConditionList),
5335 types_condition(Types,Args,UnrollArgs,Modes,RCondition).
5337 type_condition([],_,_,_,[]).
5338 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
5339 ( var(DefCase) ->
5340 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
5341 ; atomic_builtin_type(DefCase,Arg,Condition) ->
5342 true
5343 ; compound_builtin_type(DefCase,Arg,Condition,_) ->
5344 true
5345 ;
5346 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
5347 ),
5348 type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
5350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5351 :- chr_type atomic_builtin_type ---> any
5352 ; number
5353 ; float
5354 ; int
5355 ; natural
5356 ; dense_int
5357 ; chr_identifier
5358 ; chr_identifier(any)
5359 ; /* all possible values are given */
5360 chr_enum(list(any))
5361 ; /* all possible values appear in rule heads;
5362 to distinguish between multiple chr_constants
5363 we have a key*/
5364 chr_constants(any)
5365 ; /* all relevant values appear in rule heads;
5366 for other values a handler is provided */
5367 chr_constants(any,any).
5368 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5370 atomic_builtin_type(any,_Arg,true).
5371 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
5372 atomic_builtin_type(int,Arg,integer(Arg)).
5373 atomic_builtin_type(number,Arg,number(Arg)).
5374 atomic_builtin_type(float,Arg,float(Arg)).
5375 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
5376 atomic_builtin_type(chr_identifier,_Arg,true).
5378 compound_builtin_type(chr_constants(_),_Arg,true,true).
5379 compound_builtin_type(chr_constants(_,_),_Arg,true,true).
5380 compound_builtin_type(chr_identifier(_),_Arg,true,true).
5381 compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)),
5382 once(( member(Constant,Constants),
5383 unifiable(Arg,Constant,_)
5384 )
5385 )
5386 ).
5388 is_chr_constants_type(chr_constants(Key),Key,no).
5389 is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)).
5391 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
5392 ( nonvar(DefCase) ->
5393 functor(DefCase,F,A),
5394 ( A == 0 ->
5395 Condition = (Arg = DefCase)
5396 ; var(UnrollArg) ->
5397 Condition = functor(Arg,F,A)
5398 ; functor(UnrollArg,F,A) ->
5399 Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
5400 DefCase =.. [_|ArgTypes],
5401 UnrollArg =.. [_|UnrollArgs],
5402 functor(Template,F,A),
5403 Template =.. [_|TemplateArgs],
5404 replicate(A,Mode,ArgModes),
5405 types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
5406 ;
5407 Condition = functor(Arg,F,A)
5408 )
5409 ;
5410 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
5411 ).
5414 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5415 % STATIC TYPE CHECKING
5416 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5417 % Checks head constraints and CHR constraint calls in bodies.
5418 %
5419 % TODO:
5420 % - type clashes involving built-in types
5421 % - Prolog built-ins in guard and body
5422 % - indicate position in terms in error messages
5423 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5424 :- chr_constraint
5425 static_type_check/0.
5428 % 1. Check the declared types
5430 constraint_type(Constraint,ArgTypes), static_type_check
5431 ==>
5432 forall(
5433 ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ),
5434 ( get_type_definition(Type,_) ->
5435 true
5436 ;
5437 chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint])
5438 )
5439 ).
5441 % 2. Check the rules
5443 :- chr_type type_error_src ---> head(any) ; body(any).
5445 rule(_,Rule), static_type_check
5446 ==>
5447 copy_term_nat(Rule,RuleCopy),
5448 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
5449 (
5450 catch(
5451 ( static_type_check_heads(Head1),
5452 static_type_check_heads(Head2),
5453 conj2list(Body,GoalList),
5454 static_type_check_body(GoalList)
5455 ),
5456 type_error(Error),
5457 ( Error = invalid_functor(Src,Term,Type) ->
5458 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
5459 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
5460 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
5461 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
5462 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
5463 )
5464 ),
5465 fail % cleanup constraints
5466 ;
5467 true
5468 ).
5471 static_type_check <=> true.
5473 static_type_check_heads([]).
5474 static_type_check_heads([Head|Heads]) :-
5475 static_type_check_head(Head),
5476 static_type_check_heads(Heads).
5478 static_type_check_head(Head) :-
5479 functor(Head,F,A),
5480 get_constraint_type_det(F/A,Types),
5481 Head =..[_|Args],
5482 maplist(static_type_check_term(head(Head)),Args,Types).
5484 static_type_check_body([]).
5485 static_type_check_body([Goal|Goals]) :-
5486 functor(Goal,F,A),
5487 get_constraint_type_det(F/A,Types),
5488 Goal =..[_|Args],
5489 maplist(static_type_check_term(body(Goal)),Args,Types),
5490 static_type_check_body(Goals).
5492 :- chr_constraint static_type_check_term/3.
5493 :- chr_option(mode,static_type_check_term(?,?,?)).
5494 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5496 static_type_check_term(Src,Term,Type)
5497 <=>
5498 var(Term)
5499 |
5500 static_type_check_var(Src,Term,Type).
5501 static_type_check_term(Src,Term,Type)
5502 <=>
5503 atomic_builtin_type(Type,Term,Goal)
5504 |
5505 ( call(Goal) ->
5506 true
5507 ;
5508 throw(type_error(invalid_functor(Src,Term,Type)))
5509 ).
5510 static_type_check_term(Src,Term,Type)
5511 <=>
5512 compound_builtin_type(Type,Term,_,Goal)
5513 |
5514 ( call(Goal) ->
5515 true
5516 ;
5517 throw(type_error(invalid_functor(Src,Term,Type)))
5518 ).
5519 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
5520 <=>
5521 functor(Type,F,A),
5522 functor(AType,F,A)
5523 |
5524 copy_term_nat(AType-ADef,Type-Def),
5525 static_type_check_term(Src,Term,Def).
5527 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
5528 <=>
5529 functor(Type,F,A),
5530 functor(AType,F,A)
5531 |
5532 copy_term_nat(AType-ADef,Type-Variants),
5533 functor(Term,TF,TA),
5534 ( member(Variant,Variants), functor(Variant,TF,TA) ->
5535 Term =.. [_|Args],
5536 Variant =.. [_|Types],
5537 maplist(static_type_check_term(Src),Args,Types)
5538 ;
5539 throw(type_error(invalid_functor(Src,Term,Type)))
5540 ).
5542 static_type_check_term(Src,Term,Type)
5543 <=>
5544 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
5546 :- chr_constraint static_type_check_var/3.
5547 :- chr_option(mode,static_type_check_var(?,-,?)).
5548 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
5550 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
5551 <=>
5552 functor(AType,F,A),
5553 functor(Type,F,A)
5554 |
5555 copy_term_nat(AType-ADef,Type-Def),
5556 static_type_check_var(Src,Var,Def).
5558 static_type_check_var(Src,Var,Type)
5559 <=>
5560 atomic_builtin_type(Type,_,_)
5561 |
5562 static_atomic_builtin_type_check_var(Src,Var,Type).
5564 static_type_check_var(Src,Var,Type)
5565 <=>
5566 compound_builtin_type(Type,_,_,_)
5567 |
5568 true.
5571 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
5572 <=>
5573 Type1 \== Type2
5574 |
5575 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5577 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5578 %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
5579 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5580 :- chr_constraint static_atomic_builtin_type_check_var/3.
5581 :- chr_option(mode,static_type_check_var(?,-,+)).
5582 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
5584 static_atomic_builtin_type_check_var(_,_,any) <=> true.
5585 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
5586 <=>
5587 true.
5588 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
5589 <=>
5590 true.
5591 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
5592 <=>
5593 true.
5594 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
5595 <=>
5596 true.
5597 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
5598 <=>
5599 true.
5600 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
5601 <=>
5602 true.
5603 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
5604 <=>
5605 true.
5606 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
5607 <=>
5608 true.
5609 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
5610 <=>
5611 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
5613 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5614 %% format_src(+type_error_src) is det.
5615 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5616 format_src(head(Head)) :- format('head ~w',[Head]).
5617 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
5619 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5620 % Dynamic type checking
5621 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5623 :- chr_constraint
5624 dynamic_type_check/0,
5625 dynamic_type_check_clauses/1,
5626 get_dynamic_type_check_clauses/1.
5628 generate_dynamic_type_check_clauses(Clauses) :-
5629 ( chr_pp_flag(debugable,on) ->
5630 dynamic_type_check,
5631 get_dynamic_type_check_clauses(Clauses0),
5632 append(Clauses0,
5633 [('$dynamic_type_check'(Type,Term) :-
5634 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
5635 )],
5636 Clauses)
5637 ;
5638 Clauses = []
5639 ).
5641 type_definition(T,D), dynamic_type_check
5642 ==>
5643 copy_term_nat(T-D,Type-Definition),
5644 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
5645 dynamic_type_check_clauses(DynamicChecks).
5646 type_alias(A,B), dynamic_type_check
5647 ==>
5648 copy_term_nat(A-B,Alias-Body),
5649 dynamic_type_check_alias_clause(Alias,Body,Clause),
5650 dynamic_type_check_clauses([Clause]).
5652 dynamic_type_check <=>
5653 findall(
5654 ('$dynamic_type_check'(Type,Term) :- Goal),
5655 ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ),
5656 BuiltinChecks
5657 ),
5658 dynamic_type_check_clauses(BuiltinChecks).
5660 dynamic_type_check_clause(T,DC,Clause) :-
5661 copy_term(T-DC,Type-DefinitionClause),
5662 functor(DefinitionClause,F,A),
5663 functor(Term,F,A),
5664 DefinitionClause =.. [_|DCArgs],
5665 Term =.. [_|TermArgs],
5666 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
5667 list2conj(RecursiveCallList,RecursiveCalls),
5668 Clause = (
5669 '$dynamic_type_check'(Type,Term) :-
5670 RecursiveCalls
5671 ).
5673 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
5674 Clause = (
5675 '$dynamic_type_check'(Alias,Term) :-
5676 '$dynamic_type_check'(Body,Term)
5677 ).
5679 dynamic_type_check_call(Type,Term,Call) :-
5680 % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
5681 % Call = when(nonvar(Term),Goal)
5682 % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
5683 % Call = when(nonvar(Term),Goal)
5684 % ;
5685 ( Type == any ->
5686 Call = true
5687 ;
5688 Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
5689 )
5690 % )
5691 .
5693 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
5694 <=>
5695 append(C1,C2,C),
5696 dynamic_type_check_clauses(C).
5698 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
5699 <=>
5700 Q = C.
5701 get_dynamic_type_check_clauses(Q)
5702 <=>
5703 Q = [].
5705 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5706 % Atomic Types
5707 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5708 % Some optimizations can be applied for atomic types...
5709 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5711 atomic_types_suspended_constraint(C) :-
5712 C = _/N,
5713 get_constraint_type(C,ArgTypes),
5714 get_constraint_mode(C,ArgModes),
5715 numlist(1,N,Indexes),
5716 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
5718 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
5719 ( is_indexed_argument(C,Index) ->
5720 ( Mode == (?) ->
5721 atomic_type(Type)
5722 ;
5723 true
5724 )
5725 ;
5726 true
5727 ).
5729 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5730 %% atomic_type(+Type) is semidet.
5731 %
5732 % Succeeds when all values of =Type= are atomic.
5733 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5734 :- chr_constraint atomic_type/1.
5736 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
5738 type_definition(TypePat,Def) \ atomic_type(Type)
5739 <=>
5740 functor(Type,F,A), functor(TypePat,F,A)
5741 |
5742 maplist(atomic,Def).
5744 type_alias(TypePat,Alias) \ atomic_type(Type)
5745 <=>
5746 functor(Type,F,A), functor(TypePat,F,A)
5747 |
5748 atomic(Alias),
5749 copy_term_nat(TypePat-Alias,Type-NType),
5750 atomic_type(NType).
5752 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5753 %% enumerated_atomic_type(+Type,-Atoms) is semidet.
5754 %
5755 % Succeeds when all values of =Type= are atomic
5756 % and the atom values are finitely enumerable.
5757 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5758 :- chr_constraint enumerated_atomic_type/2.
5760 enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail.
5762 type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms)
5763 <=>
5764 functor(Type,F,A), functor(TypePat,F,A)
5765 |
5766 maplist(atomic,Def),
5767 Atoms = Def.
5769 type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms)
5770 <=>
5771 functor(Type,F,A), functor(TypePat,F,A)
5772 |
5773 atomic(Alias),
5774 copy_term_nat(TypePat-Alias,Type-NType),
5775 enumerated_atomic_type(NType,Atoms).
5776 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5778 :- chr_constraint
5779 stored/3, % constraint,occurrence,(yes/no/maybe)
5780 stored_completing/3,
5781 stored_complete/3,
5782 is_stored/1,
5783 is_finally_stored/1,
5784 check_all_passive/2.
5786 :- chr_option(mode,stored(+,+,+)).
5787 :- chr_option(type_declaration,stored(any,int,storedinfo)).
5788 :- chr_type storedinfo ---> yes ; no ; maybe.
5789 :- chr_option(mode,stored_complete(+,+,+)).
5790 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
5791 :- chr_option(mode,guard_list(+,+,+,+)).
5792 :- chr_option(mode,check_all_passive(+,+)).
5793 :- chr_option(type_declaration,check_all_passive(any,list)).
5795 % change yes in maybe when yes becomes passive
5796 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
5797 stored(C,O,yes), stored_complete(C,RO,Yesses)
5798 <=> O < RO | NYesses is Yesses - 1,
5799 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5800 % change yes in maybe when not observed
5801 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
5802 <=> O < RO |
5803 NYesses is Yesses - 1,
5804 stored(C,O,maybe), stored_complete(C,RO,NYesses).
5806 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
5807 ==> RO =< MO2 | % C2 is never stored
5808 passive(RuleNb,ID).
5813 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5815 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5816 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
5817 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
5819 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
5820 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
5821 check_all_passive(RuleNb,IDs2).
5823 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
5824 check_all_passive(RuleNb,IDs).
5826 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
5827 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
5829 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5831 % collect the storage information
5832 stored(C,O,yes) \ stored_completing(C,O,Yesses)
5833 <=> NO is O + 1, NYesses is Yesses + 1,
5834 stored_completing(C,NO,NYesses).
5835 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
5836 <=> NO is O + 1,
5837 stored_completing(C,NO,Yesses).
5839 stored(C,O,no) \ stored_completing(C,O,Yesses)
5840 <=> stored_complete(C,O,Yesses).
5841 stored_completing(C,O,Yesses)
5842 <=> stored_complete(C,O,Yesses).
5844 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
5845 O2 > O | passive(RuleNb,Id).
5847 % decide whether a constraint is stored
5848 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
5849 <=> RO =< MO | fail.
5850 is_stored(C) <=> true.
5852 % decide whether a constraint is suspends after occurrences
5853 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
5854 <=> RO =< MO | fail.
5855 is_finally_stored(C) <=> true.
5857 storage_analysis(Constraints) :-
5858 ( chr_pp_flag(storage_analysis,on) ->
5859 check_constraint_storages(Constraints)
5860 ;
5861 true
5862 ).
5864 check_constraint_storages([]).
5865 check_constraint_storages([C|Cs]) :-
5866 check_constraint_storage(C),
5867 check_constraint_storages(Cs).
5869 check_constraint_storage(C) :-
5870 get_max_occurrence(C,MO),
5871 check_occurrences_storage(C,1,MO).
5873 check_occurrences_storage(C,O,MO) :-
5874 ( O > MO ->
5875 stored_completing(C,1,0)
5876 ;
5877 check_occurrence_storage(C,O),
5878 NO is O + 1,
5879 check_occurrences_storage(C,NO,MO)
5880 ).
5882 check_occurrence_storage(C,O) :-
5883 get_occurrence(C,O,RuleNb,ID),
5884 ( is_passive(RuleNb,ID) ->
5885 stored(C,O,maybe)
5886 ;
5887 get_rule(RuleNb,PragmaRule),
5888 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
5889 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5890 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
5891 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5892 check_storage_head2(Head2,O,Heads1,Body)
5893 )
5894 ).
5896 check_storage_head1(Head,O,H1,H2,G) :-
5897 functor(Head,F,A),
5898 C = F/A,
5899 ( H1 == [Head],
5900 H2 == [],
5901 % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl,
5902 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
5903 Head =.. [_|L],
5904 no_matching(L,[]) ->
5905 stored(C,O,no)
5906 ;
5907 stored(C,O,maybe)
5908 ).
5910 no_matching([],_).
5911 no_matching([X|Xs],Prev) :-
5912 var(X),
5913 \+ memberchk_eq(X,Prev),
5914 no_matching(Xs,[X|Prev]).
5916 check_storage_head2(Head,O,H1,B) :-
5917 functor(Head,F,A),
5918 C = F/A,
5919 ( %(
5920 ( H1 \== [], B == true )
5921 %;
5922 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
5923 %)
5924 ->
5925 stored(C,O,maybe)
5926 ;
5927 stored(C,O,yes)
5928 ).
5930 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5932 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5933 %% ____ _ ____ _ _ _ _
5934 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
5935 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5936 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5937 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5938 %% |_|
5940 constraints_code(Constraints,Clauses) :-
5941 (chr_pp_flag(reduced_indexing,on),
5942 forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) ->
5943 none_suspended_on_variables
5944 ;
5945 true
5946 ),
5947 constraints_code1(Constraints,Clauses,[]).
5949 %===============================================================================
5950 :- chr_constraint constraints_code1/3.
5951 :- chr_option(mode,constraints_code1(+,+,+)).
5952 :- chr_option(type_declaration,constraints_code1(list,any,any)).
5953 %-------------------------------------------------------------------------------
5954 constraints_code1([],L,T) <=> L = T.
5955 constraints_code1([C|RCs],L,T)
5956 <=>
5957 constraint_code(C,L,T1),
5958 constraints_code1(RCs,T1,T).
5959 %===============================================================================
5960 :- chr_constraint constraint_code/3.
5961 :- chr_option(mode,constraint_code(+,+,+)).
5962 %-------------------------------------------------------------------------------
5963 %% Generate code for a single CHR constraint
5964 constraint_code(Constraint, L, T)
5965 <=> true
5966 | ( (chr_pp_flag(debugable,on) ;
5967 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5968 ( may_trigger(Constraint) ;
5969 get_allocation_occurrence(Constraint,AO),
5970 get_max_occurrence(Constraint,MO), MO >= AO ) )
5971 ->
5972 constraint_prelude(Constraint,Clause),
5973 add_dummy_location(Clause,LocatedClause),
5974 L = [LocatedClause | L1]
5975 ;
5976 L = L1
5977 ),
5978 Id = [0],
5979 occurrences_code(Constraint,1,Id,NId,L1,L2),
5980 gen_cond_attach_clause(Constraint,NId,L2,T).
5982 %===============================================================================
5983 %% Generate prelude predicate for a constraint.
5984 %% f(...) :- f/a_0(...,Susp).
5985 constraint_prelude(F/A, Clause) :-
5986 vars_susp(A,Vars,Susp,VarsSusp),
5987 Head =.. [ F | Vars],
5988 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5989 build_head(F,A,[0],VarsSusp,Delegate),
5990 ( chr_pp_flag(debugable,on) ->
5991 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5992 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5993 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5994 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5996 ( get_constraint_type(F/A,ArgTypeList) ->
5997 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5998 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5999 ;
6000 DynamicTypeChecks = true
6001 ),
6003 Clause =
6004 ( Head :-
6005 DynamicTypeChecks,
6006 InsertGoal,
6007 InsertCall,
6008 AttachCall,
6009 Inactive,
6010 'chr debug_event'(insert(Head#Susp)),
6011 (
6012 'chr debug_event'(call(Susp)),
6013 Delegate
6014 ;
6015 'chr debug_event'(fail(Susp)), !,
6016 fail
6017 ),
6018 (
6019 'chr debug_event'(exit(Susp))
6020 ;
6021 'chr debug_event'(redo(Susp)),
6022 fail
6023 )
6024 )
6025 ; get_allocation_occurrence(F/A,0) ->
6026 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
6027 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
6028 Clause = ( Head :- Goal, Inactive, Delegate )
6029 ;
6030 Clause = ( Head :- Delegate )
6031 ).
6033 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
6034 ( may_trigger(F/A) ->
6035 build_head(F,A,[0],VarsSusp,Delegate),
6036 ( chr_pp_flag(debugable,off) ->
6037 Goal = Delegate
6038 ;
6039 get_target_module(Mod),
6040 Goal = Mod:Delegate
6041 )
6042 ;
6043 Goal = true
6044 ).
6046 %===============================================================================
6047 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
6048 :- chr_option(mode,has_active_occurrence(+)).
6049 :- chr_option(mode,has_active_occurrence(+,+)).
6051 :- chr_constraint memo_has_active_occurrence/1.
6052 :- chr_option(mode,memo_has_active_occurrence(+)).
6053 %-------------------------------------------------------------------------------
6054 memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true.
6055 has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C).
6057 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
6058 O > MO | fail.
6059 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
6060 has_active_occurrence(C,O) <=>
6061 NO is O + 1,
6062 has_active_occurrence(C,NO).
6063 has_active_occurrence(C,O) <=> true.
6064 %===============================================================================
6066 gen_cond_attach_clause(F/A,Id,L,T) :-
6067 ( is_finally_stored(F/A) ->
6068 get_allocation_occurrence(F/A,AllocationOccurrence),
6069 get_max_occurrence(F/A,MaxOccurrence),
6070 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
6071 ( only_ground_indexed_arguments(F/A) ->
6072 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
6073 ;
6074 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
6075 )
6076 ; vars_susp(A,Args,Susp,AllArgs),
6077 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
6078 ),
6079 build_head(F,A,Id,AllArgs,Head),
6080 Clause = ( Head :- Body ),
6081 add_dummy_location(Clause,LocatedClause),
6082 L = [LocatedClause | T]
6083 ;
6084 L = T
6085 ).
6087 :- chr_constraint use_auxiliary_predicate/1.
6088 :- chr_option(mode,use_auxiliary_predicate(+)).
6090 :- chr_constraint use_auxiliary_predicate/2.
6091 :- chr_option(mode,use_auxiliary_predicate(+,+)).
6093 :- chr_constraint is_used_auxiliary_predicate/1.
6094 :- chr_option(mode,is_used_auxiliary_predicate(+)).
6096 :- chr_constraint is_used_auxiliary_predicate/2.
6097 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
6100 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
6102 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
6104 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
6106 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
6108 is_used_auxiliary_predicate(P) <=> fail.
6110 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
6111 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
6113 is_used_auxiliary_predicate(P,C) <=> fail.
6115 %------------------------------------------------------------------------------%
6116 % Only generate import statements for actually used modules.
6117 %------------------------------------------------------------------------------%
6119 :- chr_constraint use_auxiliary_module/1.
6120 :- chr_option(mode,use_auxiliary_module(+)).
6122 :- chr_constraint is_used_auxiliary_module/1.
6123 :- chr_option(mode,is_used_auxiliary_module(+)).
6126 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
6128 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
6130 is_used_auxiliary_module(P) <=> fail.
6132 % only called for constraints with
6133 % at least one
6134 % non-ground indexed argument
6135 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
6136 vars_susp(A,Args,Susp,AllArgs),
6137 make_suspension_continuation_goal(F/A,AllArgs,Closure),
6138 ( get_store_type(F/A,var_assoc_store(_,_)) ->
6139 Attach = true
6140 ;
6141 attach_constraint_atom(F/A,Vars,Susp,Attach)
6142 ),
6143 FTerm =.. [F|Args],
6144 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6145 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
6146 ( may_trigger(F/A) ->
6147 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
6148 Goal =
6149 (
6150 ( var(Susp) ->
6151 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
6152 InsertCall,
6153 Attach
6154 ;
6155 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
6156 )
6157 )
6158 ;
6159 Goal =
6160 (
6161 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
6162 InsertCall,
6163 Attach
6164 )
6165 ).
6167 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
6168 vars_susp(A,Args,Susp,AllArgs),
6169 make_suspension_continuation_goal(F/A,AllArgs,Cont),
6170 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
6171 attach_constraint_atom(F/A,Vars,Susp,Attach)
6172 ;
6173 Attach = true
6174 ),
6175 FTerm =.. [F|Args],
6176 insert_constraint_goal(F/A,Susp,Args,InsertCall),
6177 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
6178 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
6179 Goal =
6180 (
6181 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
6182 InsertCall
6183 )
6184 ;
6185 Goal =
6186 (
6187 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
6188 InsertCall,
6189 Attach
6190 )
6191 ).
6193 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
6194 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
6195 attach_constraint_atom(FA,Vars,Susp,Attach)
6196 ;
6197 Attach = true
6198 ),
6199 insert_constraint_goal(FA,Susp,Args,InsertCall),
6200 ( chr_pp_flag(late_allocation,on) ->
6201 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
6202 ;
6203 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
6204 ).
6206 %-------------------------------------------------------------------------------
6207 :- chr_constraint occurrences_code/6.
6208 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
6209 %-------------------------------------------------------------------------------
6210 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
6211 <=> O > MO
6212 | NId = Id, L = T.
6213 occurrences_code(C,O,Id,NId,L,T)
6214 <=>
6215 occurrence_code(C,O,Id,Id1,L,L1),
6216 NO is O + 1,
6217 occurrences_code(C,NO,Id1,NId,L1,T).
6218 %-------------------------------------------------------------------------------
6219 :- chr_constraint occurrence_code/6.
6220 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
6221 %-------------------------------------------------------------------------------
6222 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
6223 <=>
6224 ( named_history(RuleNb,_,_) ->
6225 does_use_history(C,O)
6226 ;
6227 true
6228 ),
6229 NId = Id,
6230 L = T.
6231 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
6232 <=> true |
6233 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
6234 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
6235 NId = Id,
6236 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
6237 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
6239 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
6240 ( should_skip_to_next_id(C,O) ->
6241 inc_id(Id,NId),
6242 ( unconditional_occurrence(C,O) ->
6243 L1 = T
6244 ;
6245 gen_alloc_inc_clause(C,O,Id,L1,T)
6246 )
6247 ;
6248 NId = Id,
6249 L1 = T
6250 )
6251 ).
6253 occurrence_code(C,O,_,_,_,_)
6254 <=>
6255 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
6256 %-------------------------------------------------------------------------------
6258 %% Generate code based on one removed head of a CHR rule
6259 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6260 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6261 Rule = rule(_,Head2,_,_),
6262 ( Head2 == [] ->
6263 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6264 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
6265 ;
6266 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6267 ).
6269 %% Generate code based on one persistent head of a CHR rule
6270 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
6271 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
6272 Rule = rule(Head1,_,_,_),
6273 ( Head1 == [] ->
6274 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
6275 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
6276 ;
6277 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
6278 ).
6280 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
6281 vars_susp(A,Vars,Susp,VarsSusp),
6282 build_head(F,A,Id,VarsSusp,Head),
6283 inc_id(Id,IncId),
6284 build_head(F,A,IncId,VarsSusp,CallHead),
6285 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
6286 Clause =
6287 (
6288 Head :-
6289 ConditionalAlloc,
6290 CallHead
6291 ),
6292 add_dummy_location(Clause,LocatedClause),
6293 L = [LocatedClause|T].
6295 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
6296 get_allocation_occurrence(FA,AO),
6297 get_occurrence_code_id(FA,AO,AId),
6298 get_occurrence_code_id(FA,O,Id),
6299 ( chr_pp_flag(debugable,off), Id == AId ->
6300 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6301 ( may_trigger(FA) ->
6302 Goal = (var(Susp) -> Goal0 ; true)
6303 ;
6304 Goal = Goal0
6305 )
6306 ;
6307 Goal = true
6308 ).
6310 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
6311 get_allocation_occurrence(FA,AO),
6312 ( chr_pp_flag(debugable,off), O < AO ->
6313 allocate_constraint_goal(FA,Susp,Vars,Goal0),
6314 ( may_trigger(FA) ->
6315 Goal = (var(Susp) -> Goal0 ; true)
6316 ;
6317 Goal = Goal0
6318 )
6319 ;
6320 Goal = true
6321 ).
6323 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6325 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6326 %
6327 % Reorders guard goals with respect to partner constraint retrieval goals and
6328 % active constraint. Returns combined partner retrieval + guard goal.
6330 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
6331 ( chr_pp_flag(guard_via_reschedule,on) ->
6332 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6333 list2conj(ScheduleSkeleton,GoalSkeleton)
6334 ;
6335 length(Retrievals,RL), length(LookupSkeleton,RL),
6336 length(GuardList,GL), length(GuardListSkeleton,GL),
6337 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
6338 list2conj(GoalListSkeleton,GoalSkeleton)
6339 ).
6340 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
6341 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
6342 initialize_unit_dictionary(ActiveHead,Dict),
6343 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
6344 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
6345 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
6346 dependency_reorder(Units,NUnits),
6347 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
6348 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
6349 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
6351 wrappedunits2lists([],[],[],[]).
6352 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
6353 Ss = [GoalCopy|TSs],
6354 ( WrappedGoal = lookup(Goal) ->
6355 Ls = [GoalCopy|TLs],
6356 Gs = TGs
6357 ; WrappedGoal = guard(Goal) ->
6358 Gs = [N-GoalCopy|TGs],
6359 Ls = TLs
6360 ),
6361 wrappedunits2lists(Units,TGs,TLs,TSs).
6363 guard_splitting(Rule,SplitGuardList) :-
6364 Rule = rule(H1,H2,Guard,_),
6365 append(H1,H2,Heads),
6366 conj2list(Guard,GuardList),
6367 term_variables(Heads,HeadVars),
6368 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
6369 append(GuardPrefix,[RestGuard],SplitGuardList),
6370 term_variables(RestGuardList,GuardVars1),
6371 % variables that are declared to be ground don't need to be locked
6372 ground_vars(Heads,GroundVars),
6373 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
6374 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
6375 ( chr_pp_flag(guard_locks,on),
6376 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
6377 once(pairup(Locks,Unlocks,LocksUnlocks))
6378 ;
6379 Locks = [],
6380 Unlocks = []
6381 ),
6382 list2conj(Locks,LockPhase),
6383 list2conj(Unlocks,UnlockPhase),
6384 list2conj(RestGuardList,RestGuard1),
6385 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
6387 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
6388 Rule = rule(_,_,_,Body),
6389 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
6390 my_term_copy(Body,VarDict2,BodyCopy).
6393 split_off_simple_guard_new([],_,[],[]).
6394 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
6395 ( simple_guard_new(G,VarDict) ->
6396 S = [G|Ss],
6397 split_off_simple_guard_new(Gs,VarDict,Ss,C)
6398 ;
6399 S = [],
6400 C = [G|Gs]
6401 ).
6403 % simple guard: cheap and benign (does not bind variables)
6404 simple_guard_new(G,Vars) :-
6405 builtin_binds_b(G,BoundVars),
6406 \+ (( member(V,BoundVars),
6407 memberchk_eq(V,Vars)
6408 )).
6410 dependency_reorder(Units,NUnits) :-
6411 dependency_reorder(Units,[],NUnits).
6413 dependency_reorder([],Acc,Result) :-
6414 reverse(Acc,Result).
6416 dependency_reorder([Unit|Units],Acc,Result) :-
6417 Unit = unit(_GID,_Goal,Type,GIDs),
6418 ( Type == fixed ->
6419 NAcc = [Unit|Acc]
6420 ;
6421 dependency_insert(Acc,Unit,GIDs,NAcc)
6422 ),
6423 dependency_reorder(Units,NAcc,Result).
6425 dependency_insert([],Unit,_,[Unit]).
6426 dependency_insert([X|Xs],Unit,GIDs,L) :-
6427 X = unit(GID,_,_,_),
6428 ( memberchk(GID,GIDs) ->
6429 L = [Unit,X|Xs]
6430 ;
6431 L = [X | T],
6432 dependency_insert(Xs,Unit,GIDs,T)
6433 ).
6435 build_units(Retrievals,Guard,InitialDict,Units) :-
6436 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
6437 build_guard_units(Guard,N,Dict,Tail).
6439 build_retrieval_units([],N,N,Dict,Dict,L,L).
6440 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
6441 term_variables(U,Vs),
6442 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
6443 L = [unit(N,U,fixed,GIDs)|L1],
6444 N1 is N + 1,
6445 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
6447 initialize_unit_dictionary(Term,Dict) :-
6448 term_variables(Term,Vars),
6449 pair_all_with(Vars,0,Dict).
6451 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
6452 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6453 ( lookup_eq(Dict,V,GID) ->
6454 ( (GID == This ; memberchk(GID,GIDs) ) ->
6455 GIDs1 = GIDs
6456 ;
6457 GIDs1 = [GID|GIDs]
6458 ),
6459 Dict1 = Dict
6460 ;
6461 Dict1 = [V - This|Dict],
6462 GIDs1 = GIDs
6463 ),
6464 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6466 build_guard_units(Guard,N,Dict,Units) :-
6467 ( Guard = [Goal] ->
6468 Units = [unit(N,Goal,fixed,[])]
6469 ; Guard = [Goal|Goals] ->
6470 term_variables(Goal,Vs),
6471 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
6472 Units = [unit(N,Goal,movable,GIDs)|RUnits],
6473 N1 is N + 1,
6474 build_guard_units(Goals,N1,NDict,RUnits)
6475 ).
6477 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
6478 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
6479 ( lookup_eq(Dict,V,GID) ->
6480 ( (GID == This ; memberchk(GID,GIDs) ) ->
6481 GIDs1 = GIDs
6482 ;
6483 GIDs1 = [GID|GIDs]
6484 ),
6485 Dict1 = [V - This|Dict]
6486 ;
6487 Dict1 = [V - This|Dict],
6488 GIDs1 = GIDs
6489 ),
6490 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
6492 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6494 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6495 %% ____ _ ____ _ _
6496 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
6497 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
6498 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
6499 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
6500 %%
6501 %% _ _ _ ___ __
6502 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
6503 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
6504 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
6505 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
6506 %% |_|
6507 :- chr_constraint
6508 functional_dependency/4,
6509 get_functional_dependency/4.
6511 :- chr_option(mode,functional_dependency(+,+,?,?)).
6512 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
6514 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
6515 <=>
6516 RuleNb > 1, AO > O
6517 |
6518 functional_dependency(C,1,Pattern,Key).
6520 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
6521 <=>
6522 RuleNb2 >= RuleNb1
6523 |
6524 QPattern = Pattern, QKey = Key.
6525 get_functional_dependency(_,_,_,_)
6526 <=>
6527 fail.
6529 functional_dependency_analysis(Rules) :-
6530 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
6531 functional_dependency_analysis_main(Rules)
6532 ;
6533 true
6534 ).
6536 functional_dependency_analysis_main([]).
6537 functional_dependency_analysis_main([PRule|PRules]) :-
6538 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
6539 functional_dependency(C,RuleNb,Pattern,Key)
6540 ;
6541 true
6542 ),
6543 functional_dependency_analysis_main(PRules).
6545 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
6546 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
6547 Rule = rule(H1,H2,Guard,_),
6548 ( H1 = [C1],
6549 H2 = [C2] ->
6550 true
6551 ; H1 = [C1,C2],
6552 H2 == [] ->
6553 true
6554 ),
6555 check_unique_constraints(C1,C2,Guard,RuleNb,List),
6556 term_variables(C1,Vs),
6557 \+ (
6558 member(V1,Vs),
6559 lookup_eq(List,V1,V2),
6560 memberchk_eq(V2,Vs)
6561 ),
6562 select_pragma_unique_variables(Vs,List,Key1),
6563 copy_term_nat(C1-Key1,Pattern-Key),
6564 functor(C1,F,A).
6566 select_pragma_unique_variables([],_,[]).
6567 select_pragma_unique_variables([V|Vs],List,L) :-
6568 ( lookup_eq(List,V,_) ->
6569 L = T
6570 ;
6571 L = [V|T]
6572 ),
6573 select_pragma_unique_variables(Vs,List,T).
6575 % depends on functional dependency analysis
6576 % and shape of rule: C1 \ C2 <=> true.
6577 set_semantics_rules(Rules) :-
6578 ( fail, chr_pp_flag(set_semantics_rule,on) ->
6579 set_semantics_rules_main(Rules)
6580 ;
6581 true
6582 ).
6584 set_semantics_rules_main([]).
6585 set_semantics_rules_main([R|Rs]) :-
6586 set_semantics_rule_main(R),
6587 set_semantics_rules_main(Rs).
6589 set_semantics_rule_main(PragmaRule) :-
6590 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
6591 ( Rule = rule([C1],[C2],true,_),
6592 IDs = ids([ID1],[ID2]),
6593 \+ is_passive(RuleNb,ID1),
6594 functor(C1,F,A),
6595 get_functional_dependency(F/A,RuleNb,Pattern,Key),
6596 copy_term_nat(Pattern-Key,C1-Key1),
6597 copy_term_nat(Pattern-Key,C2-Key2),
6598 Key1 == Key2 ->
6599 passive(RuleNb,ID2)
6600 ;
6601 true
6602 ).
6604 check_unique_constraints(C1,C2,G,RuleNb,List) :-
6605 \+ any_passive_head(RuleNb),
6606 variable_replacement(C1-C2,C2-C1,List),
6607 copy_with_variable_replacement(G,OtherG,List),
6608 negate_b(G,NotG),
6609 once(entails_b(NotG,OtherG)).
6611 % checks for rules of the shape ...,C1,C2... (<|=)=> ...
6612 % where C1 and C2 are symmteric constraints
6613 symmetry_analysis(Rules) :-
6614 ( chr_pp_flag(check_unnecessary_active,off) ->
6615 true
6616 ;
6617 symmetry_analysis_main(Rules)
6618 ).
6620 symmetry_analysis_main([]).
6621 symmetry_analysis_main([R|Rs]) :-
6622 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
6623 Rule = rule(H1,H2,_,_),
6624 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
6625 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
6626 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
6627 ;
6628 true
6629 ),
6630 symmetry_analysis_main(Rs).
6632 symmetry_analysis_heads_simplification([],[],_,_,_,_).
6633 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6634 ( \+ is_passive(RuleNb,ID),
6635 member2(PreHs,PreIDs,PreH-PreID),
6636 \+ is_passive(RuleNb,PreID),
6637 variable_replacement(PreH,H,List),
6638 copy_with_variable_replacement(Rule,Rule2,List),
6639 identical_guarded_rules(Rule,Rule2) ->
6640 passive(RuleNb,ID)
6641 ;
6642 true
6643 ),
6644 symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6646 symmetry_analysis_heads_propagation([],[],_,_,_,_).
6647 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
6648 ( \+ is_passive(RuleNb,ID),
6649 member2(PreHs,PreIDs,PreH-PreID),
6650 \+ is_passive(RuleNb,PreID),
6651 variable_replacement(PreH,H,List),
6652 copy_with_variable_replacement(Rule,Rule2,List),
6653 identical_rules(Rule,Rule2) ->
6654 passive(RuleNb,ID)
6655 ;
6656 true
6657 ),
6658 symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
6660 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6662 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6663 %% ____ _ _ _ __ _ _ _
6664 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
6665 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
6666 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
6667 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
6668 %% |_|
6669 %% {{{
6671 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
6672 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
6673 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6674 build_head(F,A,Id,HeadVars,ClauseHead),
6675 get_constraint_mode(F/A,Mode),
6676 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6679 guard_splitting(Rule,GuardList0),
6680 ( is_stored_in_guard(F/A, RuleNb) ->
6681 GuardList = [Hole1|GuardList0]
6682 ;
6683 GuardList = GuardList0
6684 ),
6685 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6687 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6689 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6691 ( is_stored_in_guard(F/A, RuleNb) ->
6692 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6693 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6694 GuardCopyList = [Hole1Copy|_],
6695 Hole1Copy = (Allocation, Attachment)
6696 ;
6697 true
6698 ),
6701 partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
6702 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6704 ( chr_pp_flag(debugable,on) ->
6705 Rule = rule(_,_,Guard,Body),
6706 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6707 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
6708 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
6709 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
6710 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6711 ;
6712 Cut = ActualCut
6713 ),
6714 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
6715 Clause = ( ClauseHead :-
6716 FirstMatching,
6717 RescheduledTest,
6718 Cut,
6719 SuspsDetachments,
6720 SuspDetachment,
6721 BodyCopy
6722 ),
6723 add_location(Clause,RuleNb,LocatedClause),
6724 L = [LocatedClause | T].
6726 % }}}
6728 add_location(Clause,RuleNb,NClause) :-
6729 ( chr_pp_flag(line_numbers,on) ->
6730 get_chr_source_file(File),
6731 get_line_number(RuleNb,LineNb),
6732 NClause = '$source_location'(File,LineNb):Clause
6733 ;
6734 NClause = Clause
6735 ).
6737 add_dummy_location(Clause,NClause) :-
6738 ( chr_pp_flag(line_numbers,on) ->
6739 get_chr_source_file(File),
6740 NClause = '$source_location'(File,1):Clause
6741 ;
6742 NClause = Clause
6743 ).
6744 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6745 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
6746 %
6747 % Return goal matching newly introduced variables with variables in
6748 % previously looked-up heads.
6749 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6750 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
6751 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
6753 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6754 %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
6755 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6756 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
6757 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
6758 list2conj(GoalList,Goal).
6760 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
6761 head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !,
6762 ( Mode == (+) ->
6763 term_variables(Arg,GroundVars0,GroundVars),
6764 head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars)
6765 ;
6766 head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars)
6767 ).
6768 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
6769 ( var(Arg) ->
6770 ( lookup_eq(VarDict,Arg,OtherVar) ->
6771 ( Mode = (+) ->
6772 ( memberchk_eq(Arg,GroundVars) ->
6773 GoalList = [Var = OtherVar | RestGoalList],
6774 GroundVars1 = GroundVars
6775 ;
6776 GoalList = [Var == OtherVar | RestGoalList],
6777 GroundVars1 = [Arg|GroundVars]
6778 )
6779 ;
6780 GoalList = [Var == OtherVar | RestGoalList],
6781 GroundVars1 = GroundVars
6782 ),
6783 VarDict1 = VarDict
6784 ;
6785 VarDict1 = [Arg-Var | VarDict],
6786 GoalList = RestGoalList,
6787 ( Mode = (+) ->
6788 GroundVars1 = [Arg|GroundVars]
6789 ;
6790 GroundVars1 = GroundVars
6791 )
6792 ),
6793 Pairs = Rest,
6794 RestModes = Modes
6795 ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
6796 identifier_label_atom(IndexType,Var,ActualArg,Goal),
6797 GoalList = [Goal|RestGoalList],
6798 VarDict = VarDict1,
6799 GroundVars1 = GroundVars,
6800 Pairs = Rest,
6801 RestModes = Modes
6802 ; atomic(Arg) ->
6803 ( Mode = (+) ->
6804 GoalList = [ Var = Arg | RestGoalList]
6805 ;
6806 GoalList = [ Var == Arg | RestGoalList]
6807 ),
6808 VarDict = VarDict1,
6809 GroundVars1 = GroundVars,
6810 Pairs = Rest,
6811 RestModes = Modes
6812 ; Mode == (+), is_ground(GroundVars,Arg) ->
6813 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6814 GoalList = [ Var = ArgCopy | RestGoalList],
6815 VarDict = VarDict1,
6816 GroundVars1 = GroundVars,
6817 Pairs = Rest,
6818 RestModes = Modes
6819 ; Mode == (?), is_ground(GroundVars,Arg) ->
6820 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
6821 GoalList = [ Var == ArgCopy | RestGoalList],
6822 VarDict = VarDict1,
6823 GroundVars1 = GroundVars,
6824 Pairs = Rest,
6825 RestModes = Modes
6826 ; Arg =.. [_|Args],
6827 functor(Arg,Fct,N),
6828 functor(Term,Fct,N),
6829 Term =.. [_|Vars],
6830 ( Mode = (+) ->
6831 GoalList = [ Var = Term | RestGoalList ]
6832 ;
6833 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
6834 ),
6835 pairup(Args,Vars,NewPairs),
6836 append(NewPairs,Rest,Pairs),
6837 replicate(N,Mode,NewModes),
6838 append(NewModes,Modes,RestModes),
6839 VarDict1 = VarDict,
6840 GroundVars1 = GroundVars
6841 ),
6842 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
6844 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6845 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
6846 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6847 add_heads_types([],VarTypes,VarTypes).
6848 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
6849 add_head_types(Head,VarTypes,VarTypes1),
6850 add_heads_types(Heads,VarTypes1,NVarTypes).
6852 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6853 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
6854 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6855 add_head_types(Head,VarTypes,NVarTypes) :-
6856 functor(Head,F,A),
6857 get_constraint_type_det(F/A,ArgTypes),
6858 Head =.. [_|Args],
6859 add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
6861 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6862 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
6863 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6864 add_args_types([],[],VarTypes,VarTypes).
6865 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
6866 add_arg_types(Arg,Type,VarTypes,VarTypes1),
6867 add_args_types(Args,Types,VarTypes1,NVarTypes).
6869 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6870 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
6871 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6872 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
6873 ( var(Term) ->
6874 ( lookup_eq(VarTypes,Term,_) ->
6875 NVarTypes = VarTypes
6876 ;
6877 NVarTypes = [Term-Type|VarTypes]
6878 )
6879 ; ground(Term) ->
6880 NVarTypes = VarTypes
6881 ; % TODO improve approximation!
6882 term_variables(Term,Vars),
6883 length(Vars,VarNb),
6884 replicate(VarNb,any,Types),
6885 add_args_types(Vars,Types,VarTypes,NVarTypes)
6886 ).
6890 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6891 %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
6892 %
6893 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6894 add_heads_ground_variables([],GroundVars,GroundVars).
6895 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
6896 add_head_ground_variables(Head,GroundVars,GroundVars1),
6897 add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
6899 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6900 %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
6901 %
6902 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6903 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
6904 functor(Head,F,A),
6905 get_constraint_mode(F/A,ArgModes),
6906 Head =.. [_|Args],
6907 add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
6910 add_arg_ground_variables([],[],GroundVars,GroundVars).
6911 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
6912 ( Mode == (+) ->
6913 term_variables(Arg,Vars),
6914 add_var_ground_variables(Vars,GroundVars,GroundVars1)
6915 ;
6916 GroundVars = GroundVars1
6917 ),
6918 add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
6920 add_var_ground_variables([],GroundVars,GroundVars).
6921 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
6922 ( memberchk_eq(Var,GroundVars) ->
6923 GroundVars1 = GroundVars
6924 ;
6925 GroundVars1 = [Var|GroundVars]
6926 ),
6927 add_var_ground_variables(Vars,GroundVars1,NGroundVars).
6928 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6929 %% is_ground(+GroundVars,+Term) is semidet.
6930 %
6931 % Determine whether =Term= is always ground.
6932 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
6933 is_ground(GroundVars,Term) :-
6934 ( ground(Term) ->
6935 true
6936 ; compound(Term) ->
6937 Term =.. [_|Args],
6938 maplist(is_ground(GroundVars),Args)
6939 ;
6940 memberchk_eq(Term,GroundVars)
6941 ).
6943 %% check_ground(+GroundVars,+Term,-Goal) is det.
6944 %
6945 % Return runtime check to see whether =Term= is ground.
6946 check_ground(GroundVars,Term,Goal) :-
6947 term_variables(Term,Variables),
6948 check_ground_variables(Variables,GroundVars,Goal).
6950 check_ground_variables([],_,true).
6951 check_ground_variables([Var|Vars],GroundVars,Goal) :-
6952 ( memberchk_eq(Var,GroundVars) ->
6953 check_ground_variables(Vars,GroundVars,Goal)
6954 ;
6955 Goal = (ground(Var), RGoal),
6956 check_ground_variables(Vars,GroundVars,RGoal)
6957 ).
6959 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
6960 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
6962 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
6963 ( Heads = [_|_] ->
6964 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
6965 ;
6966 GoalList = [],
6967 Susps = [],
6968 VarDict = NVarDict,
6969 GroundVars = NGroundVars
6970 ).
6972 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6973 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6974 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6975 functor(H,F,A),
6976 head_info(H,A,Vars,_,_,Pairs),
6977 get_store_type(F/A,StoreType),
6978 ( StoreType == default ->
6979 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6980 delay_phase_end(validate_store_type_assumptions,
6981 ( static_suspension_term(F/A,Suspension),
6982 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6983 get_static_suspension_field(F/A,Suspension,state,active,GetState)
6984 )
6985 ),
6986 % create_get_mutable_ref(active,State,GetMutable),
6987 get_constraint_mode(F/A,Mode),
6988 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6989 NPairs = Pairs,
6990 sbag_member_call(Susp,VarSusps,Sbag),
6991 ExistentialLookup = (
6992 ViaGoal,
6993 Sbag,
6994 Susp = Suspension, % not inlined
6995 GetState
6996 )
6997 ;
6998 delay_phase_end(validate_store_type_assumptions,
6999 ( static_suspension_term(F/A,Suspension),
7000 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
7001 )
7002 ),
7003 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
7004 get_constraint_mode(F/A,Mode),
7005 NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode),
7006 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
7007 ),
7008 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
7009 filter_append(NPairs,VarDict1,DA_), % order important here
7010 translate(GroundVars1,DA_,GroundVarsA),
7011 translate(GroundVars1,VarDict1,GroundVarsB),
7012 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
7013 Goal =
7014 (
7015 ExistentialLookup,
7016 DiffSuspGoals,
7017 MatchingGoal2
7018 ),
7019 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
7021 inline_matching_goal(A==B,true,GVA,GVB) :-
7022 memberchk_eq(A,GVA),
7023 memberchk_eq(B,GVB),
7024 A=B, !.
7026 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
7027 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
7028 inline_matching_goal(A,A2,GVA,GVB),
7029 inline_matching_goal(B,B2,GVA,GVB).
7030 inline_matching_goal(X,X,_,_).
7033 filter_mode([],_,_,[]).
7034 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
7035 ( Var == V ->
7036 Modes = [M|MT],
7037 filter_mode(Rest,R,Ms,MT)
7038 ;
7039 filter_mode([Arg-Var|Rest],R,Ms,Modes)
7040 ).
7042 filter_append([],VarDict,VarDict).
7043 filter_append([X|Xs],VarDict,NVarDict) :-
7044 ( X = silent(_) ->
7045 filter_append(Xs,VarDict,NVarDict)
7046 ;
7047 NVarDict = [X|NVarDict0],
7048 filter_append(Xs,VarDict,NVarDict0)
7049 ).
7051 check_unique_keys([],_).
7052 check_unique_keys([V|Vs],Dict) :-
7053 lookup_eq(Dict,V,_),
7054 check_unique_keys(Vs,Dict).
7056 % Generates tests to ensure the found constraint differs from previously found constraints
7057 % TODO: detect more cases where constraints need be different
7058 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
7059 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
7060 list2conj(DiffSuspGoalList,DiffSuspGoals).
7062 different_from_other_susps_(_,[],_,_,[]) :- !.
7063 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
7064 ( functor(Head,F,A), functor(PreHead,F,A),
7065 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
7066 \+ \+ PreHeadCopy = HeadCopy ->
7068 List = [Susp \== PreSusp | Tail]
7069 ;
7070 List = Tail
7071 ),
7072 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
7074 % passive_head_via(in,in,in,in,out,out,out) :-
7075 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
7076 functor(Head,F,A),
7077 get_constraint_index(F/A,Pos),
7078 /* which static variables may contain runtime variables */
7079 common_variables(Head,PrevHeads,CommonVars0),
7080 ground_vars([Head],GroundVars),
7081 list_difference_eq(CommonVars0,GroundVars,CommonVars),
7082 /********************************************************/
7083 global_list_store_name(F/A,Name),
7084 GlobalGoal = nb_getval(Name,AllSusps),
7085 get_constraint_mode(F/A,ArgModes),
7086 ( Vars == [] ->
7087 Goal = GlobalGoal
7088 ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
7089 translate([CommonVar],VarDict,[Var]),
7090 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
7091 Goal = AttrGoal
7092 ;
7093 translate(CommonVars,VarDict,Vars),
7094 add_heads_types(PrevHeads,[],TypeDict),
7095 my_term_copy(TypeDict,VarDict,TypeDictCopy),
7096 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
7097 Goal =
7098 ( ViaGoal ->
7099 AttrGoal
7100 ;
7101 GlobalGoal
7102 )
7103 ).
7105 common_variables(T,Ts,Vs) :-
7106 term_variables(T,V1),
7107 term_variables(Ts,V2),
7108 intersect_eq(V1,V2,Vs).
7110 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
7111 via_goal(Vars,TypeDict,ViaGoal,Var),
7112 get_target_module(Mod),
7113 AttrGoal =
7114 ( get_attr(Var,Mod,TSusps),
7115 TSuspsEqSusps % TSusps = Susps
7116 ),
7117 get_max_constraint_index(N),
7118 ( N == 1 ->
7119 TSuspsEqSusps = true, % TSusps = Susps
7120 AllSusps = TSusps
7121 ;
7122 get_constraint_index(FA,Pos),
7123 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7124 ).
7125 via_goal(Vars,TypeDict,ViaGoal,Var) :-
7126 ( Vars = [] ->
7127 ViaGoal = fail
7128 ; Vars = [A] ->
7129 lookup_eq(TypeDict,A,Type),
7130 ( atomic_type(Type) ->
7131 ViaGoal = var(A),
7132 A = Var
7133 ;
7134 ViaGoal = 'chr newvia_1'(A,Var)
7135 )
7136 ; Vars = [A,B] ->
7137 ViaGoal = 'chr newvia_2'(A,B,Var)
7138 ;
7139 ViaGoal = 'chr newvia'(Vars,Var)
7140 ).
7141 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
7142 get_target_module(Mod),
7143 AttrGoal =
7144 ( get_attr(Var,Mod,TSusps),
7145 TSuspsEqSusps % TSusps = Susps
7146 ),
7147 get_max_constraint_index(N),
7148 ( N == 1 ->
7149 TSuspsEqSusps = true, % TSusps = Susps
7150 AllSusps = TSusps
7151 ;
7152 get_constraint_index(FA,Pos),
7153 get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps)
7154 ).
7156 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
7157 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
7158 list2conj(GuardCopyList,GuardCopy).
7160 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
7161 Rule = rule(_,H,Guard,Body),
7162 conj2list(Guard,GuardList),
7163 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
7164 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
7166 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
7167 term_variables(RestGuardList,GuardVars),
7168 term_variables(RestGuardListCopyCore,GuardCopyVars),
7169 % variables that are declared to be ground don't need to be locked
7170 ground_vars(H,GroundVars),
7171 list_difference_eq(GuardVars,GroundVars,LockedGuardVars),
7172 ( chr_pp_flag(guard_locks,on),
7173 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
7174 X ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard
7175 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
7176 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
7177 ),
7178 LocksUnlocks) ->
7179 once(pairup(Locks,Unlocks,LocksUnlocks))
7180 ;
7181 Locks = [],
7182 Unlocks = []
7183 ),
7184 list2conj(Locks,LockPhase),
7185 list2conj(Unlocks,UnlockPhase),
7186 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
7187 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
7188 my_term_copy(Body,VarDict2,BodyCopy).
7191 split_off_simple_guard([],_,[],[]).
7192 split_off_simple_guard([G|Gs],VarDict,S,C) :-
7193 ( simple_guard(G,VarDict) ->
7194 S = [G|Ss],
7195 split_off_simple_guard(Gs,VarDict,Ss,C)
7196 ;
7197 S = [],
7198 C = [G|Gs]
7199 ).
7201 % simple guard: cheap and benign (does not bind variables)
7202 simple_guard(G,VarDict) :-
7203 binds_b(G,Vars),
7204 \+ (( member(V,Vars),
7205 lookup_eq(VarDict,V,_)
7206 )).
7208 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
7209 functor(Head,F,A),
7210 C = F/A,
7211 ( is_stored(C) ->
7212 (
7213 (
7214 Id == [0], chr_pp_flag(store_in_guards, off)
7215 ;
7216 ( get_allocation_occurrence(C,AO),
7217 get_max_occurrence(C,MO),
7218 MO < AO )
7219 ),
7220 only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
7221 SuspDetachment = true
7222 ;
7223 gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
7224 ( chr_pp_flag(late_allocation,on) ->
7225 SuspDetachment =
7226 ( var(Susp) ->
7227 true
7228 ;
7229 UnCondSuspDetachment
7230 )
7231 ;
7232 SuspDetachment = UnCondSuspDetachment
7233 )
7234 )
7235 ;
7236 SuspDetachment = true
7237 ).
7239 partner_constraint_detachments([],[],_,true).
7240 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
7241 gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
7242 partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
7244 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
7245 functor(Head,F,A),
7246 C = F/A,
7247 ( is_stored(C) ->
7248 SuspDetachment = ( DebugEvent, RemoveInternalGoal),
7249 ( chr_pp_flag(debugable,on) ->
7250 DebugEvent = 'chr debug_event'(remove(Susp))
7251 ;
7252 DebugEvent = true
7253 ),
7254 remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
7255 delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
7256 ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
7257 detach_constraint_atom(C,Vars,Susp,Detach)
7258 ;
7259 Detach = true
7260 )
7261 ;
7262 SuspDetachment = true
7263 ).
7265 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7267 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7268 %% ____ _ _ _ _
7269 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
7270 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
7271 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
7272 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
7273 %% |_| |___/
7274 %% {{{
7276 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
7277 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
7278 Rule = rule(_Heads,Heads2,Guard,Body),
7280 head_info(Head,A,Vars,Susp,HeadVars,HeadPairs),
7281 get_constraint_mode(F/A,Mode),
7282 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
7284 build_head(F,A,Id,HeadVars,ClauseHead),
7286 append(RestHeads,Heads2,Heads),
7287 append(OtherIDs,Heads2IDs,IDs),
7288 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
7290 guard_splitting(Rule,GuardList0),
7291 ( is_stored_in_guard(F/A, RuleNb) ->
7292 GuardList = [Hole1|GuardList0]
7293 ;
7294 GuardList = GuardList0
7295 ),
7296 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
7298 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
7299 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
7301 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
7303 ( is_stored_in_guard(F/A, RuleNb) ->
7304 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
7305 GuardCopyList = [Hole1Copy|_],
7306 Hole1Copy = Attachment
7307 ;
7308 true
7309 ),
7311 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
7312 partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
7313 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
7315 ( chr_pp_flag(debugable,on) ->
7316 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7317 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
7318 sort_by_key(Susps2,Susps2IDs,KeptSusps),
7319 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7320 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
7321 instrument_goal((!),DebugTry,DebugApply,Cut)
7322 ;
7323 Cut = (!)
7324 ),
7326 Clause = ( ClauseHead :-
7327 FirstMatching,
7328 RescheduledTest,
7329 Cut,
7330 SuspsDetachments,
7331 SuspDetachment,
7332 BodyCopy
7333 ),
7334 add_location(Clause,RuleNb,LocatedClause),
7335 L = [LocatedClause | T].
7337 % }}}
7339 split_by_ids([],[],_,[],[]).
7340 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
7341 ( memberchk_eq(I,I1s) ->
7342 S1s = [S | R1s],
7343 S2s = R2s
7344 ;
7345 S1s = R1s,
7346 S2s = [S | R2s]
7347 ),
7348 split_by_ids(Is,Ss,I1s,R1s,R2s).
7350 split_by_ids([],[],_,[],[],[],[]).
7351 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
7352 ( memberchk_eq(I,I1s) ->
7353 S1s = [S | R1s],
7354 SI1s = [I|RSI1s],
7355 S2s = R2s,
7356 SI2s = RSI2s
7357 ;
7358 S1s = R1s,
7359 SI1s = RSI1s,
7360 S2s = [S | R2s],
7361 SI2s = [I|RSI2s]
7362 ),
7363 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
7364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7367 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7368 %% ____ _ _ _ ____
7369 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
7370 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
7371 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
7372 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
7373 %% |_| |___/
7375 %% Genereate prelude + worker predicate
7376 %% prelude calls worker
7377 %% worker iterates over one type of removed constraints
7378 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
7379 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
7380 Rule = rule(Heads1,_,Guard,Body),
7381 append(Heads1,RestHeads2,Heads),
7382 append(IDs1,RestIDs,IDs),
7383 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
7384 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
7385 extend_id(Id,Id1),
7386 ( memberchk_eq(NID,IDs2) ->
7387 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
7388 ;
7389 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
7390 ),
7391 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3),
7392 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
7394 simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L).
7395 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
7396 Heads = [Head|RHeads],
7397 inc_id(Id,Id1),
7398 universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0),
7399 universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1),
7400 ( memberchk_eq(ID,IDs2) ->
7401 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
7402 ;
7403 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
7404 ).
7406 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7407 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
7408 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7409 build_head(F,A,Id1,VarsSusp,ClauseHead),
7410 get_constraint_mode(F/A,Mode),
7411 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7413 lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
7415 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
7417 extend_id(Id1,DelegateId),
7418 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
7419 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
7420 build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate),
7422 PreludeClause =
7423 ( ClauseHead :-
7424 FirstMatching,
7425 ModConstraintsGoal,
7426 !,
7427 ConstraintAllocationGoal,
7428 Delegate
7429 ),
7430 add_dummy_location(PreludeClause,LocatedPreludeClause),
7431 L = [LocatedPreludeClause|T].
7433 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
7434 Term =.. [_|Args],
7435 delegate_variables(Term,Terms,VarDict,Args,Vars).
7437 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
7438 term_variables(PrevTerms,PrevVars),
7439 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
7441 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
7442 term_variables(Term,V1),
7443 term_variables(Terms,V2),
7444 intersect_eq(V1,V2,V3),
7445 list_difference_eq(V3,PrevVars,V4),
7446 translate(V4,VarDict,Vars).
7449 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7450 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
7451 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
7452 Rule = rule(_,_,Guard,Body),
7453 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
7455 gen_var(OtherSusp),
7456 gen_var(OtherSusps),
7458 functor(CurrentHead,OtherF,OtherA),
7459 gen_vars(OtherA,OtherVars),
7460 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7461 get_constraint_mode(OtherF/OtherA,Mode),
7462 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
7464 delay_phase_end(validate_store_type_assumptions,
7465 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7466 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7467 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7468 )
7469 ),
7470 % create_get_mutable_ref(active,State,GetMutable),
7471 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7472 CurrentSuspTest = (
7473 OtherSusp = OtherSuspension,
7474 GetState,
7475 DiffSuspGoals,
7476 FirstMatching
7477 ),
7479 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7480 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7482 guard_splitting(Rule,GuardList0),
7483 ( is_stored_in_guard(F/A, RuleNb) ->
7484 GuardList = [Hole1|GuardList0]
7485 ;
7486 GuardList = GuardList0
7487 ),
7488 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
7490 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
7491 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
7492 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
7494 partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
7496 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7497 build_head(F,A,[O|Id],RecursiveVars,RecursiveCall),
7498 RecursiveVars2 = [[]|PreVarsAndSusps],
7499 build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2),
7501 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
7502 ( is_stored_in_guard(F/A, RuleNb) ->
7503 GuardCopyList = [GuardAttachment|_] % once( ) ??
7504 ;
7505 true
7506 ),
7508 ( is_observed(F/A,O) ->
7509 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7510 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
7511 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
7512 ;
7513 Attachment = true,
7514 ConditionalRecursiveCall = RecursiveCall,
7515 ConditionalRecursiveCall2 = RecursiveCall2
7516 ),
7518 ( chr_pp_flag(debugable,on) ->
7519 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7520 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
7521 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
7522 ;
7523 DebugTry = true,
7524 DebugApply = true
7525 ),
7527 ( is_stored_in_guard(F/A, RuleNb) ->
7528 GuardAttachment = Attachment,
7529 BodyAttachment = true
7530 ;
7531 GuardAttachment = true,
7532 BodyAttachment = Attachment % will be true if not observed at all
7533 ),
7535 ( member(unique(ID1,UniqueKeys), Pragmas),
7536 check_unique_keys(UniqueKeys,VarDict) ->
7537 Clause =
7538 ( ClauseHead :-
7539 ( CurrentSuspTest ->
7540 ( RescheduledTest,
7541 DebugTry ->
7542 DebugApply,
7543 Susps1Detachments,
7544 BodyAttachment,
7545 BodyCopy,
7546 ConditionalRecursiveCall2
7547 ;
7548 RecursiveCall2
7549 )
7550 ;
7551 RecursiveCall
7552 )
7553 )
7554 ;
7555 Clause =
7556 ( ClauseHead :-
7557 ( CurrentSuspTest,
7558 RescheduledTest,
7559 DebugTry ->
7560 DebugApply,
7561 Susps1Detachments,
7562 BodyAttachment,
7563 BodyCopy,
7564 ConditionalRecursiveCall
7565 ;
7566 RecursiveCall
7567 )
7568 )
7569 ),
7570 add_location(Clause,RuleNb,LocatedClause),
7571 L = [LocatedClause | T].
7573 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
7574 ( may_trigger(FA) ->
7575 does_use_field(FA,generation),
7576 delay_phase_end(validate_store_type_assumptions,
7577 ( static_suspension_term(FA,Suspension),
7578 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7579 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
7580 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7581 )
7582 )
7583 ;
7584 delay_phase_end(validate_store_type_assumptions,
7585 ( static_suspension_term(FA,Suspension),
7586 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
7587 get_static_suspension_term_field(arguments,FA,Suspension,Args)
7588 )
7589 ),
7590 GetGeneration = true
7591 ),
7592 ConditionalCall =
7593 ( Susp = Suspension,
7594 GetState,
7595 GetGeneration ->
7596 UpdateState,
7597 Call
7598 ;
7599 true
7600 ).
7602 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7605 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7606 %% ____ _ _
7607 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
7608 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
7609 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
7610 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
7611 %% |_| |___/
7613 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7614 ( RestHeads == [] ->
7615 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
7616 ;
7617 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
7618 ).
7619 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7620 %% Single headed propagation
7621 %% everything in a single clause
7622 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
7623 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7624 build_head(F,A,Id,VarsSusp,ClauseHead),
7626 inc_id(Id,NextId),
7627 build_head(F,A,NextId,VarsSusp,NextHead),
7629 get_constraint_mode(F/A,Mode),
7630 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
7631 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7633 % - recursive call -
7634 RecursiveCall = NextHead,
7636 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
7637 ActualCut = true
7638 ;
7639 ActualCut = !
7640 ),
7642 Rule = rule(_,_,Guard,Body),
7643 ( chr_pp_flag(debugable,on) ->
7644 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7645 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
7646 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
7647 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
7648 ;
7649 Cut = ActualCut
7650 ),
7651 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
7652 use_auxiliary_predicate(novel_production),
7653 use_auxiliary_predicate(extend_history),
7654 does_use_history(F/A,O),
7655 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
7657 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7658 ( HistoryIDs == [] ->
7659 empty_named_history_novel_production(HistoryName,NovelProduction),
7660 empty_named_history_extend_history(HistoryName,ExtendHistory)
7661 ;
7662 Tuple = HistoryName
7663 )
7664 ;
7665 Tuple = RuleNb
7666 ),
7668 ( var(NovelProduction) ->
7669 NovelProduction = '$novel_production'(Susp,Tuple),
7670 ExtendHistory = '$extend_history'(Susp,Tuple)
7671 ;
7672 true
7673 ),
7675 ( is_observed(F/A,O) ->
7676 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
7677 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7678 ;
7679 Attachment = true,
7680 ConditionalRecursiveCall = RecursiveCall
7681 )
7682 ;
7683 Allocation = true,
7684 NovelProduction = true,
7685 ExtendHistory = true,
7687 ( is_observed(F/A,O) ->
7688 get_allocation_occurrence(F/A,AllocO),
7689 ( O == AllocO ->
7690 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
7691 Generation = 0
7692 ; % more room for improvement?
7693 Attachment = (Attachment1, Attachment2),
7694 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
7695 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
7696 ),
7697 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7698 ;
7699 gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
7700 ConditionalRecursiveCall = RecursiveCall
7701 )
7702 ),
7704 ( is_stored_in_guard(F/A, RuleNb) ->
7705 GuardAttachment = Attachment,
7706 BodyAttachment = true
7707 ;
7708 GuardAttachment = true,
7709 BodyAttachment = Attachment % will be true if not observed at all
7710 ),
7712 Clause = (
7713 ClauseHead :-
7714 HeadMatching,
7715 Allocation,
7716 NovelProduction,
7717 GuardAttachment,
7718 GuardCopy,
7719 Cut,
7720 ExtendHistory,
7721 BodyAttachment,
7722 BodyCopy,
7723 ConditionalRecursiveCall
7724 ),
7725 add_location(Clause,RuleNb,LocatedClause),
7726 ProgramList = [LocatedClause | ProgramTail].
7728 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7729 %% multi headed propagation
7730 %% prelude + predicates to accumulate the necessary combinations of suspended
7731 %% constraints + predicate to execute the body
7732 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7733 RestHeads = [First|Rest],
7734 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
7735 extend_id(Id,ExtendedId),
7736 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
7738 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7739 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
7740 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
7741 build_head(F,A,Id,VarsSusp,PreludeHead),
7742 get_constraint_mode(F/A,Mode),
7743 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
7744 Rule = rule(_,_,Guard,Body),
7745 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
7747 lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
7749 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
7751 extend_id(Id,NestedId),
7752 append([Susps|VarsSusp],ExtraVars,NestedVars),
7753 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
7754 NestedCall = NestedHead,
7756 Prelude = (
7757 PreludeHead :-
7758 FirstMatching,
7759 FirstSuspGoal,
7760 !,
7761 CondAllocation,
7762 NestedCall
7763 ),
7764 add_dummy_location(Prelude,LocatedPrelude),
7765 L = [LocatedPrelude|T].
7767 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7768 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7769 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1),
7770 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
7772 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
7773 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1),
7774 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2),
7775 inc_id(Id,IncId),
7776 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
7778 %check_fd_lookup_condition(_,_,_,_) :- fail.
7779 check_fd_lookup_condition(F,A,_,_) :-
7780 get_store_type(F/A,global_singleton), !.
7781 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
7782 \+ may_trigger(F/A),
7783 get_functional_dependency(F/A,1,P,K),
7784 copy_term(P-K,CurrentHead-Key),
7785 term_variables(PreHeads,PreVars),
7786 intersect_eq(Key,PreVars,Key),!.
7788 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
7789 Rule = rule(_,H2,Guard,Body),
7790 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7791 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7792 init(AllSusps,RestSusps),
7793 last(AllSusps,Susp),
7794 gen_var(OtherSusp),
7795 gen_var(OtherSusps),
7796 functor(CurrentHead,OtherF,OtherA),
7797 gen_vars(OtherA,OtherVars),
7798 delay_phase_end(validate_store_type_assumptions,
7799 ( static_suspension_term(OtherF/OtherA,Suspension),
7800 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
7801 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
7802 )
7803 ),
7804 % create_get_mutable_ref(active,State,GetMutable),
7805 CurrentSuspTest = (
7806 OtherSusp = Suspension,
7807 GetState
7808 ),
7809 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7810 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
7811 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
7812 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
7813 RecursiveVars = PreVarsAndSusps1
7814 ;
7815 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7816 PrevId0 = Id
7817 ),
7818 ( PrevId0 = [_] ->
7819 PrevId = PrevId0
7820 ;
7821 PrevId = [O|PrevId0]
7822 ),
7823 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7824 RecursiveCall = RecursiveHead,
7825 CurrentHead =.. [_|OtherArgs],
7826 pairup(OtherArgs,OtherVars,OtherPairs),
7827 get_constraint_mode(OtherF/OtherA,Mode),
7828 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
7830 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
7831 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
7832 get_occurrence(F/A,O,_,ID),
7834 ( is_observed(F/A,O) ->
7835 init(FirstVarsSusp,FirstVars),
7836 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
7837 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
7838 ;
7839 Attachment = true,
7840 ConditionalRecursiveCall = RecursiveCall
7841 ),
7842 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
7843 NovelProduction = true,
7844 ExtendHistory = true
7845 ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) ->
7846 NovelProduction = true,
7847 ExtendHistory = true
7848 ;
7849 get_occurrence(F/A,O,_,ID),
7850 use_auxiliary_predicate(novel_production),
7851 use_auxiliary_predicate(extend_history),
7852 does_use_history(F/A,O),
7853 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
7854 ( HistoryIDs == [] ->
7855 empty_named_history_novel_production(HistoryName,NovelProduction),
7856 empty_named_history_extend_history(HistoryName,ExtendHistory)
7857 ;
7858 reverse([OtherSusp|RestSusps],NamedSusps),
7859 named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
7860 HistorySusps = [HistorySusp|_],
7862 ( length(HistoryIDs, 1) ->
7863 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
7864 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
7865 ;
7866 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
7867 Tuple =.. [t,HistoryName|HistorySusps]
7868 )
7869 )
7870 ;
7871 HistorySusp = Susp,
7872 maplist(extract_symbol,H2,ConstraintSymbols),
7873 sort([ID|RestIDs],HistoryIDs),
7874 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
7875 Tuple =.. [t,RuleNb|HistorySusps]
7876 ),
7878 ( var(NovelProduction) ->
7879 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
7880 ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
7881 NovelProduction = ( TupleVar = Tuple, NovelProductions )
7882 ;
7883 true
7884 )
7885 ),
7888 ( chr_pp_flag(debugable,on) ->
7889 Rule = rule(_,_,Guard,Body),
7890 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
7891 get_occurrence(F/A,O,_,ID),
7892 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
7893 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
7894 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
7895 ;
7896 DebugTry = true,
7897 DebugApply = true
7898 ),
7900 ( is_stored_in_guard(F/A, RuleNb) ->
7901 GuardAttachment = Attachment,
7902 BodyAttachment = true
7903 ;
7904 GuardAttachment = true,
7905 BodyAttachment = Attachment % will be true if not observed at all
7906 ),
7908 Clause = (
7909 ClauseHead :-
7910 ( CurrentSuspTest,
7911 DiffSuspGoals,
7912 Matching,
7913 NovelProduction,
7914 GuardAttachment,
7915 GuardCopy,
7916 DebugTry ->
7917 DebugApply,
7918 ExtendHistory,
7919 BodyAttachment,
7920 BodyCopy,
7921 ConditionalRecursiveCall
7922 ; RecursiveCall
7923 )
7924 ),
7925 add_location(Clause,RuleNb,LocatedClause),
7926 L = [LocatedClause|T].
7928 extract_symbol(Head,F/A) :-
7929 functor(Head,F,A).
7931 novel_production_calls([],[],[],_,_,true).
7932 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
7933 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
7934 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
7935 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
7937 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
7938 reverse(ReversedRestSusps,RestSusps),
7939 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
7941 named_history_susps([],_,_,[]).
7942 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
7943 select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
7944 named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
7948 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
7949 !,
7950 functor(Head,F,A),
7951 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
7952 get_constraint_mode(F/A,Mode),
7953 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
7954 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
7955 append(VarsSusp,ExtraVars,HeadVars).
7956 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
7957 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
7958 functor(Head,F,A),
7959 gen_var(Susps),
7960 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7961 get_constraint_mode(F/A,Mode),
7962 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7963 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
7964 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
7966 % returns
7967 % VarDict for the copies of variables in the original heads
7968 % VarsSuspsList list of lists of arguments for the successive heads
7969 % FirstVarsSusp top level arguments
7970 % SuspList list of all suspensions
7971 % Iterators list of all iterators
7972 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
7973 !,
7974 functor(Head,F,A),
7975 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
7976 get_constraint_mode(F/A,Mode),
7977 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
7978 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
7979 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
7980 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
7981 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
7982 functor(Head,F,A),
7983 gen_var(Susps),
7984 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
7985 get_constraint_mode(F/A,Mode),
7986 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
7987 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
7988 append(HeadVars,[Susp,Susps],Vars).
7990 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
7991 !,
7992 functor(Head,F,A),
7993 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
7994 get_constraint_mode(F/A,Mode),
7995 head_arg_matches(Pairs,Mode,[],_,VarDict),
7996 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
7997 append(VarsSusp,ExtraVars,HeadVars).
7998 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
7999 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
8000 functor(Head,F,A),
8001 gen_var(Susps),
8002 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
8003 get_constraint_mode(F/A,Mode),
8004 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
8005 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
8006 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
8008 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8010 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8011 %% ____ _ _ _ _
8012 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
8013 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
8014 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
8015 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
8016 %%
8017 %% ____ _ _ _
8018 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
8019 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
8020 %% | _ < __/ |_| | | | __/\ V / (_| | |
8021 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
8022 %%
8023 %% ____ _ _
8024 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
8025 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
8026 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
8027 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
8028 %% |___/
8030 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8031 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
8032 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
8033 ;
8034 NRestHeads = RestHeads,
8035 NRestIDs = RestIDs
8036 ).
8038 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
8039 term_variables(Head,Vars),
8040 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
8041 copy_term_nat(InitialData,InitialDataCopy),
8042 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
8043 InitialDataCopy = InitialData,
8044 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
8045 reverse(RNRestHeads,NRestHeads),
8046 reverse(RNRestIDs,NRestIDs).
8048 final_data(Entry) :-
8049 Entry = entry(_,_,_,_,[],_).
8051 expand_data(Entry,NEntry,Cost) :-
8052 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
8053 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
8054 term_variables([Head1|Vars],Vars1),
8055 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
8056 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
8058 % Assigns score to head based on known variables and heads to lookup
8059 % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{
8060 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
8061 functor(Head,F,A),
8062 get_store_type(F/A,StoreType),
8063 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,99999,Score).
8064 % }}}
8066 %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{
8067 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8068 term_variables(Head,HeadVars0),
8069 term_variables(RestHeads,RestVars),
8070 ground_vars([Head],GroundVars),
8071 list_difference_eq(HeadVars0,GroundVars,HeadVars),
8072 order_score_vars(HeadVars,KnownVars,RestVars,Score),
8073 NScore is min(CScore,Score).
8074 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8075 ( CScore =< 100 ->
8076 Score = CScore
8077 ;
8078 order_score_indexes(Indexes,Head,KnownVars,Score)
8079 ).
8080 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8081 ( CScore =< 100 ->
8082 Score = CScore
8083 ;
8084 order_score_indexes(Indexes,Head,KnownVars,Score)
8085 ).
8086 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :-
8087 term_variables(Head,HeadVars),
8088 term_variables(RestHeads,RestVars),
8089 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
8090 Score is Score_ * 200,
8091 NScore is min(CScore,Score).
8092 order_score(var_assoc_store(_,_),_,_,_,_,_,_,1).
8093 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :-
8094 Score = 1. % guaranteed O(1)
8095 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8096 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score).
8097 multi_order_score([],_,_,_,_,_,Score,Score).
8098 multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :-
8099 ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true
8100 ; Score1 = Score0
8101 ),
8102 multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score).
8104 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8105 Score is min(CScore,10).
8106 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :-
8107 Score is min(CScore,10).
8108 % }}}
8111 %% order_score_indexes(+indexes,+head,+vars,-score). {{{
8112 order_score_indexes(Indexes,Head,Vars,Score) :-
8113 copy_term_nat(Head+Vars,HeadCopy+VarsCopy),
8114 numbervars(VarsCopy,0,_),
8115 order_score_indexes(Indexes,HeadCopy,Score).
8117 order_score_indexes([I|Is],Head,Score) :-
8118 multi_hash_key_args(I,Head,Args),
8119 ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ ->
8120 Score = 100
8121 ;
8122 order_score_indexes(Is,Head,Score)
8123 ).
8124 % }}}
8126 memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List).
8128 order_score_vars(Vars,KnownVars,RestVars,Score) :-
8129 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
8130 ( K-R-O == 0-0-0 ->
8131 Score = 0
8132 ; K > 0 ->
8133 Score is max(10 - K,0)
8134 ; R > 0 ->
8135 Score is max(10 - R,1) * 100
8136 ;
8137 Score is max(10-O,1) * 1000
8138 ).
8139 order_score_count_vars([],_,_,0-0-0).
8140 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
8141 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
8142 ( memberchk_eq(V,KnownVars) ->
8143 NK is K + 1,
8144 NR = R, NO = O
8145 ; memberchk_eq(V,RestVars) ->
8146 NR is R + 1,
8147 NK = K, NO = O
8148 ;
8149 NO is O + 1,
8150 NK = K, NR = R
8151 ).
8153 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8154 %% ___ _ _ _
8155 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
8156 %% | || '_ \| | | '_ \| | '_ \ / _` |
8157 %% | || | | | | | | | | | | | | (_| |
8158 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
8159 %% |___/
8161 %% SWI begin
8162 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
8163 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
8164 %% SWI end
8166 %% SICStus begin
8167 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
8168 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
8169 %% SICStus end
8171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8173 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8174 %% _ _ _ _ _ _ _
8175 %% | | | | |_(_) (_) |_ _ _
8176 %% | | | | __| | | | __| | | |
8177 %% | |_| | |_| | | | |_| |_| |
8178 %% \___/ \__|_|_|_|\__|\__, |
8179 %% |___/
8181 % Create a fresh variable.
8182 gen_var(_).
8184 % Create =N= fresh variables.
8185 gen_vars(N,Xs) :-
8186 length(Xs,N).
8188 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
8189 vars_susp(A,Vars,Susp,VarsSusp),
8190 Head =.. [_|Args],
8191 pairup(Args,Vars,HeadPairs).
8193 inc_id([N|Ns],[O|Ns]) :-
8194 O is N + 1.
8195 dec_id([N|Ns],[M|Ns]) :-
8196 M is N - 1.
8198 extend_id(Id,[0|Id]).
8200 next_id([_,N|Ns],[O|Ns]) :-
8201 O is N + 1.
8203 % return clause Head
8204 % for F/A constraint symbol, predicate identifier Id and arguments Head
8205 build_head(F,A,Id,Args,Head) :-
8206 buildName(F,A,Id,Name),
8207 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)),
8208 ( may_trigger(F/A) ;
8209 get_allocation_occurrence(F/A,AO),
8210 get_max_occurrence(F/A,MO),
8211 MO >= AO ) ) ->
8212 Head =.. [Name|Args]
8213 ;
8214 init(Args,ArgsWOSusp), % XXX not entirely correct!
8215 Head =.. [Name|ArgsWOSusp]
8216 ).
8218 % return predicate name Result
8219 % for Fct/Aty constraint symbol and predicate identifier List
8220 buildName(Fct,Aty,List,Result) :-
8221 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
8222 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
8223 MO >= AO ) ; List \= [0])) ) ) ->
8224 atom_concat(Fct, '___' ,FctSlash),
8225 atomic_concat(FctSlash,Aty,FctSlashAty),
8226 buildName_(List,FctSlashAty,Result)
8227 ;
8228 Result = Fct
8229 ).
8231 buildName_([],Name,Name).
8232 buildName_([N|Ns],Name,Result) :-
8233 buildName_(Ns,Name,Name1),
8234 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
8235 atomic_concat(NameDash,N,Result).
8237 vars_susp(A,Vars,Susp,VarsSusp) :-
8238 length(Vars,A),
8239 append(Vars,[Susp],VarsSusp).
8241 or_pattern(Pos,Pat) :-
8242 Pow is Pos - 1,
8243 Pat is 1 << Pow. % was 2 ** X
8245 and_pattern(Pos,Pat) :-
8246 X is Pos - 1,
8247 Y is 1 << X, % was 2 ** X
8248 Pat is (-1)*(Y + 1).
8250 make_name(Prefix,F/A,Name) :-
8251 atom_concat_list([Prefix,F,'___',A],Name).
8253 %===============================================================================
8254 % Attribute for attributed variables
8256 make_attr(N,Mask,SuspsList,Attr) :-
8257 length(SuspsList,N),
8258 Attr =.. [v,Mask|SuspsList].
8260 get_all_suspensions2(N,Attr,SuspensionsList) :-
8261 chr_pp_flag(dynattr,off), !,
8262 make_attr(N,_,SuspensionsList,Attr).
8264 % NEW
8265 get_all_suspensions2(N,Attr,Goal,SuspensionsList) :-
8266 % writeln(get_all_suspensions2),
8267 length(SuspensionsList,N),
8268 Goal = 'chr all_suspensions'(SuspensionsList,1,Attr).
8271 % NEW
8272 normalize_attr(Attr,NormalGoal,NormalAttr) :-
8273 % writeln(normalize_attr),
8274 NormalGoal = 'chr normalize_attr'(Attr,NormalAttr).
8276 get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :-
8277 chr_pp_flag(dynattr,off), !,
8278 make_attr(N,_,SuspsList,Attr),
8279 nth1(Position,SuspsList,Suspensions).
8281 % NEW
8282 get_suspensions(N,Position,TAttr,Goal,Suspensions) :-
8283 % writeln(get_suspensions),
8284 Goal =
8285 ( memberchk(Position-Suspensions,TAttr) ->
8286 true
8287 ;
8288 Suspensions = []
8289 ).
8291 %-------------------------------------------------------------------------------
8292 % +N: number of constraint symbols
8293 % +Suspension: source-level variable, for suspension
8294 % +Position: constraint symbol number
8295 % -Attr: source-level term, for new attribute
8296 singleton_attr(N,Suspension,Position,Attr) :-
8297 chr_pp_flag(dynattr,off), !,
8298 or_pattern(Position,Pattern),
8299 make_attr(N,Pattern,SuspsList,Attr),
8300 nth1(Position,SuspsList,[Suspension]),
8301 chr_delete(SuspsList,[Suspension],RestSuspsList),
8302 set_elems(RestSuspsList,[]).
8304 % NEW
8305 singleton_attr(N,Suspension,Position,Attr) :-
8306 % writeln(singleton_attr),
8307 Attr = [Position-[Suspension]].
8309 %-------------------------------------------------------------------------------
8310 % +N: number of constraint symbols
8311 % +Suspension: source-level variable, for suspension
8312 % +Position: constraint symbol number
8313 % +TAttr: source-level variable, for old attribute
8314 % -Goal: goal for creating new attribute
8315 % -NTAttr: source-level variable, for new attribute
8316 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8317 chr_pp_flag(dynattr,off), !,
8318 make_attr(N,Mask,SuspsList,Attr),
8319 or_pattern(Position,Pattern),
8320 nth1(Position,SuspsList,Susps),
8321 substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1),
8322 make_attr(N,Mask,SuspsList1,NewAttr1),
8323 substitute_eq(Susps,SuspsList,[Suspension],SuspsList2),
8324 make_attr(N,NewMask,SuspsList2,NewAttr2),
8325 Goal = (
8326 TAttr = Attr,
8327 ( Mask /\ Pattern =:= Pattern ->
8328 NTAttr = NewAttr1
8329 ;
8330 NewMask is Mask \/ Pattern,
8331 NTAttr = NewAttr2
8332 )
8333 ), !.
8335 % NEW
8336 add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :-
8337 % writeln(add_attr),
8338 Goal =
8339 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8340 NTAttr = [Position-[Suspension|Suspensions]|RAttr]
8341 ;
8342 NTAttr = [Position-[Suspension]|TAttr]
8343 ).
8345 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8346 chr_pp_flag(dynattr,off), !,
8347 or_pattern(Position,Pattern),
8348 and_pattern(Position,DelPattern),
8349 make_attr(N,Mask,SuspsList,Attr),
8350 nth1(Position,SuspsList,Susps),
8351 substitute_eq(Susps,SuspsList,[],SuspsList1),
8352 make_attr(N,NewMask,SuspsList1,Attr1),
8353 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
8354 make_attr(N,Mask,SuspsList2,Attr2),
8355 get_target_module(Mod),
8356 Goal = (
8357 TAttr = Attr,
8358 ( Mask /\ Pattern =:= Pattern ->
8359 'chr sbag_del_element'(Susps,Suspension,NewSusps),
8360 ( NewSusps == [] ->
8361 NewMask is Mask /\ DelPattern,
8362 ( NewMask == 0 ->
8363 del_attr(Var,Mod)
8364 ;
8365 put_attr(Var,Mod,Attr1)
8366 )
8367 ;
8368 put_attr(Var,Mod,Attr2)
8369 )
8370 ;
8371 true
8372 )
8373 ), !.
8375 % NEW
8376 rem_attr(N,Var,Suspension,Position,TAttr,Goal) :-
8377 % writeln(rem_attr),
8378 get_target_module(Mod),
8379 Goal =
8380 ( 'chr select'(TAttr,Position-Suspensions,RAttr) ->
8381 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions),
8382 ( NSuspensions == [] ->
8383 ( RAttr == [] ->
8384 del_attr(Var,Mod)
8385 ;
8386 put_attr(Var,Mod,RAttr)
8387 )
8388 ;
8389 put_attr(Var,Mod,[Position-NSuspensions|RAttr])
8390 )
8391 ;
8392 true
8393 ).
8395 %-------------------------------------------------------------------------------
8396 % +N: number of constraint symbols
8397 % +TAttr1: source-level variable, for attribute
8398 % +TAttr2: source-level variable, for other attribute
8399 % -Goal: goal for merging the two attributes
8400 % -Attr: source-level term, for merged attribute
8401 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8402 chr_pp_flag(dynattr,off), !,
8403 make_attr(N,Mask1,SuspsList1,Attr1),
8404 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr),
8405 Goal = (
8406 TAttr1 = Attr1,
8407 Goal2
8408 ).
8410 % NEW
8411 merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :-
8412 % writeln(merge_attributes),
8413 Goal = (
8414 sort(TAttr1,Sorted1),
8415 sort(TAttr2,Sorted2),
8416 'chr new_merge_attributes'(Sorted1,Sorted2,Attr)
8417 ).
8420 %-------------------------------------------------------------------------------
8421 % +N: number of constraint symbols
8422 % +Mask1: ...
8423 % +SuspsList1: static term, for suspensions list
8424 % +TAttr2: source-level variable, for other attribute
8425 % -Goal: goal for merging the two attributes
8426 % -Attr: source-level term, for merged attribute
8427 merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :-
8428 make_attr(N,Mask2,SuspsList2,Attr2),
8429 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
8430 list2conj(Gs,SortGoals),
8431 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), SuspsList),
8432 make_attr(N,Mask,SuspsList,Attr),
8433 Goal = (
8434 TAttr2 = Attr2,
8435 SortGoals,
8436 Mask is Mask1 \/ Mask2
8437 ).
8440 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8441 % Storetype dependent lookup
8443 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8444 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
8445 %% -Goal,-SuspensionList) is det.
8446 %
8447 % Create a universal lookup goal for given head.
8448 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8449 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
8450 functor(Head,F,A),
8451 get_store_type(F/A,StoreType),
8452 lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
8454 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8455 %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
8456 %% -Goal,-SuspensionList) is det.
8457 %
8458 % Create a universal lookup goal for given head.
8459 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8460 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8461 functor(Head,F,A),
8462 get_store_type(F/A,StoreType),
8463 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
8465 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8466 %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
8467 %% +GroundVars,-Goal,-SuspensionList) is det.
8468 %
8469 % Create a universal lookup goal for given head.
8470 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8471 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
8472 functor(Head,F,A),
8473 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps),
8474 update_store_type(F/A,default).
8475 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8476 hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8477 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8478 hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
8479 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8480 functor(Head,F,A),
8481 global_ground_store_name(F/A,StoreName),
8482 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
8483 update_store_type(F/A,global_ground).
8484 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
8485 arg(VarIndex,Head,OVar),
8486 arg(KeyIndex,Head,OKey),
8487 translate([OVar,OKey],VarDict,[Var,Key]),
8488 get_target_module(Module),
8489 Goal = (
8490 get_attr(Var,Module,AssocStore),
8491 lookup_assoc_store(AssocStore,Key,AllSusps)
8492 ).
8493 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
8494 functor(Head,F,A),
8495 global_singleton_store_name(F/A,StoreName),
8496 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8497 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
8498 update_store_type(F/A,global_singleton).
8499 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8500 once((
8501 member(ST,StoreTypes),
8502 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
8503 )).
8504 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8505 functor(Head,F,A),
8506 arg(Index,Head,Var),
8507 translate([Var],VarDict,[KeyVar]),
8508 delay_phase_end(validate_store_type_assumptions,
8509 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
8510 ),
8511 update_store_type(F/A,identifier_store(Index)),
8512 get_identifier_index(F/A,Index,_).
8513 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
8514 functor(Head,F,A),
8515 arg(Index,Head,Var),
8516 ( var(Var) ->
8517 translate([Var],VarDict,[KeyVar]),
8518 Goal = StructGoal
8519 ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
8520 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
8521 Goal = (LookupGoal,StructGoal)
8522 ),
8523 delay_phase_end(validate_store_type_assumptions,
8524 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
8525 ),
8526 update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
8527 get_type_indexed_identifier_index(IndexType,F/A,Index,_).
8529 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
8530 get_identifier_size(ISize),
8531 functor(Struct,struct,ISize),
8532 get_identifier_index(C,Index,IIndex),
8533 arg(IIndex,Struct,AllSusps),
8534 Goal = (KeyVar = Struct).
8536 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
8537 type_indexed_identifier_structure(IndexType,Struct),
8538 get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
8539 arg(IIndex,Struct,AllSusps),
8540 Goal = (KeyVar = Struct).
8542 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8543 %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
8544 %% +GroundVars,-Goal,-SuspensionList,-Index) is det.
8545 %
8546 % Create a universal hash lookup goal for given head.
8547 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8548 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
8549 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies),
8550 ( KeyArgCopies = [KeyCopy] ->
8551 true
8552 ;
8553 KeyCopy =.. [k|KeyArgCopies]
8554 ),
8555 functor(Head,F,A),
8556 multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal),
8558 check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
8559 my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
8561 Goal = (GroundCheck,LookupGoal),
8563 ( HashType == inthash ->
8564 update_store_type(F/A,multi_inthash([Index]))
8565 ;
8566 update_store_type(F/A,multi_hash([Index]))
8567 ).
8569 pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :-
8570 member(Index,Indexes),
8571 multi_hash_key_args(Index,Head,KeyArgs),
8572 key_in_scope(KeyArgs,VarDict,KeyArgCopies),
8573 !.
8575 % check whether we can copy the given terms
8576 % with the given dictionary, and, if so, do so
8577 key_in_scope([],VarDict,[]).
8578 key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :-
8579 term_variables(Arg,Vars),
8580 translate(Vars,VarDict,VarCopies),
8581 copy_term(Arg/Vars,ArgCopy/VarCopies),
8582 key_in_scope(Args,VarDict,ArgCopies).
8584 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8585 %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
8586 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8587 %% +VarArgDict,-NewVarArgDict) is det.
8588 %
8589 % Create existential lookup goal for given head.
8590 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8591 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8592 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
8593 sbag_member_call(Susp,AllSusps,Sbag),
8594 functor(Head,F,A),
8595 delay_phase_end(validate_store_type_assumptions,
8596 ( static_suspension_term(F/A,SuspTerm),
8597 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8598 )
8599 ),
8600 Goal = (
8601 UniversalGoal,
8602 Sbag,
8603 Susp = SuspTerm,
8604 GetState
8605 ).
8606 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
8607 functor(Head,F,A),
8608 global_singleton_store_name(F/A,StoreName),
8609 make_get_store_goal(StoreName,Susp,GetStoreGoal),
8610 Goal = (
8611 GetStoreGoal, % nb_getval(StoreName,Susp),
8612 Susp \== [],
8613 Susp = SuspTerm
8614 ),
8615 update_store_type(F/A,global_singleton).
8616 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8617 once((
8618 member(ST,StoreTypes),
8619 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
8620 )).
8621 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8622 existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8623 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8624 existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
8625 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8626 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8627 hash_index_filter(Pairs,Index,NPairs),
8629 functor(Head,F,A),
8630 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8631 Sbag = (AllSusps = [Susp])
8632 ;
8633 sbag_member_call(Susp,AllSusps,Sbag)
8634 ),
8635 delay_phase_end(validate_store_type_assumptions,
8636 ( static_suspension_term(F/A,SuspTerm),
8637 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8638 )
8639 ),
8640 Goal = (
8641 LookupGoal,
8642 Sbag,
8643 Susp = SuspTerm, % not inlined
8644 GetState
8645 ).
8646 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
8647 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
8648 hash_index_filter(Pairs,Index,NPairs),
8650 functor(Head,F,A),
8651 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8652 Sbag = (AllSusps = [Susp])
8653 ;
8654 sbag_member_call(Susp,AllSusps,Sbag)
8655 ),
8656 delay_phase_end(validate_store_type_assumptions,
8657 ( static_suspension_term(F/A,SuspTerm),
8658 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8659 )
8660 ),
8661 Goal = (
8662 LookupGoal,
8663 Sbag,
8664 Susp = SuspTerm, % not inlined
8665 GetState
8666 ).
8667 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
8668 lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
8669 sbag_member_call(Susp,Susps,Sbag),
8670 functor(Head,F,A),
8671 delay_phase_end(validate_store_type_assumptions,
8672 ( static_suspension_term(F/A,SuspTerm),
8673 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8674 )
8675 ),
8676 Goal = (
8677 UGoal,
8678 Sbag,
8679 Susp = SuspTerm, % not inlined
8680 GetState
8681 ).
8683 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8684 %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
8685 %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
8686 %% +VarArgDict,-NewVarArgDict) is det.
8687 %
8688 % Create existential hash lookup goal for given head.
8689 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8690 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
8691 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
8693 hash_index_filter(Pairs,Index,NPairs),
8695 functor(Head,F,A),
8696 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
8697 Sbag = (AllSusps = [Susp])
8698 ;
8699 sbag_member_call(Susp,AllSusps,Sbag)
8700 ),
8701 delay_phase_end(validate_store_type_assumptions,
8702 ( static_suspension_term(F/A,SuspTerm),
8703 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
8704 )
8705 ),
8706 Goal = (
8707 LookupGoal,
8708 Sbag,
8709 Susp = SuspTerm, % not inlined
8710 GetState
8711 ).
8713 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8714 %% hash_index_filter(+Pairs,+Index,-NPairs) is det.
8715 %
8716 % Filter out pairs already covered by given hash index.
8717 % makes them 'silent'
8718 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
8719 hash_index_filter(Pairs,Index,NPairs) :-
8720 hash_index_filter(Pairs,Index,1,NPairs).
8722 hash_index_filter([],_,_,[]).
8723 hash_index_filter([P|Ps],Index,N,NPairs) :-
8724 ( Index = [I|Is] ->
8725 NN is N + 1,
8726 ( I > N ->
8727 NPairs = [P|NPs],
8728 hash_index_filter(Ps,[I|Is],NN,NPs)
8729 ; I == N ->
8730 NPairs = [silent(P)|NPs],
8731 hash_index_filter(Ps,Is,NN,NPs)
8732 )
8733 ;
8734 NPairs = [P|Ps]
8735 ).
8737 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8738 %------------------------------------------------------------------------------%
8739 %% assume_constraint_stores(+ConstraintSymbols) is det.
8740 %
8741 % Compute all constraint store types that are possible for the given
8742 % =ConstraintSymbols=.
8743 %------------------------------------------------------------------------------%
8744 assume_constraint_stores([]).
8745 assume_constraint_stores([C|Cs]) :-
8746 ( chr_pp_flag(debugable,off),
8747 ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ),
8748 is_stored(C),
8749 get_store_type(C,default) ->
8750 get_indexed_arguments(C,AllIndexedArgs),
8751 get_constraint_mode(C,Modes),
8752 aggregate_all(bag(Index)-count,
8753 (member(Index,AllIndexedArgs),nth1(Index,Modes,+)),
8754 IndexedArgs-NbIndexedArgs),
8755 % Construct Index Combinations
8756 ( NbIndexedArgs > 10 ->
8757 findall([Index],member(Index,IndexedArgs),Indexes)
8758 ;
8759 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
8760 predsort(longer_list,UnsortedIndexes,Indexes)
8761 ),
8762 % EXPERIMENTAL HEURISTIC
8763 % findall(Index, (
8764 % member(Arg1,IndexedArgs),
8765 % member(Arg2,IndexedArgs),
8766 % Arg1 =< Arg2,
8767 % sort([Arg1,Arg2], Index)
8768 % ), UnsortedIndexes),
8769 % predsort(longer_list,UnsortedIndexes,Indexes),
8770 % Choose Index Type
8771 ( get_functional_dependency(C,1,Pattern,Key),
8772 all_distinct_var_args(Pattern), Key == [] ->
8773 assumed_store_type(C,global_singleton)
8774 ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) ->
8775 get_constraint_type_det(C,ArgTypes),
8776 partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
8778 ( IntHashIndexes = [] ->
8779 Stores = Stores1
8780 ;
8781 Stores = [multi_inthash(IntHashIndexes)|Stores1]
8782 ),
8783 ( HashIndexes = [] ->
8784 Stores1 = Stores2
8785 ;
8786 Stores1 = [multi_hash(HashIndexes)|Stores2]
8787 ),
8788 ( IdentifierIndexes = [] ->
8789 Stores2 = Stores3
8790 ;
8791 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
8792 append(WrappedIdentifierIndexes,Stores3,Stores2)
8793 ),
8794 append(CompoundIdentifierIndexes,Stores4,Stores3),
8795 ( only_ground_indexed_arguments(C)
8796 -> Stores4 = [global_ground]
8797 ; Stores4 = [default]
8798 ),
8799 assumed_store_type(C,multi_store(Stores))
8800 ; true
8801 )
8802 ;
8803 true
8804 ),
8805 assume_constraint_stores(Cs).
8807 %------------------------------------------------------------------------------%
8808 %% partition_indexes(+Indexes,+Types,
8809 %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
8810 %------------------------------------------------------------------------------%
8811 partition_indexes([],_,[],[],[],[]).
8812 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
8813 ( Index = [I],
8814 nth1(I,Types,Type),
8815 unalias_type(Type,UnAliasedType),
8816 UnAliasedType == chr_identifier ->
8817 IdentifierIndexes = [I|RIdentifierIndexes],
8818 IntHashIndexes = RIntHashIndexes,
8819 HashIndexes = RHashIndexes,
8820 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8821 ; Index = [I],
8822 nth1(I,Types,Type),
8823 unalias_type(Type,UnAliasedType),
8824 nonvar(UnAliasedType),
8825 UnAliasedType = chr_identifier(IndexType) ->
8826 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
8827 IdentifierIndexes = RIdentifierIndexes,
8828 IntHashIndexes = RIntHashIndexes,
8829 HashIndexes = RHashIndexes
8830 ; Index = [I],
8831 nth1(I,Types,Type),
8832 unalias_type(Type,UnAliasedType),
8833 UnAliasedType == dense_int ->
8834 IntHashIndexes = [Index|RIntHashIndexes],
8835 HashIndexes = RHashIndexes,
8836 IdentifierIndexes = RIdentifierIndexes,
8837 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8838 ; member(I,Index),
8839 nth1(I,Types,Type),
8840 unalias_type(Type,UnAliasedType),
8841 nonvar(UnAliasedType),
8842 UnAliasedType = chr_identifier(_) ->
8843 % don't use chr_identifiers in hash indexes
8844 IntHashIndexes = RIntHashIndexes,
8845 HashIndexes = RHashIndexes,
8846 IdentifierIndexes = RIdentifierIndexes,
8847 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8848 ;
8849 IntHashIndexes = RIntHashIndexes,
8850 HashIndexes = [Index|RHashIndexes],
8851 IdentifierIndexes = RIdentifierIndexes,
8852 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
8853 ),
8854 partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
8856 longer_list(R,L1,L2) :-
8857 length(L1,N1),
8858 length(L2,N2),
8859 compare(Rt,N2,N1),
8860 ( Rt == (=) ->
8861 compare(R,L1,L2)
8862 ;
8863 R = Rt
8864 ).
8866 all_distinct_var_args(Term) :-
8867 copy_term_nat(Term,TermCopy),
8868 functor(Term,F,A),
8869 functor(Pattern,F,A),
8870 Pattern =@= TermCopy.
8872 get_indexed_arguments(C,IndexedArgs) :-
8873 C = F/A,
8874 get_indexed_arguments(1,A,C,IndexedArgs).
8876 get_indexed_arguments(I,N,C,L) :-
8877 ( I > N ->
8878 L = []
8879 ; ( is_indexed_argument(C,I) ->
8880 L = [I|T]
8881 ;
8882 L = T
8883 ),
8884 J is I + 1,
8885 get_indexed_arguments(J,N,C,T)
8886 ).
8888 validate_store_type_assumptions([]).
8889 validate_store_type_assumptions([C|Cs]) :-
8890 validate_store_type_assumption(C),
8891 validate_store_type_assumptions(Cs).
8893 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8894 % new code generation
8895 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :-
8896 Rule = rule(H1,_,Guard,Body),
8897 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8898 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0),
8899 flatten(VarsAndSuspsList,VarsAndSusps),
8900 Vars = [ [] | VarsAndSusps],
8901 build_head(F,A,[O|Id],Vars,Head),
8902 ( PrevId0 = [_] ->
8903 get_success_continuation_code_id(F/A,O,PredictedPrevId),
8904 % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]),
8905 PrevId = [PredictedPrevId] % PrevId = PrevId0
8906 ;
8907 PrevId = [O|PrevId0]
8908 ),
8909 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8910 Clause = ( Head :- PredecessorCall),
8911 add_dummy_location(Clause,LocatedClause),
8912 L = [LocatedClause | T].
8913 % ( H1 == [],
8914 % functor(CurrentHead,CF,CA),
8915 % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
8916 % L = T
8917 % ;
8918 % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
8919 % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
8920 % flatten(VarsAndSuspsList,VarsAndSusps),
8921 % Vars = [ [] | VarsAndSusps],
8922 % build_head(F,A,Id,Vars,Head),
8923 % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
8924 % Clause = ( Head :- PredecessorCall),
8925 % L = [Clause | T]
8926 % ).
8928 % skips back intelligently over global_singleton lookups
8929 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
8930 ( Id = [0|_] ->
8931 % TOM: add partial success continuation optimization here!
8932 next_id(Id,PrevId),
8933 PrevVarsAndSusps = BaseCallArgs
8934 ;
8935 VarsAndSuspsList = [_|AllButFirstList],
8936 dec_id(Id,PrevId1),
8937 ( PrevHeads = [PrevHead|PrevHeads1],
8938 functor(PrevHead,F,A),
8939 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
8940 PrevIterators = [_|PrevIterators1],
8941 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
8942 ;
8943 PrevId = PrevId1,
8944 flatten(AllButFirstList,AllButFirst),
8945 PrevIterators = [PrevIterator|_],
8946 PrevVarsAndSusps = [PrevIterator|AllButFirst]
8947 )
8948 ).
8950 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :-
8951 Rule = rule(_,_,Guard,Body),
8952 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
8953 init(AllSusps,PreSusps),
8954 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
8955 gen_var(OtherSusps),
8956 functor(CurrentHead,OtherF,OtherA),
8957 gen_vars(OtherA,OtherVars),
8958 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
8959 get_constraint_mode(OtherF/OtherA,Mode),
8960 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
8962 delay_phase_end(validate_store_type_assumptions,
8963 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
8964 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
8965 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
8966 )
8967 ),
8969 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
8970 % create_get_mutable_ref(active,State,GetMutable),
8971 CurrentSuspTest = (
8972 OtherSusp = OtherSuspension,
8973 GetState,
8974 DiffSuspGoals,
8975 FirstMatching
8976 ),
8977 add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
8978 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
8979 inc_id(Id,NestedId),
8980 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
8981 build_head(F,A,[O|Id],ClauseVars,ClauseHead),
8982 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
8983 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
8984 build_head(F,A,[O|NestedId],NestedVars,NestedHead),
8986 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
8987 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0),
8988 RecursiveVars = PreVarsAndSusps1
8989 ;
8990 RecursiveVars = [OtherSusps|PreVarsAndSusps],
8991 PrevId0 = Id
8992 ),
8993 ( PrevId0 = [_] ->
8994 PrevId = PrevId0
8995 ;
8996 PrevId = [O|PrevId0]
8997 ),
8998 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
9000 Clause = (
9001 ClauseHead :-
9002 ( CurrentSuspTest,
9003 NextSuspGoal
9004 ->
9005 NestedHead
9006 ; RecursiveHead
9007 )
9008 ),
9009 add_dummy_location(Clause,LocatedClause),
9010 L = [LocatedClause|T].
9012 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9014 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9015 % Observation Analysis
9016 %
9017 % CLASSIFICATION
9018 % Enabled
9019 %
9020 % Analysis based on Abstract Interpretation paper.
9021 %
9022 % TODO:
9023 % stronger analysis domain [research]
9025 :- chr_constraint
9026 initial_call_pattern/1,
9027 call_pattern/1,
9028 call_pattern_worker/1,
9029 final_answer_pattern/2,
9030 abstract_constraints/1,
9031 depends_on/2,
9032 depends_on_ap/4,
9033 depends_on_goal/2,
9034 ai_observed_internal/2,
9035 % ai_observed/2,
9036 ai_not_observed_internal/2,
9037 ai_not_observed/2,
9038 ai_is_observed/2,
9039 depends_on_as/3,
9040 ai_observation_gather_results/0.
9042 :- chr_type abstract_domain ---> odom(program_point,list(constraint)).
9043 :- chr_type program_point == any.
9045 :- chr_option(mode,initial_call_pattern(+)).
9046 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9048 :- chr_option(mode,call_pattern(+)).
9049 :- chr_option(type_declaration,call_pattern(abstract_domain)).
9051 :- chr_option(mode,call_pattern_worker(+)).
9052 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
9054 :- chr_option(mode,final_answer_pattern(+,+)).
9055 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
9057 :- chr_option(mode,abstract_constraints(+)).
9058 :- chr_option(type_declaration,abstract_constraints(list)).
9060 :- chr_option(mode,depends_on(+,+)).
9061 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
9063 :- chr_option(mode,depends_on_as(+,+,+)).
9064 :- chr_option(mode,depends_on_ap(+,+,+,+)).
9065 :- chr_option(mode,depends_on_goal(+,+)).
9066 :- chr_option(mode,ai_is_observed(+,+)).
9067 :- chr_option(mode,ai_not_observed(+,+)).
9068 % :- chr_option(mode,ai_observed(+,+)).
9069 :- chr_option(mode,ai_not_observed_internal(+,+)).
9070 :- chr_option(mode,ai_observed_internal(+,+)).
9073 abstract_constraints_fd @
9074 abstract_constraints(_) \ abstract_constraints(_) <=> true.
9076 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9077 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
9078 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
9080 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
9081 ai_is_observed(_,_) <=> true.
9083 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
9084 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
9085 ai_observation_gather_results <=> true.
9087 %------------------------------------------------------------------------------%
9088 % Main Analysis Entry
9089 %------------------------------------------------------------------------------%
9090 ai_observation_analysis(ACs) :-
9091 ( chr_pp_flag(ai_observation_analysis,on),
9092 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
9093 list_to_ord_set(ACs,ACSet),
9094 abstract_constraints(ACSet),
9095 ai_observation_schedule_initial_calls(ACSet,ACSet),
9096 ai_observation_gather_results
9097 ;
9098 true
9099 ).
9101 ai_observation_schedule_initial_calls([],_).
9102 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
9103 ai_observation_schedule_initial_call(AC,ACs),
9104 ai_observation_schedule_initial_calls(RACs,ACs).
9106 ai_observation_schedule_initial_call(AC,ACs) :-
9107 ai_observation_top(AC,CallPattern),
9108 % ai_observation_bot(AC,ACs,CallPattern),
9109 initial_call_pattern(CallPattern).
9111 ai_observation_schedule_new_calls([],AP).
9112 ai_observation_schedule_new_calls([AC|ACs],AP) :-
9113 AP = odom(_,Set),
9114 initial_call_pattern(odom(AC,Set)),
9115 ai_observation_schedule_new_calls(ACs,AP).
9117 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
9118 <=>
9119 ai_observation_leq(AP2,AP1)
9120 |
9121 true.
9123 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
9125 initial_call_pattern(CP) ==> call_pattern(CP).
9127 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
9128 ==>
9129 ai_observation_schedule_new_calls(ACs,AP)
9130 pragma
9131 passive(ID3).
9133 call_pattern(CP) \ call_pattern(CP) <=> true.
9135 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
9136 final_answer_pattern(CP1,AP).
9138 %call_pattern(CP) ==> writeln(call_pattern(CP)).
9140 call_pattern(CP) ==> call_pattern_worker(CP).
9142 %------------------------------------------------------------------------------%
9143 % Abstract Goal
9144 %------------------------------------------------------------------------------%
9146 % AbstractGoala
9147 %call_pattern(odom([],Set)) ==>
9148 % final_answer_pattern(odom([],Set),odom([],Set)).
9150 call_pattern_worker(odom([],Set)) <=>
9151 % writeln(' - AbstractGoal'(odom([],Set))),
9152 final_answer_pattern(odom([],Set),odom([],Set)).
9154 % AbstractGoalb
9155 call_pattern_worker(odom([G|Gs],Set)) <=>
9156 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
9157 CP1 = odom(G,Set),
9158 depends_on_goal(odom([G|Gs],Set),CP1),
9159 call_pattern(CP1).
9161 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
9162 <=> true pragma passive(ID).
9163 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
9164 ==>
9165 CP1 = odom([_|Gs],_),
9166 AP2 = odom([],Set),
9167 CCP = odom(Gs,Set),
9168 call_pattern(CCP),
9169 depends_on(CP1,CCP).
9171 %------------------------------------------------------------------------------%
9172 % Abstract Disjunction
9173 %------------------------------------------------------------------------------%
9175 call_pattern_worker(odom((AG1;AG2),Set)) <=>
9176 CP = odom((AG1;AG2),Set),
9177 InitialAnswerApproximation = odom([],Set),
9178 final_answer_pattern(CP,InitialAnswerApproximation),
9179 CP1 = odom(AG1,Set),
9180 CP2 = odom(AG2,Set),
9181 call_pattern(CP1),
9182 call_pattern(CP2),
9183 depends_on_as(CP,CP1,CP2).
9185 %------------------------------------------------------------------------------%
9186 % Abstract Solve
9187 %------------------------------------------------------------------------------%
9188 call_pattern_worker(odom(builtin,Set)) <=>
9189 % writeln(' - AbstractSolve'(odom(builtin,Set))),
9190 ord_empty(EmptySet),
9191 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
9193 %------------------------------------------------------------------------------%
9194 % Abstract Drop
9195 %------------------------------------------------------------------------------%
9196 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9197 <=>
9198 O > MO
9199 |
9200 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
9201 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9202 pragma
9203 passive(ID2).
9205 %------------------------------------------------------------------------------%
9206 % Abstract Activate
9207 %------------------------------------------------------------------------------%
9208 call_pattern_worker(odom(AC,Set))
9209 <=>
9210 AC = _ / _
9211 |
9212 % writeln(' - AbstractActivate'(odom(AC,Set))),
9213 CP = odom(occ(AC,1),Set),
9214 call_pattern(CP),
9215 depends_on(odom(AC,Set),CP).
9217 %------------------------------------------------------------------------------%
9218 % Abstract Passive
9219 %------------------------------------------------------------------------------%
9220 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9221 <=>
9222 is_passive(RuleNb,ID)
9223 |
9224 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9225 % DEFAULT
9226 NO is O + 1,
9227 DCP = odom(occ(C,NO),Set),
9228 call_pattern(DCP),
9229 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
9230 depends_on(odom(occ(C,O),Set),DCP)
9231 pragma
9232 passive(ID2).
9233 %------------------------------------------------------------------------------%
9234 % Abstract Simplify
9235 %------------------------------------------------------------------------------%
9237 % AbstractSimplify
9238 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9239 <=>
9240 \+ is_passive(RuleNb,ID)
9241 |
9242 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
9243 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
9244 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
9245 ai_observation_memo_abstract_goal(RuleNb,AG),
9246 call_pattern(odom(AG,Set2)),
9247 % DEFAULT
9248 NO is O + 1,
9249 DCP = odom(occ(C,NO),Set),
9250 call_pattern(DCP),
9251 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
9252 % DEADLOCK AVOIDANCE
9253 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
9254 pragma
9255 passive(ID2).
9257 depends_on_as(CP,CPS,CPD),
9258 final_answer_pattern(CPS,APS),
9259 final_answer_pattern(CPD,APD) ==>
9260 ai_observation_lub(APS,APD,AP),
9261 final_answer_pattern(CP,AP).
9264 :- chr_constraint
9265 ai_observation_memo_simplification_rest_heads/3,
9266 ai_observation_memoed_simplification_rest_heads/3.
9268 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
9269 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
9271 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9272 <=>
9273 QRH = RH.
9274 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
9275 <=>
9276 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
9277 once(select2(ID,_,IDs1,H1,_,RestH1)),
9278 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
9279 ai_observation_abstract_constraints(H2,ACs,AH2),
9280 append(ARestHeads,AH2,AbstractHeads),
9281 sort(AbstractHeads,QRH),
9282 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
9283 pragma
9284 passive(ID1),
9285 passive(ID2),
9286 passive(ID3).
9288 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
9290 %------------------------------------------------------------------------------%
9291 % Abstract Propagate
9292 %------------------------------------------------------------------------------%
9295 % AbstractPropagate
9296 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
9297 <=>
9298 \+ is_passive(RuleNb,ID)
9299 |
9300 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
9301 % observe partners
9302 ai_observation_memo_propagation_rest_heads(C,O,AHs),
9303 ai_observation_observe_set(Set,AHs,Set2),
9304 ord_add_element(Set2,C,Set3),
9305 ai_observation_memo_abstract_goal(RuleNb,AG),
9306 call_pattern(odom(AG,Set3)),
9307 ( ord_memberchk(C,Set2) ->
9308 Delete = no
9309 ;
9310 Delete = yes
9311 ),
9312 % DEFAULT
9313 NO is O + 1,
9314 DCP = odom(occ(C,NO),Set),
9315 call_pattern(DCP),
9316 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
9317 pragma
9318 passive(ID2).
9320 :- chr_constraint
9321 ai_observation_memo_propagation_rest_heads/3,
9322 ai_observation_memoed_propagation_rest_heads/3.
9324 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
9325 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
9327 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9328 <=>
9329 QRH = RH.
9330 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
9331 <=>
9332 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
9333 once(select2(ID,_,IDs2,H2,_,RestH2)),
9334 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
9335 ai_observation_abstract_constraints(H1,ACs,AH1),
9336 append(ARestHeads,AH1,AbstractHeads),
9337 sort(AbstractHeads,QRH),
9338 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
9339 pragma
9340 passive(ID1),
9341 passive(ID2),
9342 passive(ID3).
9344 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
9346 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
9347 final_answer_pattern(CP,APD).
9348 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
9349 final_answer_pattern(CPD,APD) ==>
9350 true |
9351 CP = odom(occ(C,O),_),
9352 ( ai_observation_is_observed(APP,C) ->
9353 ai_observed_internal(C,O)
9354 ;
9355 ai_not_observed_internal(C,O)
9356 ),
9357 ( Delete == yes ->
9358 APP = odom([],Set0),
9359 ord_del_element(Set0,C,Set),
9360 NAPP = odom([],Set)
9361 ;
9362 NAPP = APP
9363 ),
9364 ai_observation_lub(NAPP,APD,AP),
9365 final_answer_pattern(CP,AP).
9367 %------------------------------------------------------------------------------%
9368 % Catch All
9369 %------------------------------------------------------------------------------%
9371 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
9373 %------------------------------------------------------------------------------%
9374 % Auxiliary Predicates
9375 %------------------------------------------------------------------------------%
9377 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
9378 ord_intersection(S1,S2,S3).
9380 ai_observation_bot(AG,AS,odom(AG,AS)).
9382 ai_observation_top(AG,odom(AG,EmptyS)) :-
9383 ord_empty(EmptyS).
9385 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
9386 ord_subset(S2,S1).
9388 ai_observation_observe_set(S,ACSet,NS) :-
9389 ord_subtract(S,ACSet,NS).
9391 ai_observation_abstract_constraint(C,ACs,AC) :-
9392 functor(C,F,A),
9393 AC = F/A,
9394 memberchk(AC,ACs).
9396 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
9397 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
9399 %------------------------------------------------------------------------------%
9400 % Abstraction of Rule Bodies
9401 %------------------------------------------------------------------------------%
9403 :- chr_constraint
9404 ai_observation_memoed_abstract_goal/2,
9405 ai_observation_memo_abstract_goal/2.
9407 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
9408 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
9410 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9411 <=>
9412 QAG = AG
9413 pragma
9414 passive(ID1).
9416 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
9417 <=>
9418 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9419 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
9420 QAG = AG,
9421 ai_observation_memoed_abstract_goal(RuleNb,AG)
9422 pragma
9423 passive(ID1),
9424 passive(ID2).
9426 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
9427 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
9428 term_variables((H1,H2,Guard),HVars),
9429 append(H1,H2,Heads),
9430 % variables that are declared to be ground are safe,
9431 ground_vars(Heads,GroundVars),
9432 % so we remove them from the list of 'dangerous' head variables
9433 list_difference_eq(HVars,GroundVars,HV),
9434 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
9435 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
9436 % HV are 'dangerous' variables, all others are fresh and safe
9438 ground_vars([],[]).
9439 ground_vars([H|Hs],GroundVars) :-
9440 functor(H,F,A),
9441 get_constraint_mode(F/A,Mode),
9442 % TOM: fix this code!
9443 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
9444 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
9445 ground_vars(Hs,GroundVars2),
9446 append(GroundVars1,GroundVars2,GroundVars).
9448 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
9449 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9450 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9451 ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction
9452 ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV),
9453 ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV).
9454 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
9455 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
9456 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
9457 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
9458 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
9459 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
9460 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
9461 % non-CHR constraint is safe if it only binds fresh variables
9462 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
9463 builtin_binds_b(G,Vars),
9464 intersect_eq(Vars,HV,[]),
9465 !.
9466 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
9467 AG = builtin. % default case if goal is not recognized/safe
9469 ai_observation_is_observed(odom(_,ACSet),AC) :-
9470 \+ ord_memberchk(AC,ACSet).
9472 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9473 unconditional_occurrence(C,O) :-
9474 get_occurrence(C,O,RuleNb,ID),
9475 get_rule(RuleNb,PRule),
9476 PRule = pragma(ORule,_,_,_,_),
9477 copy_term_nat(ORule,Rule),
9478 Rule = rule(H1,H2,Guard,_),
9479 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
9480 once((
9481 H1 = [Head], H2 == []
9482 ;
9483 H2 = [Head], H1 == [], \+ may_trigger(C)
9484 )),
9485 all_distinct_var_args(Head).
9487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9489 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9490 % Partial wake analysis
9491 %
9492 % In a Var = Var unification do not wake up constraints of both variables,
9493 % but rather only those of one variable.
9494 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
9496 :- chr_constraint partial_wake_analysis/0.
9497 :- chr_constraint no_partial_wake/1.
9498 :- chr_option(mode,no_partial_wake(+)).
9499 :- chr_constraint wakes_partially/1.
9500 :- chr_option(mode,wakes_partially(+)).
9502 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
9503 ==>
9504 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
9505 ( is_passive(RuleNb,ID) ->
9506 true
9507 ; Type == simplification ->
9508 select(H,H1,RestH1),
9509 H =.. [_|Args],
9510 term_variables(Guard,Vars),
9511 partial_wake_args(Args,ArgModes,Vars,FA)
9512 ; % Type == propagation ->
9513 select(H,H2,RestH2),
9514 H =.. [_|Args],
9515 term_variables(Guard,Vars),
9516 partial_wake_args(Args,ArgModes,Vars,FA)
9517 ).
9519 partial_wake_args([],_,_,_).
9520 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
9521 ( Mode \== (+) ->
9522 ( nonvar(Arg) ->
9523 no_partial_wake(C)
9524 ; memberchk_eq(Arg,Vars) ->
9525 no_partial_wake(C)
9526 ;
9527 true
9528 )
9529 ;
9530 true
9531 ),
9532 partial_wake_args(Args,Modes,Vars,C).
9534 no_partial_wake(C) \ no_partial_wake(C) <=> true.
9536 no_partial_wake(C) \ wakes_partially(C) <=> fail.
9538 wakes_partially(C) <=> true.
9541 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9542 % Generate rules that implement chr_show_store/1 functionality.
9543 %
9544 % CLASSIFICATION
9545 % Experimental
9546 % Unused
9547 %
9548 % Generates additional rules:
9549 %
9550 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
9551 % ...
9552 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
9553 % $show <=> true.
9555 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
9556 ( chr_pp_flag(show,on) ->
9557 Constraints = ['$show'/0|Constraints0],
9558 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
9559 inc_rule_count(RuleNb),
9560 Rule = pragma(
9561 rule(['$show'],[],true,true),
9562 ids([0],[]),
9563 [],
9564 no,
9565 RuleNb
9566 )
9567 ;
9568 Constraints = Constraints0,
9569 Rules = Rules0
9570 ).
9572 generate_show_rules([],Rules,Rules).
9573 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
9574 functor(C,F,A),
9575 inc_rule_count(RuleNb),
9576 Rule = pragma(
9577 rule([],['$show',C],true,writeln(C)),
9578 ids([],[0,1]),
9579 [passive(1)],
9580 no,
9581 RuleNb
9582 ),
9583 generate_show_rules(Rest,Tail,Rules).
9585 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9586 % Custom supension term layout
9588 static_suspension_term(F/A,Suspension) :-
9589 suspension_term_base(F/A,Base),
9590 Arity is Base + A,
9591 functor(Suspension,suspension,Arity).
9593 has_suspension_field(FA,Field) :-
9594 suspension_term_base_fields(FA,Fields),
9595 memberchk(Field,Fields).
9597 suspension_term_base(FA,Base) :-
9598 suspension_term_base_fields(FA,Fields),
9599 length(Fields,Base).
9601 suspension_term_base_fields(FA,Fields) :-
9602 ( chr_pp_flag(debugable,on) ->
9603 % 1. ID
9604 % 2. State
9605 % 3. Propagation History
9606 % 4. Generation Number
9607 % 5. Continuation Goal
9608 % 6. Functor
9609 Fields = [id,state,history,generation,continuation,functor]
9610 ;
9611 ( uses_history(FA) ->
9612 Fields = [id,state,history|Fields2]
9613 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
9614 Fields = [state|Fields2]
9615 ;
9616 Fields = [id,state|Fields2]
9617 ),
9618 ( only_ground_indexed_arguments(FA) ->
9619 get_store_type(FA,StoreType),
9620 basic_store_types(StoreType,BasicStoreTypes),
9621 ( memberchk(global_ground,BasicStoreTypes) ->
9622 % 1. ID
9623 % 2. State
9624 % 3. Propagation History
9625 % 4. Global List Prev
9626 Fields2 = [global_list_prev|Fields3]
9627 ;
9628 % 1. ID
9629 % 2. State
9630 % 3. Propagation History
9631 Fields2 = Fields3
9632 ),
9633 ( chr_pp_flag(ht_removal,on)
9634 -> ht_prev_fields(BasicStoreTypes,Fields3)
9635 ; Fields3 = []
9636 )
9637 ; may_trigger(FA) ->
9638 % 1. ID
9639 % 2. State
9640 % 3. Propagation History
9641 ( uses_field(FA,generation) ->
9642 % 4. Generation Number
9643 % 5. Global List Prev
9644 Fields2 = [generation,global_list_prev|Fields3]
9645 ;
9646 Fields2 = [global_list_prev|Fields3]
9647 ),
9648 ( chr_pp_flag(mixed_stores,on),
9649 chr_pp_flag(ht_removal,on)
9650 -> get_store_type(FA,StoreType),
9651 basic_store_types(StoreType,BasicStoreTypes),
9652 ht_prev_fields(BasicStoreTypes,Fields3)
9653 ; Fields3 = []
9654 )
9655 ;
9656 % 1. ID
9657 % 2. State
9658 % 3. Propagation History
9659 % 4. Global List Prev
9660 Fields2 = [global_list_prev|Fields3],
9661 ( chr_pp_flag(mixed_stores,on),
9662 chr_pp_flag(ht_removal,on)
9663 -> get_store_type(FA,StoreType),
9664 basic_store_types(StoreType,BasicStoreTypes),
9665 ht_prev_fields(BasicStoreTypes,Fields3)
9666 ; Fields3 = []
9667 )
9668 )
9669 ).
9671 ht_prev_fields(Stores,Prevs) :-
9672 ht_prev_fields_int(Stores,PrevsList),
9673 append(PrevsList,Prevs).
9674 ht_prev_fields_int([],[]).
9675 ht_prev_fields_int([H|T],Fields) :-
9676 ( H = multi_hash(Indexes)
9677 -> maplist(ht_prev_field,Indexes,FH),
9678 Fields = [FH|FT]
9679 ; Fields = FT
9680 ),
9681 ht_prev_fields_int(T,FT).
9683 ht_prev_field(Index,Field) :-
9684 concat_atom(['multi_hash_prev-'|Index],Field).
9686 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
9687 suspension_term_base_fields(FA,Fields),
9688 nth1(Index,Fields,FieldName), !,
9689 arg(Index,StaticSuspension,Field).
9690 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
9691 suspension_term_base(FA,Base),
9692 StaticSuspension =.. [_|Args],
9693 drop(Base,Args,Field).
9694 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
9695 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
9698 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9699 suspension_term_base_fields(FA,Fields),
9700 nth1(Index,Fields,FieldName), !,
9701 Goal = arg(Index,DynamicSuspension,Field).
9702 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
9703 static_suspension_term(FA,StaticSuspension),
9704 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
9705 Goal = (DynamicSuspension = StaticSuspension).
9706 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
9707 suspension_term_base(FA,Base),
9708 Index is I + Base,
9709 Goal = arg(Index,DynamicSuspension,Field).
9710 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9711 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
9714 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
9715 suspension_term_base_fields(FA,Fields),
9716 nth1(Index,Fields,FieldName), !,
9717 Goal = setarg(Index,DynamicSuspension,Field).
9718 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
9719 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
9721 basic_store_types(multi_store(Types),Types) :- !.
9722 basic_store_types(Type,[Type]).
9724 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9725 %
9727 :- chr_constraint
9728 phase_end/1,
9729 delay_phase_end/2.
9731 :- chr_option(mode,phase_end(+)).
9732 :- chr_option(mode,delay_phase_end(+,?)).
9734 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
9735 % phase_end(Phase) <=> true.
9738 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9739 :- chr_constraint
9740 does_use_history/2,
9741 uses_history/1,
9742 novel_production_call/4.
9744 :- chr_option(mode,uses_history(+)).
9745 :- chr_option(mode,does_use_history(+,+)).
9746 :- chr_option(mode,novel_production_call(+,+,?,?)).
9748 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
9749 does_use_history(FA,_) \ uses_history(FA) <=> true.
9750 uses_history(_FA) <=> fail.
9752 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
9753 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
9755 :- chr_constraint
9756 does_use_field/2,
9757 uses_field/2.
9759 :- chr_option(mode,uses_field(+,+)).
9760 :- chr_option(mode,does_use_field(+,+)).
9762 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
9763 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
9764 uses_field(_FA,_Field) <=> fail.
9766 :- chr_constraint
9767 uses_state/2,
9768 if_used_state/5,
9769 used_states_known/0.
9771 :- chr_option(mode,uses_state(+,+)).
9772 :- chr_option(mode,if_used_state(+,+,?,?,?)).
9775 % states ::= not_stored_yet | passive | active | triggered | removed
9776 %
9777 % allocate CREATES not_stored_yet
9778 % remove CHECKS not_stored_yet
9779 % activate CHECKS not_stored_yet
9780 %
9781 % ==> no allocate THEN no not_stored_yet
9783 % recurs CREATES inactive
9784 % lookup CHECKS inactive
9786 % insert CREATES active
9787 % activate CREATES active
9788 % lookup CHECKS active
9789 % recurs CHECKS active
9791 % runsusp CREATES triggered
9792 % lookup CHECKS triggered
9793 %
9794 % ==> no runsusp THEN no triggered
9796 % remove CREATES removed
9797 % runsusp CHECKS removed
9798 % lookup CHECKS removed
9799 % recurs CHECKS removed
9800 %
9801 % ==> no remove THEN no removed
9803 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
9805 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
9807 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9808 <=> ResultGoal = Used.
9809 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
9810 <=> ResultGoal = NotUsed.
9812 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
9813 % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES
9814 % (Feature for SSS)
9815 %
9816 % 1. Checking
9817 % ~~~~~~~~~~~
9818 %
9819 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9820 %
9821 % :- chr_option(declare_stored_constraints,on).
9822 %
9823 % the compiler will check for the storedness of constraints.
9824 %
9825 % By default, the compiler assumes that the programmer wants his constraints to
9826 % be never-stored. Hence, a warning will be issues when a constraint is actually
9827 % stored.
9828 %
9829 % Such warnings are suppressed, if the programmer adds the `# stored' modifier
9830 % to a constraint declaration, i.e. writes
9831 %
9832 % :- chr_constraint c(...) # stored.
9833 %
9834 % In that case a warning is issued when the constraint is never-stored.
9835 %
9836 % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all
9837 % constraints are stored anyway.
9838 %
9839 %
9840 % 2. Rule Generation
9841 % ~~~~~~~~~~~~~~~~~~
9842 %
9843 % When the programmer enables the `declare_stored_constraints' option, i.e. writes
9844 %
9845 % :- chr_option(declare_stored_constraints,on).
9846 %
9847 % the compiler will generate default simplification rules for constraints.
9848 %
9849 % By default, no default rule is generated for a constraint. However, if the
9850 % programmer writes a default/1 annotation in the constraint declaration, i.e. writes
9851 %
9852 % :- chr_constraint c(...) # default(Goal).
9853 %
9854 % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'),
9855 % the compiler generates a rule:
9856 %
9857 % c(_,...,_) <=> Goal.
9858 %
9859 % at the end of the program. If multiple default rules are generated, for several constraints,
9860 % then the order of the default rules is not specified.
9863 :- chr_constraint stored_assertion/1.
9864 :- chr_option(mode,stored_assertion(+)).
9865 :- chr_option(type_declaration,stored_assertion(constraint)).
9867 :- chr_constraint never_stored_default/2.
9868 :- chr_option(mode,never_stored_default(+,?)).
9869 :- chr_option(type_declaration,never_stored_default(constraint,any)).
9871 % Rule Generation
9872 % ~~~~~~~~~~~~~~~
9874 generate_never_stored_rules(Constraints,Rules) :-
9875 ( chr_pp_flag(declare_stored_constraints,on) ->
9876 never_stored_rules(Constraints,Rules)
9877 ;
9878 Rules = []
9879 ).
9881 :- chr_constraint never_stored_rules/2.
9882 :- chr_option(mode,never_stored_rules(+,?)).
9883 :- chr_option(type_declaration,never_stored_rules(list(constraint),any)).
9885 never_stored_rules([],Rules) <=> Rules = [].
9886 never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=>
9887 Constraint = F/A,
9888 functor(Head,F,A),
9889 inc_rule_count(RuleNb),
9890 Rule = pragma(
9891 rule([Head],[],true,Goal),
9892 ids([0],[]),
9893 [],
9894 no,
9895 RuleNb
9896 ),
9897 Rules = [Rule|Tail],
9898 never_stored_rules(Constraints,Tail).
9899 never_stored_rules([_|Constraints],Rules) <=>
9900 never_stored_rules(Constraints,Rules).
9902 % Checking
9903 % ~~~~~~~~
9905 check_storedness_assertions(Constraints) :-
9906 ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) ->
9907 forall(Constraint,Constraints,check_storedness_assertion(Constraint))
9908 ;
9909 true
9910 ).
9913 :- chr_constraint check_storedness_assertion/1.
9914 :- chr_option(mode,check_storedness_assertion(+)).
9915 :- chr_option(type_declaration,check_storedness_assertion(constraint)).
9917 check_storedness_assertion(Constraint), stored_assertion(Constraint)
9918 <=> ( is_stored(Constraint) ->
9919 true
9920 ;
9921 chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint])
9922 ).
9923 never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint)
9924 <=> ( is_finally_stored(Constraint) ->
9925 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9926 ; is_stored(Constraint) ->
9927 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9928 ;
9929 true
9930 ).
9931 % never-stored, no default goal
9932 check_storedness_assertion(Constraint)
9933 <=> ( is_finally_stored(Constraint) ->
9934 chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint])
9935 ; is_stored(Constraint) ->
9936 chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint])
9937 ;
9938 true
9939 ).
9941 %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
9942 % success continuation analysis
9944 % TODO
9945 % also use for forward jumping improvement!
9946 % use Prolog indexing for generated code
9947 %
9948 % EXPORTED
9949 %
9950 % should_skip_to_next_id(C,O)
9951 %
9952 % get_occurrence_code_id(C,O,Id)
9953 %
9954 %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
9956 continuation_analysis(ConstraintSymbols) :-
9957 maplist(analyse_continuations,ConstraintSymbols).
9959 analyse_continuations(C) :-
9960 % 1. compute success continuations of the
9961 % occurrences of constraint C
9962 continuation_analysis(C,1),
9963 % 2. determine for which occurrences
9964 % to skip to next code id
9965 get_max_occurrence(C,MO),
9966 LO is MO + 1,
9967 bulk_propagation(C,1,LO),
9968 % 3. determine code id for each occurrence
9969 set_occurrence_code_id(C,1,0).
9971 % 1. Compute the success continuations of constrait C
9972 %-------------------------------------------------------------------------------
9974 continuation_analysis(C,O) :-
9975 get_max_occurrence(C,MO),
9976 ( O > MO ->
9977 true
9978 ; O == MO ->
9979 NextO is O + 1,
9980 continuation_occurrence(C,O,NextO)
9981 ;
9982 constraint_continuation(C,O,MO,NextO),
9983 continuation_occurrence(C,O,NextO),
9984 NO is O + 1,
9985 continuation_analysis(C,NO)
9986 ).
9988 constraint_continuation(C,O,MO,NextO) :-
9989 ( get_occurrence_head(C,O,Head) ->
9990 NO is O + 1,
9991 ( between(NO,MO,NextO),
9992 get_occurrence_head(C,NextO,NextHead),
9993 unifiable(Head,NextHead,_) ->
9994 true
9995 ;
9996 NextO is MO + 1
9997 )
9998 ; % current occurrence is passive
9999 NextO = MO
10000 ).
10002 get_occurrence_head(C,O,Head) :-
10003 get_occurrence(C,O,RuleNb,Id),
10004 \+ is_passive(RuleNb,Id),
10005 get_rule(RuleNb,Rule),
10006 Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_),
10007 ( select2(Id,Head,Ids1,H1,_,_) -> true
10008 ; select2(Id,Head,Ids2,H2,_,_)
10009 ).
10011 :- chr_constraint continuation_occurrence/3.
10012 :- chr_option(mode,continuation_occurrence(+,+,+)).
10014 :- chr_constraint get_success_continuation_occurrence/3.
10015 :- chr_option(mode,get_success_continuation_occurrence(+,+,-)).
10017 continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X)
10018 <=>
10019 X = NO.
10021 get_success_continuation_occurrence(C,O,X)
10022 <=>
10023 chr_error(internal,'Success continuation not found for ~w.\n',[C:O]).
10025 % 2. figure out when to skip to next code id
10026 %-------------------------------------------------------------------------------
10027 % don't go beyond the last occurrence
10028 % we have to go to next id for storage here
10030 :- chr_constraint skip_to_next_id/2.
10031 :- chr_option(mode,skip_to_next_id(+,+)).
10033 :- chr_constraint should_skip_to_next_id/2.
10034 :- chr_option(mode,should_skip_to_next_id(+,+)).
10036 skip_to_next_id(C,O) \ should_skip_to_next_id(C,O)
10037 <=>
10038 true.
10040 should_skip_to_next_id(_,_)
10041 <=>
10042 fail.
10044 :- chr_constraint bulk_propagation/3.
10045 :- chr_option(mode,bulk_propagation(+,+,+)).
10047 max_occurrence(C,MO) \ bulk_propagation(C,O,_)
10048 <=>
10049 O >= MO
10050 |
10051 skip_to_next_id(C,O).
10052 % we have to go to the next id here because
10053 % a predecessor needs it
10054 bulk_propagation(C,O,LO)
10055 <=>
10056 LO =:= O + 1
10057 |
10058 skip_to_next_id(C,O),
10059 get_max_occurrence(C,MO),
10060 NLO is MO + 1,
10061 bulk_propagation(C,LO,NLO).
10062 % we have to go to the next id here because
10063 % we're running into a simplification rule
10064 % IMPROVE: propagate back to propagation predecessor (IF ANY)
10065 occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO)
10066 <=>
10067 NO =:= O + 1
10068 |
10069 skip_to_next_id(C,O),
10070 get_max_occurrence(C,MO),
10071 NLO is MO + 1,
10072 bulk_propagation(C,NO,NLO).
10073 % we skip the next id here
10074 % and go to the next occurrence
10075 continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO)
10076 <=>
10077 NextO > O + 1
10078 |
10079 NLO is min(LO,NextO),
10080 NO is O + 1,
10081 bulk_propagation(C,NO,NLO).
10082 % default case
10083 % err on the safe side
10084 bulk_propagation(C,O,LO)
10085 <=>
10086 skip_to_next_id(C,O),
10087 get_max_occurrence(C,MO),
10088 NLO is MO + 1,
10089 NO is O + 1,
10090 bulk_propagation(C,NO,NLO).
10092 skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true.
10094 % if this occurrence is passive, but has to skip,
10095 % then the previous one must skip instead...
10096 % IMPROVE reasoning is conservative
10097 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O)
10098 ==>
10099 O > 1
10100 |
10101 PO is O - 1,
10102 skip_to_next_id(C,PO).
10104 % 3. determine code id of each occurrence
10105 %-------------------------------------------------------------------------------
10107 :- chr_constraint set_occurrence_code_id/3.
10108 :- chr_option(mode,set_occurrence_code_id(+,+,+)).
10110 :- chr_constraint occurrence_code_id/3.
10111 :- chr_option(mode,occurrence_code_id(+,+,+)).
10113 % stop at the end
10114 set_occurrence_code_id(C,O,IdNb)
10115 <=>
10116 get_max_occurrence(C,MO),
10117 O > MO
10118 |
10119 occurrence_code_id(C,O,IdNb).
10121 % passive occurrences don't change the code id
10122 occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb)
10123 <=>
10124 occurrence_code_id(C,O,IdNb),
10125 NO is O + 1,
10126 set_occurrence_code_id(C,NO,IdNb).
10128 occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb)
10129 <=>
10130 occurrence_code_id(C,O,IdNb),
10131 NO is O + 1,
10132 set_occurrence_code_id(C,NO,IdNb).
10134 occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb)
10135 <=>
10136 occurrence_code_id(C,O,IdNb),
10137 NO is O + 1,
10138 NIdNb is IdNb + 1,
10139 set_occurrence_code_id(C,NO,NIdNb).
10141 occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb)
10142 <=>
10143 occurrence_code_id(C,O,IdNb),
10144 NO is O + 1,
10145 set_occurrence_code_id(C,NO,IdNb).
10147 % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)).
10149 :- chr_constraint get_occurrence_code_id/3.
10150 :- chr_option(mode,get_occurrence_code_id(+,+,-)).
10152 occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X)
10153 <=>
10154 X = IdNb.
10156 get_occurrence_code_id(C,O,X)
10157 <=>
10158 ( O == 0 ->
10159 true % X = 0
10160 ;
10161 format('no occurrence code for ~w!\n',[C:O])
10162 ).
10164 get_success_continuation_code_id(C,O,NextId) :-
10165 get_success_continuation_occurrence(C,O,NextO),
10166 get_occurrence_code_id(C,NextO,NextId).
10168 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10169 % COLLECT CONSTANTS FOR INLINING
10170 %
10171 % for SSS
10173 % collect_constants(+rules,+constraint_symbols,+clauses) {{{
10174 collect_constants(Rules,Constraints,Clauses0) :-
10175 ( not_restarted ->
10176 maplist(collect_rule_constants(Constraints),Rules),
10177 ( chr_pp_flag(verbose,on) ->
10178 print_chr_constants
10179 ;
10180 true
10181 ),
10182 ( chr_pp_flag(experiment,on) ->
10183 flattening_dictionary(Constraints,Dictionary),
10184 copy_term_nat(Clauses0,Clauses),
10185 flatten_clauses(Clauses,Dictionary,FlatClauses),
10186 install_new_declarations_and_restart(FlatClauses)
10187 ;
10188 true
10189 )
10190 ;
10191 true
10192 ).
10194 :- chr_constraint chr_constants/2.
10195 :- chr_option(mode,chr_constants(+,+)).
10197 :- chr_constraint get_chr_constants/2.
10199 chr_constants(Key,Constants) \ get_chr_constants(Key,Q) <=> Q = Constants.
10201 get_chr_constants(Key,Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = [].
10203 % collect_rule_constants(+constraint_symbols,+rule) {{{
10204 collect_rule_constants(Constraints,Rule) :-
10205 Rule = pragma(rule(H1,H2,_,B),_,_,_,_),
10206 maplist(collect_head_constants,H1),
10207 maplist(collect_head_constants,H2),
10208 collect_body_constants(B,Constraints).
10210 collect_body_constants(Body,Constraints) :-
10211 conj2list(Body,Goals),
10212 maplist(collect_goal_constants(Constraints),Goals).
10214 collect_goal_constants(Constraints,Goal) :-
10215 ( nonvar(Goal),
10216 functor(Goal,C,N),
10217 memberchk(C/N,Constraints) ->
10218 collect_head_constants(Goal)
10219 ; nonvar(Goal),
10220 Goal = Mod : TheGoal,
10221 get_target_module(Module),
10222 Mod == Module,
10223 nonvar(TheGoal),
10224 functor(TheGoal,C,N),
10225 memberchk(C/N,Constraints) ->
10226 collect_head_constants(TheGoal)
10227 ;
10228 true
10229 ).
10231 collect_head_constants(Head) :-
10232 functor(Head,C,N),
10233 get_constraint_type_det(C/N,Types),
10234 Head =.. [_|Args],
10235 maplist(collect_arg_constants,Args,Types).
10237 collect_arg_constants(Arg,Type) :-
10238 ( ground(Arg),
10239 unalias_type(Type,NormalType),
10240 is_chr_constants_type(NormalType,Key,_) ->
10241 add_chr_constant(Key,Arg)
10242 ;
10243 true
10244 ).
10245 :- chr_constraint add_chr_constant/2.
10246 :- chr_option(mode,add_chr_constant(+,+)).
10248 add_chr_constant(Key,Constant) , chr_constants(Key,Constants) <=>
10249 sort([Constant|Constants],NConstants),
10250 chr_constants(Key,NConstants).
10252 add_chr_constant(Key,Constant) <=>
10253 chr_constants(Key,[Constant]).
10255 % }}}
10257 :- chr_constraint print_chr_constants/0. % {{{
10259 print_chr_constants, chr_constants(Key,Constants) # Id ==>
10260 format('\t* chr_constants ~w : ~w.\n',[Key,Constants])
10261 pragma passive(Id).
10263 print_chr_constants <=>
10264 true.
10266 % }}}
10268 % flattening_dictionary(+constraint_symbols,-dictionary) {{{
10269 flattening_dictionary([],[]).
10270 flattening_dictionary([CS|CSs],Dictionary) :-
10271 ( flattening_dictionary_entry(CS,Entry) ->
10272 Dictionary = [Entry|Rest]
10273 ;
10274 Dictionary = Rest
10275 ),
10276 flattening_dictionary(CSs,Rest).
10278 flattening_dictionary_entry(CS,Entry) :-
10279 get_constraint_arg_type(CS,Pos,Type),
10280 ( is_chr_constants_type(Type,Key,MaybeErrorHandler) ->
10281 get_chr_constants(Key,Constants)
10282 ; Type = chr_enum(Constants) ->
10283 MaybeErrorHandler = no
10284 ),
10285 Entry = CS-Pos-Specs-MaybeErrorHandler,
10286 maplist(flat_spec(CS,Pos),Constants,Specs).
10288 flat_spec(C/N,Pos,Term,Spec) :-
10289 Spec = Term - Functor,
10290 term_to_atom(Term,TermAtom),
10291 atom_concat_list(['$flat_',C,'/',N,'___',Pos,'___',TermAtom],Functor).
10292 % }}}
10294 % }}}
10295 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10296 % RESTART AFTER FLATTENING {{{
10298 restart_after_flattening(Declarations,Declarations) :-
10299 nb_setval('$chr_restart_after_flattening',started).
10300 restart_after_flattening(_,Declarations) :-
10301 nb_getval('$chr_restart_after_flattening',restart(Declarations)),
10302 nb_setval('$chr_restart_after_flattening',restarted).
10304 not_restarted :-
10305 nb_getval('$chr_restart_after_flattening',started).
10307 install_new_declarations_and_restart(Declarations) :-
10308 nb_setval('$chr_restart_after_flattening',restart(Declarations)),
10309 fail. /* fails to choicepoint of restart_after_flattening */
10310 % }}}
10311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10312 % FLATTENING {{{
10314 % DONE
10315 % -) generate dictionary from collected chr_constants
10316 % enable with :- chr_option(experiment,on).
10317 % -) issue constraint declarations for constraints not present in
10318 % dictionary
10319 %
10320 % TODO:
10321 % -) integrate with CHR compiler
10322 % RELEASE-----------------------------------------------------------------
10323 % -) pass Mike's test code (full syntactic support for current CHR code)
10324 % -) rewrite the body using the inliner
10325 % -) refined semantics correctness issue
10326 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10328 flatten_clauses(Clauses,Dict,NClauses) :-
10329 flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses),
10330 flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses).
10332 flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :-
10333 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0),
10334 dispatching_rules(Dict,NClauses1),
10335 declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2),
10336 flatten_rules(Clauses,Dict,NClauses3),
10337 append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses).
10339 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10340 % Declarations for non-flattened constraints
10342 % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{
10343 declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :-
10344 findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols),
10345 maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList),
10346 flatten(DeclarationsList,Declarations).
10348 declaration(ModeDecls,TypeDecls,ConstraintSymbol,
10349 [(:- chr_constraint ConstraintSymbol),
10350 (:- chr_option(mode,ModeDeclPattern)),
10351 (:- chr_option(type_declaration,TypeDeclPattern))
10352 ]) :-
10353 ConstraintSymbol = Functor / Arity,
10354 % print optional mode declaration
10355 functor(ModeDeclPattern,Functor,Arity),
10356 ( memberchk(ModeDeclPattern,ModeDecls) ->
10357 true
10358 ;
10359 replicate(Arity,(?),Modes),
10360 ModeDeclPattern =.. [_|Modes]
10361 ),
10362 % print optional type declaration
10363 functor(TypeDeclPattern,Functor,Arity),
10364 ( memberchk(TypeDeclPattern,TypeDecls) ->
10365 true
10366 ;
10367 replicate(Arity,any,Types),
10368 TypeDeclPattern =.. [_|Types]
10369 ).
10370 % }}}
10371 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10372 % read clauses from file
10373 % CHR are returned
10374 % declared constaints are returned
10375 % type definitions are returned and printed
10376 % mode declarations are returned
10377 % other clauses are returned
10379 % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{
10380 flatten_readcontent([],[],[],[],[],[],[]).
10381 flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :-
10382 % read(Clause),
10383 ( Clause == end_of_file ->
10384 Rules = [],
10385 ConstraintSymbols = [],
10386 ModeDecls = [],
10387 TypeDecls = [],
10388 TypeDefs = [],
10389 RestClauses = []
10390 ; crude_is_rule(Clause) ->
10391 Rules = [Clause|RestRules],
10392 flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses)
10393 ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) ->
10394 append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols),
10395 append(SomeModeDecls,RestModeDecls,ModeDecls),
10396 append(SomeTypeDecls,RestTypeDecls,TypeDecls),
10397 flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10398 ; is_mode_declaration(Clause,ModeDecl) ->
10399 ModeDecls = [ModeDecl|RestModeDecls],
10400 flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses)
10401 ; is_type_declaration(Clause,TypeDecl) ->
10402 TypeDecls = [TypeDecl|RestTypeDecls],
10403 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses)
10404 ; is_type_definition(Clause,TypeDef) ->
10405 RestClauses = [Clause|NRestClauses],
10406 TypeDefs = [TypeDef|RestTypeDefs],
10407 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses)
10408 ; ( Clause = (:- op(A,B,C)) ->
10409 % assert operators in order to read and print them out properly
10410 op(A,B,C)
10411 ;
10412 true
10413 ),
10414 RestClauses = [Clause|NRestClauses],
10415 flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses)
10416 ).
10418 crude_is_rule(_ @ _).
10419 crude_is_rule(_ pragma _).
10420 crude_is_rule(_ ==> _).
10421 crude_is_rule(_ <=> _).
10423 pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration
10424 D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint),
10425 conj2list(Cs,Constraints0),
10426 pure_extract_type_mode(Constraints0,Constraints,Modes,Types).
10428 pure_extract_type_mode([],[],[],[]).
10429 pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !,
10430 pure_extract_type_mode(R,R2,Modes,Types).
10431 pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :-
10432 functor(C,F,A),
10433 ConstraintSymbol = F/A,
10434 C =.. [_|Args],
10435 extract_types_and_modes(Args,ArgTypes,ArgModes),
10436 Mode =.. [F|ArgModes],
10437 ( forall(member(ArgType,ArgTypes),ArgType == any) ->
10438 Types = RTypes
10439 ;
10440 Types = [Type|RTypes],
10441 Type =.. [F|ArgTypes]
10442 ),
10443 pure_extract_type_mode(R,R2,Modes,RTypes).
10445 is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl).
10447 is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl).
10448 % }}}
10449 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10450 % DECLARATIONS FOR FLATTENED CONSTRAINTS
10451 % including mode and type declarations
10453 % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{
10454 auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :-
10455 findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0),
10456 flatten(ConstraintSpecs0,ConstraintSpecs).
10458 auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,
10459 [(:- chr_constraint ConstraintSpec),
10460 (:- chr_option(mode,NewModeDecl)),
10461 (:- chr_option(type_declaration,NewTypeDecl))]) :-
10462 member(C/N-I-SFs-_,Dict),
10463 arg_modes(C,N,ModeDecls,Modes),
10464 specialize_modes(Modes,I,SpecializedModes),
10465 arg_types(C,N,TypeDecls,Types),
10466 specialize_types(Types,I,SpecializedTypes),
10467 AN is N - 1,
10468 member(_Term-F,SFs),
10469 ConstraintSpec = F/AN,
10470 NewModeDecl =.. [F|SpecializedModes],
10471 NewTypeDecl =.. [F|SpecializedTypes].
10473 arg_modes(C,N,ModeDecls,ArgModes) :-
10474 functor(ConstraintPattern,C,N),
10475 ( memberchk(ConstraintPattern,ModeDecls) ->
10476 ConstraintPattern =.. [_|ArgModes]
10477 ;
10478 replicate(N,?,ArgModes)
10479 ).
10481 specialize_modes(Modes,I,SpecializedModes) :-
10482 split(Modes,I,Before,_At,After),
10483 append(Before,After,SpecializedModes).
10485 arg_types(C,N,TypeDecls,ArgTypes) :-
10486 functor(ConstraintPattern,C,N),
10487 ( memberchk(ConstraintPattern,TypeDecls) ->
10488 ConstraintPattern =.. [_|ArgTypes]
10489 ;
10490 replicate(N,any,ArgTypes)
10491 ).
10493 specialize_types(Types,I,SpecializedTypes) :-
10494 split(Types,I,Before,_At,After),
10495 append(Before,After,SpecializedTypes).
10496 % }}}
10498 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10499 % DISPATCHING RULES
10500 %
10501 % dispatching_rules(+dict,-newrules)
10504 % {{{
10506 % This code generates a decision tree for calling the appropriate specialized
10507 % constraint based on the particular value of the argument the constraint
10508 % is being specialized on.
10509 %
10510 % In case an error handler is provided, the handler is called with the
10511 % unexpected constraint.
10513 dispatching_rules([],[]).
10514 dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :-
10515 constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules),
10516 dispatching_rules(Dict,RestDispatchingRules).
10518 constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :-
10519 ( I == 1 ->
10520 /* index on first argument */
10521 Rules0 = Rules,
10522 NCN = C/N
10523 ;
10524 /* reorder arguments for 1st argument indexing */
10525 functor(Head,C,N),
10526 Head =.. [_|Args],
10527 split(Args,I,BeforeArgs,IndexArg,AfterArgs),
10528 append([IndexArg|BeforeArgs],AfterArgs,ShuffledArgs),
10529 atom_concat(C,'_$shuffled',NC),
10530 Body =.. [NC|ShuffledArgs],
10531 [(Head :- Body)|Rules0] = Rules,
10532 NCN = NC / N
10533 ),
10534 Context = swap(C,I),
10535 dispatching_rule_term_cases(SFs,NCN,MaybeErrorHandler,Context,Rules0,RestRules).
10537 dispatching_rule_term_cases(SFs,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :-
10538 once(pairup(Terms,Functors,SFs)),
10539 length(Terms,K),
10540 replicate(K,[],MorePatterns),
10541 Payload is N - 1,
10542 maplist(wrap_in_functor(dispatching_action),Functors,Actions),
10543 dispatch_trie_index([Terms|MorePatterns],Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules).
10545 dispatching_action(Functor,PayloadArgs,Goal) :-
10546 Goal =.. [Functor|PayloadArgs].
10548 dispatch_trie_index([Patterns|MorePatterns],Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :-
10549 dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail).
10551 dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !.
10552 % length MorePatterns == length Patterns == length Results
10553 dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :-
10554 MorePatterns = [List|_],
10555 length(List,N),
10556 aggregate_all(set(F/A),
10557 ( member(Pattern,Patterns),
10558 functor(Pattern,F,A)
10559 ),
10560 FAs),
10561 N1 is N + 1,
10562 dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T).
10564 dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :-
10565 ( MaybeErrorHandler = yes(ErrorHandler) ->
10566 Clauses0 = [ErrorClause|Clauses],
10567 ErrorClause = (Head :- Body),
10568 Arity is N + Payload,
10569 functor(Head,Symbol,Arity),
10570 reconstruct_original_term(Context,Head,Term),
10571 Body =.. [ErrorHandler,Term]
10572 ;
10573 Clauses0 = Clauses
10574 ).
10575 dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :-
10576 dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1),
10577 dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail).
10579 dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :-
10580 Clause = (Head :- Cut, Body),
10581 ( MaybeErrorHandler = yes(_) ->
10582 Cut = (!)
10583 ;
10584 Cut = true
10585 ),
10586 /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */
10587 N1 is N + Payload,
10588 functor(Head,Symbol,N1),
10589 arg(1,Head,IndexPattern),
10590 Head =.. [_,_|RestArgs],
10591 length(PayloadArgs,Payload),
10592 once(append(Vs,PayloadArgs,RestArgs)),
10593 /* IndexPattern = F(...) */
10594 functor(IndexPattern,F,A),
10595 Context1 = index_functor(F,A,Context0),
10596 IndexPattern =.. [_|Args],
10597 append(Args,RestArgs,RecArgs),
10598 ( RecArgs == PayloadArgs ->
10599 /* nothing more to match on */
10600 List = Tail,
10601 rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions),
10602 MoreActions = [Action],
10603 call(Action,PayloadArgs,Body)
10604 ; /* more things to match on */
10605 rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions),
10606 ( MoreActions = [OneMoreAction] ->
10607 /* only one more thing to match on */
10608 List = Tail,
10609 call(OneMoreAction,PayloadArgs,Body)
10610 ;
10611 /* more than one thing to match on */
10612 /* [ x1,..., xn]
10613 [xs1,...,xsn]
10614 */
10615 pairup(Cases,MoreCases,CasePairs),
10616 common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences),
10617 append(Args,Vs,[First|Rest]),
10618 First-Rest = CommonPatternPair,
10619 Context2 = gct(Vs,Context1),
10620 gensym(Prefix,RSymbol),
10621 append(DiffVars,PayloadArgs,RecCallVars),
10622 Body =.. [RSymbol|RecCallVars],
10623 findall(CH-CT,member([CH|CT],Differences),CPairs),
10624 once(pairup(CHs,CTs,CPairs)),
10625 dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail)
10626 )
10627 ).
10630 % split(list,int,before,at,after).
10632 split([X|Xs],I,Before,At,After) :-
10633 ( I == 1 ->
10634 Before = [],
10635 At = X,
10636 After = Xs
10637 ;
10638 J is I - 1,
10639 Before = [X|RBefore],
10640 split(Xs,J,RBefore,At,After)
10641 ).
10643 % reconstruct_original_term(Context,CurrentTerm,OriginalTerm)
10644 %
10645 % context ::= swap(functor,position)
10646 % | index_functor(functor,arity,context)
10647 % | gct(Pattern,Context)
10649 reconstruct_original_term(swap(Functor,Position),Term,OriginalTerm) :-
10650 Term =.. [_,IndexArg|Args],
10651 PrefixSize is Position - 1,
10652 split_at(PrefixSize,Args,Prefix,Suffix),
10653 append(Prefix,[IndexArg|Suffix],OriginalArgs),
10654 OriginalTerm =.. [Functor|OriginalArgs].
10655 reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :-
10656 Term0 =.. [Predicate|Args],
10657 split_at(Arity,Args,IndexArgs,RestArgs),
10658 Index =.. [Functor|IndexArgs],
10659 Term1 =.. [Predicate,Index|RestArgs],
10660 reconstruct_original_term(Context,Term1,OriginalTerm).
10661 reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :-
10662 copy_term_nat(PatternList,IndexTerms),
10663 term_variables(IndexTerms,Variables),
10664 Term0 =.. [Predicate|Args0],
10665 append(Variables,RestArgs,Args0),
10666 append(IndexTerms,RestArgs,Args1),
10667 Term1 =.. [Predicate|Args1],
10668 reconstruct_original_term(Context,Term1,OriginalTerm).
10669 % }}}
10670 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
10671 % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS
10672 %
10673 % flatten_rules(+rule_clauses,+dict,-rule_clauses).
10674 %
10675 % dict :== list(functor/arity-int-list(term-functor)-maybe(error_handler))
10677 % {{{
10678 flatten_rules(Rules,Dict,FlatRules) :-
10679 flatten_rules1(Rules,Dict,FlatRulesList),
10680 flatten(FlatRulesList,FlatRules).
10682 flatten_rules1([],_,[]).
10683 flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :-
10684 findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules),
10685 flatten_rules1(Rules,Dict,FlatRulesList).
10687 flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !,
10688 flatten_rule(Rule,Dict,NRule).
10689 flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !,
10690 flatten_rule(Rule,Dict,NRule).
10691 flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !,
10692 flatten_heads(H,Dict,NH),
10693 flatten_body(B,Dict,NB).
10694 flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !,
10695 flatten_heads((H1,H2),Dict,(NH1,NH2)),
10696 flatten_body(B,Dict,NB).
10697 flatten_rule((H <=> B),Dict,(NH <=> NB)) :-
10698 flatten_heads(H,Dict,NH),
10699 flatten_body(B,Dict,NB).
10701 flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !,
10702 flatten_heads(H1,Dict,NH1),
10703 flatten_heads(H2,Dict,NH2).
10704 flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !,
10705 flatten_heads(H,Dict,NH).
10706 flatten_heads(H,Dict,NH) :-
10707 ( functor(H,C,N),
10708 memberchk(C/N-I-SFs-_,Dict) ->
10709 H =.. [_|AllArgs],
10710 split(AllArgs,I,PreArgs,Arg,PostArgs),
10711 member(Term-Name,SFs),
10712 Arg = Term,
10713 append(PreArgs,PostArgs,FlatArgs),
10714 NH =.. [Name|FlatArgs]
10715 ;
10716 NH = H
10717 ).
10719 flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !,
10720 conj2list(Guard,Guards),
10721 maplist(flatten_goal(Dict),Guards,NGuards),
10722 list2conj(NGuards,NGuard),
10723 conj2list(Body,Goals),
10724 maplist(flatten_goal(Dict),Goals,NGoals),
10725 list2conj(NGoals,NBody).
10726 flatten_body(Body,Dict,NBody) :-
10727 conj2list(Body,Goals),
10728 maplist(flatten_goal(Dict),Goals,NGoals),
10729 list2conj(NGoals,NBody).
10731 flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal.
10732 flatten_goal(Dict,Goal,NGoal) :-
10733 ( is_specializable_goal(Goal,Dict,ArgPos)
10734 ->
10735 specialize_goal(Goal,ArgPos,NGoal)
10736 ; Goal = Mod : TheGoal,
10737 get_target_module(Module),
10738 Mod == Module,
10739 nonvar(TheGoal),
10740 is_specializable_goal(TheGoal,Dict,ArgPos)
10741 ->
10742 specialize_goal(TheGoal,ArgPos,NTheGoal),
10743 NGoal = Mod : NTheGoal
10744 ; partial_eval(Goal,NGoal)
10745 ->
10746 true
10747 ;
10748 NGoal = Goal
10749 ).
10751 is_specializable_goal(Goal,Dict,ArgPos) :-
10752 functor(Goal,C,N),
10753 memberchk(C/N-ArgPos-_-_,Dict),
10754 arg(ArgPos,Goal,Arg),
10755 ground(Arg).
10758 specialize_goal(Goal,ArgPos,NGoal) :-
10759 functor(Goal,C,N),
10760 Goal =.. [_|Args],
10761 split(Args,ArgPos,Before,Arg,After),
10762 append(Before,After,NArgs),
10763 flat_spec(C/N,ArgPos,Arg,_-Functor),
10764 NGoal =.. [Functor|NArgs].
10766 partial_eval(append(L1,L2,L3),NGoal) :-
10767 ( L1 == [] ->
10768 NGoal = (L3 = L2)
10769 ; L2 == [] ->
10770 NGoal = (L3 = L1)
10771 ).
10772 partial_eval(flatten_path(L1,L2),NGoal) :-
10773 nonvar(L1),
10774 flatten(L1,FlatterL1),
10775 FlatterL1 \== L1 ->
10776 NGoal = flatten_path(FlatterL1,L2).
10779 % }}}
10781 % }}}
10782 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
10783 dump_code(Clauses) :-
10784 ( chr_pp_flag(dump,on) ->
10785 maplist(portray_clause,Clauses)
10786 ;
10787 true
10788 ).
10790 chr_banner :-
10791 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',[]).