| blob | 2d65e97c86028f545f7e53e0571dae464b4c19da |
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 %% URGENTLY TODO
52 %%
53 %% * add groundness info to a.i.-based observation analysis
54 %% * proper fd/index analysis
55 %% * re-add generation checking
56 %% * untangle CHR-level and traget source-level generation & optimization
57 %%
58 %% AGGRESSIVE OPTIMISATION IDEAS
59 %%
60 %% * continuation optimization
61 %% * analyze history usage to determine whether/when
62 %% cheaper suspension is possible
63 %% * store constraint unconditionally for unconditional propagation rule,
64 %% if first, i.e. without checking history and set trigger cont to next occ
65 %% * get rid of suspension passing for never triggered constraints,
66 %% up to allocation occurrence
67 %% * get rid of call indirection for never triggered constraints
68 %% up to first allocation occurrence.
69 %% * get rid of unnecessary indirection if last active occurrence
70 %% before unconditional removal is head2, e.g.
71 %% a \ b <=> true.
72 %% a <=> true.
73 %% * Eliminate last clause of never stored constraint, if its body
74 %% is fail.
75 %% * Specialize lookup operations and indexes for functional dependencies.
76 %%
77 %% MORE TODO
78 %%
79 %% * generate code to empty all constraint stores of a module (Bart Demoen)
80 %% * variable suspension: only look upto necessary depth and necessary number
81 %% of arguments into term (Thom Fruehwirth: global constraints)
82 %% * ground matching seems to be not optimized for compound terms
83 %% in case of simpagation_head2 and propagation occurrences
84 %% * Do not unnecessarily generate store operations.
85 %% * further specialize runtime predicates for special cases where
86 %% - none of the constraints contain any indexing variables, ...
87 %% - just one constraint requires some runtime predicate
88 %% * analysis for storage delaying (see primes for case)
89 %% * internal constraints declaration + analyses?
90 %% * Do not store in global variable store if not necessary
91 %% NOTE: affects show_store/1
92 %% * multi-level store: variable - ground
93 %% * Do not maintain/check unnecessary propagation history
94 %% for rules that cannot be applied more than once
95 %% for reasons of anti-monotony
96 %% * Strengthen storage analysis for propagation rules
97 %% reason about bodies of rules only containing constraints
98 %% -> fixpoint with overservation analysis
99 %% * SICStus compatibility
100 %% - options
101 %% - pragmas
102 %% - tell guard
103 %% * instantiation declarations
104 %% POTENTIAL GAIN:
105 %% VARIABLE (never bound)
106 %%
107 %% * make difference between cheap guards for reordering
108 %% and non-binding guards for lock removal
109 %% * unqiue -> once/[] transformation for propagation
110 %% * cheap guards interleaved with head retrieval + faster
111 %% via-retrieval + non-empty checking for propagation rules
112 %% redo for simpagation_head2 prelude
113 %% * intelligent backtracking for simplification/simpagation rule
114 %% generator_1(X),'_$savecp'(CP_1),
115 %% ...
116 %% if( (
117 %% generator_n(Y),
118 %% test(X,Y)
119 %% ),
120 %% true,
121 %% ('_$cutto'(CP_1), fail)
122 %% ),
123 %% ...
124 %%
125 %% or recently developped cascading-supported approach
126 %% * intelligent backtracking for propagation rule
127 %% use additional boolean argument for each possible smart backtracking
128 %% when boolean at end of list true -> no smart backtracking
129 %% false -> smart backtracking
130 %% only works for rules with at least 3 constraints in the head
131 %% * (set semantics + functional dependency) declaration + resolution
132 %%
133 %%
134 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
135 %% merged
136 %%
137 %% * map A \ B <=> true | true rules
138 %% onto efficient code that empties the constraint stores of B
139 %% in O(1) time for ground constraints where A and B do not share
140 %% any variables
141 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
142 :- module(chr_translate,
143 [ chr_translate/2 % +Decls, -TranslatedDecls
144 ]).
145 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
146 :- use_module(hprolog).
148 %% SICStus begin
149 %% :- use_module(library(lists),[memberchk/2,is_list/1]).
150 %% SICStus end
153 %% for release 4 SICStus begin
154 %% :- use_module(library(samsort)).
155 %% for release 4 SICStus end
157 :- use_module(pairlist).
158 :- use_module(library(ordsets)).
159 :- use_module(a_star).
160 :- use_module(listmap).
161 :- use_module(clean_code).
162 :- use_module(builtins).
163 :- use_module(find).
164 :- use_module(guard_entailment).
165 :- use_module(chr_compiler_options).
166 :- use_module(chr_compiler_utility).
167 :- use_module(chr_compiler_errors).
168 :- include(chr_op).
169 :- op(1150, fx, chr_type).
170 :- op(1130, xfx, --->).
171 :- op(980, fx, (+)).
172 :- op(980, fx, (-)).
173 :- op(980, fx, (?)).
174 :- op(1150, fx, constraints).
175 :- op(1150, fx, chr_constraint).
177 :- chr_option(debug,off).
178 :- chr_option(optimize,full).
180 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
181 :- chr_constraint
182 target_module/1, % target_module(Module)
183 get_target_module/1,
185 indexed_argument/2, % argument instantiation may enable applicability of rule
186 is_indexed_argument/2,
188 constraint_mode/2,
189 get_constraint_mode/2,
191 may_trigger/1,
192 only_ground_indexed_arguments/1,
193 none_suspended_on_variables/0,
194 are_none_suspended_on_variables/0,
196 store_type/2,
197 get_store_type/2,
198 update_store_type/2,
199 actual_store_types/2,
200 assumed_store_type/2,
201 validate_store_type_assumption/1,
203 rule_count/1,
204 inc_rule_count/1,
206 passive/2,
207 is_passive/2,
208 any_passive_head/1,
210 new_occurrence/3,
211 occurrence/4,
212 get_occurrence/4,
214 max_occurrence/2,
215 get_max_occurrence/2,
217 allocation_occurrence/2,
218 get_allocation_occurrence/2,
219 rule/2,
220 get_rule/2,
221 least_occurrence/2,
222 is_least_occurrence/1
223 .
225 :- chr_option(check_guard_bindings,off).
227 :- chr_option(mode,target_module(+)).
228 :- chr_option(mode,indexed_argument(+,+)).
229 :- chr_option(mode,constraint_mode(+,+)).
230 :- chr_option(mode,may_trigger(+)).
231 :- chr_option(mode,store_type(+,+)).
232 :- chr_option(mode,actual_store_types(+,+)).
233 :- chr_option(mode,assumed_store_type(+,+)).
234 :- chr_option(mode,rule_count(+)).
235 :- chr_option(mode,passive(+,+)).
236 :- chr_option(mode,occurrence(+,+,+,+)).
237 :- chr_option(mode,max_occurrence(+,+)).
238 :- chr_option(mode,allocation_occurrence(+,+)).
239 :- chr_option(mode,rule(+,+)).
240 :- chr_option(mode,least_occurrence(+,+)).
241 :- chr_option(mode,is_least_occurrence(+)).
243 :- chr_option(type_definition,type(list,[ [], [any|list] ])).
244 :- chr_option(type_definition,type(constraint,[ any / any ])).
246 :- chr_option(type_declaration,constraint_mode(constraint,list)).
248 target_module(_) \ target_module(_) <=> true.
249 target_module(Mod) \ get_target_module(Query)
250 <=> Query = Mod .
251 get_target_module(Query)
252 <=> Query = user.
254 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
255 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
256 is_indexed_argument(_,_) <=> fail.
258 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
260 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
261 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
262 Q = Mode.
263 get_constraint_mode(FA,Q) <=>
264 FA = _ / N,
265 replicate(N,(?),Q).
267 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
269 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
270 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
271 nth1(I,Mode,M),
272 M \== (+) |
273 is_stored(FA).
274 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
276 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
277 <=>
278 nth1(I,Mode,M),
279 M \== (+)
280 |
281 fail.
282 only_ground_indexed_arguments(_) <=>
283 true.
285 none_suspended_on_variables \ none_suspended_on_variables <=> true.
286 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
287 are_none_suspended_on_variables <=> fail.
288 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
290 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
291 store_type(FA,Store) \ get_store_type(FA,Query)
292 <=> Query = Store.
293 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
294 <=> Query = Store.
295 get_store_type(_,Query)
296 <=> Query = default.
298 actual_store_types(C,STs) \ update_store_type(C,ST)
299 <=> member(ST,STs) | true.
300 update_store_type(C,ST), actual_store_types(C,STs)
301 <=>
302 actual_store_types(C,[ST|STs]).
303 update_store_type(C,ST)
304 <=>
305 actual_store_types(C,[ST]).
307 % refine store type assumption
308 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
309 <=>
310 store_type(C,multi_store(STs)).
311 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
312 <=>
313 store_type(C,multi_store(STs)).
314 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
315 <=> store_type(C,global_ground).
316 validate_store_type_assumption(C)
317 <=> true.
319 rule_count(C), inc_rule_count(NC)
320 <=> NC is C + 1, rule_count(NC).
321 inc_rule_count(NC)
322 <=> NC = 1, rule_count(NC).
324 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
325 passive(R,ID) \ passive(R,ID) <=> true.
327 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
328 is_passive(_,_) <=> fail.
330 passive(RuleNb,_) \ any_passive_head(RuleNb)
331 <=> true.
332 any_passive_head(_)
333 <=> fail.
334 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
336 max_occurrence(C,N) \ max_occurrence(C,M)
337 <=> N >= M | true.
339 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID) <=>
340 NO is MO + 1,
341 occurrence(C,NO,RuleNb,ID),
342 max_occurrence(C,NO).
343 new_occurrence(C,RuleNb,ID) <=>
344 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
346 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
347 <=> Q = MON.
348 get_max_occurrence(C,Q)
349 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
351 occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
352 <=> Rule = QRule, ID = QID.
353 get_occurrence(C,O,_,_)
354 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[]).
356 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
358 % cannot store constraint at passive occurrence
359 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
360 <=> NO is O + 1, allocation_occurrence(C,NO).
361 % need not store constraint that is removed
362 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
363 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
364 | NO is O + 1, allocation_occurrence(C,NO).
365 % need not store constraint when body is true
366 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
367 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
368 | NO is O + 1, allocation_occurrence(C,NO).
369 % need not store constraint if does not observe itself
370 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
371 <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
372 | NO is O + 1, allocation_occurrence(C,NO).
373 % need not store constraint if does not observe itself and cannot trigger
374 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_), least_occurrence(RuleNb,[])
375 \ allocation_occurrence(C,O)
376 <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
377 | NO is O + 1, allocation_occurrence(C,NO).
379 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID), allocation_occurrence(C,AO)
380 \ least_occurrence(RuleNb,[ID|IDs])
381 <=> AO >= O, \+ may_trigger(C) |
382 least_occurrence(RuleNb,IDs).
383 rule(RuleNb,Rule), passive(RuleNb,ID)
384 \ least_occurrence(RuleNb,[ID|IDs])
385 <=> least_occurrence(RuleNb,IDs).
387 rule(RuleNb,Rule)
388 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
389 least_occurrence(RuleNb,IDs).
391 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
392 <=> true.
393 is_least_occurrence(_)
394 <=> fail.
396 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
397 <=> Q = O.
398 get_allocation_occurrence(_,Q)
399 <=> chr_pp_flag(late_allocation,off), Q=0.
400 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
402 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
403 <=> Q = Rule.
404 get_rule(_,_)
405 <=> fail.
407 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
409 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
410 :- chr_constraint
411 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
412 get_constraint_index/2,
413 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
414 get_max_constraint_index/1.
416 :- chr_option(mode,constraint_index(+,+)).
417 :- chr_option(mode,max_constraint_index(+)).
419 constraint_index(C,Index) \ get_constraint_index(C,Query)
420 <=> Query = Index.
421 get_constraint_index(C,Query)
422 <=> fail.
424 max_constraint_index(Index) \ get_max_constraint_index(Query)
425 <=> Query = Index.
426 get_max_constraint_index(Query)
427 <=> Query = 0.
429 set_constraint_indices(Constraints) :-
430 set_constraint_indices(Constraints,1).
431 set_constraint_indices([],M) :-
432 N is M - 1,
433 max_constraint_index(N).
434 set_constraint_indices([C|Cs],N) :-
435 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C) ; is_stored(C), get_store_type(C,default)) ->
436 constraint_index(C,N),
437 M is N + 1,
438 set_constraint_indices(Cs,M)
439 ;
440 set_constraint_indices(Cs,N)
441 ).
443 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
448 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
449 %%
450 %% Translation
452 chr_translate(Declarations,NewDeclarations) :-
453 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',[]),
454 init_chr_pp_flags,
455 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
456 check_declared_constraints(Constraints0),
457 generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
458 add_constraints(Constraints),
459 add_rules(Rules),
460 % start analysis
461 check_rules(Rules,Constraints),
462 add_occurrences(Rules),
463 functional_dependency_analysis(Rules),
464 set_semantics_rules(Rules),
465 symmetry_analysis(Rules),
466 guard_simplification,
467 storage_analysis(Constraints),
468 observation_analysis(Constraints),
469 ai_observation_analysis(Constraints),
470 late_allocation_analysis(Constraints),
471 assume_constraint_stores(Constraints),
472 set_constraint_indices(Constraints),
473 % end analysis
474 constraints_code(Constraints,ConstraintClauses),
475 validate_store_type_assumptions(Constraints),
476 store_management_preds(Constraints,StoreClauses), % depends on actual code used
477 insert_declarations(OtherClauses, Clauses0),
478 chr_module_declaration(CHRModuleDeclaration),
479 append([Clauses0,
480 StoreClauses,
481 ConstraintClauses,
482 CHRModuleDeclaration,
483 [end_of_file]
484 ],
485 NewDeclarations).
487 store_management_preds(Constraints,Clauses) :-
488 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
489 generate_indexed_variables_clauses(Constraints,IndexedClauses),
490 generate_attach_increment(AttachIncrementClauses),
491 generate_attr_unify_hook(AttrUnifyHookClauses),
492 generate_extra_clauses(Constraints,ExtraClauses),
493 generate_insert_delete_constraints(Constraints,DeleteClauses),
494 generate_attach_code(Constraints,StoreClauses),
495 generate_counter_code(CounterClauses),
496 append([AttachAConstraintClauses
497 ,IndexedClauses
498 ,AttachIncrementClauses
499 ,AttrUnifyHookClauses
500 ,ExtraClauses
501 ,DeleteClauses
502 ,StoreClauses
503 ,CounterClauses
504 ]
505 ,Clauses).
507 %% SWI begin
508 extra_declaration([ :- use_module(chr(chr_runtime))
509 , :- use_module(chr(chr_hashtable_store))
510 , :- use_module(chr(chr_integertable_store))
511 , :- use_module(library('clp/clp_events'))
512 ]).
513 %% SWI end
515 %% SICStus begin
516 %% extra_declaration([(:- use_module(library('chr/hprolog'),[term_variables/3]))]).
517 %% SICStus end
521 insert_declarations(Clauses0, Clauses) :-
522 extra_declaration(Decls),
523 append(Clauses0, Decls, Clauses).
525 generate_counter_code(Clauses) :-
526 ( chr_pp_flag(store_counter,on) ->
527 Clauses = [
528 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
529 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
530 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
531 (:- '$counter_init'('$insert_counter')),
532 (:- '$counter_init'('$delete_counter')),
533 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
534 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
535 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
536 ]
537 ;
538 Clauses = []
539 ).
541 % for systems with multifile declaration
542 chr_module_declaration(CHRModuleDeclaration) :-
543 get_target_module(Mod),
544 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
545 CHRModuleDeclaration = [
546 (:- multifile chr:'$chr_module'/1),
547 chr:'$chr_module'(Mod)
548 ]
549 ;
550 CHRModuleDeclaration = []
551 ).
554 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
555 %%
556 %% Partitioning of clauses into constraint declarations, chr rules and other
557 %% clauses
559 partition_clauses([],[],[],[]).
560 partition_clauses([C|Cs],Ds,Rs,OCs) :-
561 ( parse_rule(C,R) ->
562 Ds = RDs,
563 Rs = [R | RRs],
564 OCs = ROCs
565 ; is_declaration(C,D) ->
566 append(D,RDs,Ds),
567 Rs = RRs,
568 OCs = ROCs
569 ; is_module_declaration(C,Mod) ->
570 target_module(Mod),
571 Ds = RDs,
572 Rs = RRs,
573 OCs = [C|ROCs]
574 ; is_type_definition(C) ->
575 Ds = RDs,
576 Rs = RRs,
577 OCs = ROCs
578 ; C = (handler _) ->
579 chr_warning(deprecated(C),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
580 Ds = RDs,
581 Rs = RRs,
582 OCs = ROCs
583 ; C = (rules _) ->
584 chr_warning(deprecated(C),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
585 Ds = RDs,
586 Rs = RRs,
587 OCs = ROCs
588 ; C = option(OptionName,OptionValue) ->
589 chr_warning(deprecated(C),'Instead use :- chr_option(~w,~w).\n',[OptionName,OptionValue]),
590 handle_option(OptionName,OptionValue),
591 Ds = RDs,
592 Rs = RRs,
593 OCs = ROCs
594 ; C = (:- chr_option(OptionName,OptionValue)) ->
595 handle_option(OptionName,OptionValue),
596 Ds = RDs,
597 Rs = RRs,
598 OCs = ROCs
599 ; Ds = RDs,
600 Rs = RRs,
601 OCs = [C|ROCs]
602 ),
603 partition_clauses(Cs,RDs,RRs,ROCs).
605 is_declaration(D, Constraints) :- %% constraint declaration
606 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
607 conj2list(Cs,Constraints0)
608 ;
609 ( D = (:- Decl) ->
610 Decl =.. [constraints,Cs]
611 ;
612 D =.. [constraints,Cs]
613 ),
614 conj2list(Cs,Constraints0),
615 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
616 ),
617 extract_type_mode(Constraints0,Constraints).
619 extract_type_mode([],[]).
620 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
621 extract_type_mode([C|R],[C2|R2]) :-
622 functor(C,F,A),C2=F/A,
623 C =.. [_|Args],
624 extract_types_and_modes(Args,ArgTypes,ArgModes),
625 constraint_type(F/A,ArgTypes),
626 constraint_mode(F/A,ArgModes),
627 extract_type_mode(R,R2).
629 extract_types_and_modes([],[],[]).
630 extract_types_and_modes([+(T)|R],[T|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
631 extract_types_and_modes([?(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
632 extract_types_and_modes([-(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
633 extract_types_and_modes([(+)|R],[any|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
634 extract_types_and_modes([(?)|R],[any|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
635 extract_types_and_modes([(-)|R],[any|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
636 extract_types_and_modes([Illegal|R],_,_) :-
637 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
639 is_type_definition(D) :-
640 ( D = (:- TDef) ->
641 true
642 ;
643 D = TDef
644 ),
645 TDef =.. [chr_type,TypeDef],
646 ( TypeDef = (Name ---> Def) ->
647 tdisj2list(Def,DefList),
648 type_definition(Name,DefList)
649 ;
650 ( TypeDef = (Alias == Name) ->
651 type_alias(Alias,Name)
652 ;
653 chr_warning(syntax,'Illegal type definition "~w".\n\tIgnoring this malformed type definition.\n',[TypeDef])
654 )
655 ).
657 % no removal of fails, e.g. :- type bool ---> true ; fail.
658 tdisj2list(Conj,L) :-
659 tdisj2list(Conj,L,[]).
660 tdisj2list(Conj,L,T) :-
661 Conj = (G1;G2), !,
662 tdisj2list(G1,L,T1),
663 tdisj2list(G2,T1,T).
664 tdisj2list(G,[G | T],T).
667 %% Data Declaration
668 %%
669 %% pragma_rule
670 %% -> pragma(
671 %% rule,
672 %% ids,
673 %% list(pragma),
674 %% yesno(string), :: maybe rule nane
675 %% int :: rule number
676 %% )
677 %%
678 %% ids -> ids(
679 %% list(int),
680 %% list(int)
681 %% )
682 %%
683 %% rule -> rule(
684 %% list(constraint), :: constraints to be removed
685 %% list(constraint), :: surviving constraints
686 %% goal, :: guard
687 %% goal :: body
688 %% )
690 parse_rule(RI,R) :- %% name @ rule
691 RI = (Name @ RI2), !,
692 rule(RI2,yes(Name),R).
693 parse_rule(RI,R) :-
694 rule(RI,no,R).
696 rule(RI,Name,R) :-
697 RI = (RI2 pragma P), !, %% pragmas
698 ( var(P) ->
699 Ps = [_] % intercept variable
700 ;
701 conj2list(P,Ps)
702 ),
703 inc_rule_count(RuleCount),
704 R = pragma(R1,IDs,Ps,Name,RuleCount),
705 is_rule(RI2,R1,IDs,R).
706 rule(RI,Name,R) :-
707 inc_rule_count(RuleCount),
708 R = pragma(R1,IDs,[],Name,RuleCount),
709 is_rule(RI,R1,IDs,R).
712 is_rule(RI,R,IDs,RC) :- %% propagation rule
713 RI = (H ==> B), !,
714 conj2list(H,Head2i),
715 get_ids(Head2i,IDs2,Head2,RC),
716 IDs = ids([],IDs2),
717 ( B = (G | RB) ->
718 R = rule([],Head2,G,RB)
719 ;
720 R = rule([],Head2,true,B)
721 ).
722 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
723 RI = (H <=> B), !,
724 ( B = (G | RB) ->
725 Guard = G,
726 Body = RB
727 ; Guard = true,
728 Body = B
729 ),
730 ( H = (H1 \ H2) ->
731 conj2list(H1,Head2i),
732 conj2list(H2,Head1i),
733 get_ids(Head2i,IDs2,Head2,0,N,RC),
734 get_ids(Head1i,IDs1,Head1,N,_,RC),
735 IDs = ids(IDs1,IDs2)
736 ; conj2list(H,Head1i),
737 Head2 = [],
738 get_ids(Head1i,IDs1,Head1,RC),
739 IDs = ids(IDs1,[])
740 ),
741 R = rule(Head1,Head2,Guard,Body).
743 get_ids(Cs,IDs,NCs,RC) :-
744 get_ids(Cs,IDs,NCs,0,_,RC).
746 get_ids([],[],[],N,N,_).
747 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
748 ( C = (NC # N1) ->
749 (var(N1) ->
750 N1 = N
751 ;
752 check_direct_pragma(N1,N,RC)
753 )
754 ;
755 NC = C
756 ),
757 M is N + 1,
758 get_ids(Cs,IDs,NCs, M,NN,RC).
760 direct_pragma(passive).
761 check_direct_pragma(passive,N,R) :-
762 R = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), passive(RuleNb,N).
763 check_direct_pragma(Abbrev,N,RC) :-
764 (direct_pragma(X),
765 atom_concat(Abbrev,Remainder,X) ->
766 chr_warning(problem_pragma(Abbrev,RC),'completed "~w" to "~w"\n',[Abbrev,X])
767 ;
768 chr_warning(unsupported_pragma(Abbrev,RC),'',[])
769 ).
772 is_module_declaration((:- module(Mod)),Mod).
773 is_module_declaration((:- module(Mod,_)),Mod).
775 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
777 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
778 % Add constraints
779 add_constraints([]).
780 add_constraints([C|Cs]) :-
781 max_occurrence(C,0),
782 C = _/A,
783 length(Mode,A),
784 set_elems(Mode,?),
785 constraint_mode(C,Mode),
786 add_constraints(Cs).
788 % Add rules
789 add_rules([]).
790 add_rules([Rule|Rules]) :-
791 Rule = pragma(_,_,_,_,RuleNb),
792 rule(RuleNb,Rule),
793 add_rules(Rules).
795 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
798 %% Some input verification:
800 check_declared_constraints(Constraints) :-
801 check_declared_constraints(Constraints,[]).
803 check_declared_constraints([],_).
804 check_declared_constraints([C|Cs],Acc) :-
805 ( memberchk_eq(C,Acc) ->
806 chr_error(syntax(C),'Constraint ~w multiply defined.\n\tRemove redundant declaration!\n',[C])
807 ;
808 true
809 ),
810 check_declared_constraints(Cs,[C|Acc]).
812 %% - all constraints in heads are declared constraints
813 %% - all passive pragmas refer to actual head constraints
815 check_rules([],_).
816 check_rules([PragmaRule|Rest],Decls) :-
817 check_rule(PragmaRule,Decls),
818 check_rules(Rest,Decls).
820 check_rule(PragmaRule,Decls) :-
821 check_rule_indexing(PragmaRule),
822 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
823 Rule = rule(H1,H2,_,_),
824 append(H1,H2,HeadConstraints),
825 check_head_constraints(HeadConstraints,Decls,PragmaRule),
826 check_pragmas(Pragmas,PragmaRule).
828 check_head_constraints([],_,_).
829 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
830 functor(Constr,F,A),
831 ( member(F/A,Decls) ->
832 check_head_constraints(Rest,Decls,PragmaRule)
833 ;
834 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ).
836 check_pragmas([],_).
837 check_pragmas([Pragma|Pragmas],PragmaRule) :-
838 check_pragma(Pragma,PragmaRule),
839 check_pragmas(Pragmas,PragmaRule).
841 check_pragma(Pragma,PragmaRule) :-
842 var(Pragma), !,
843 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
844 check_pragma(passive(ID), PragmaRule) :-
845 !,
846 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
847 ( memberchk_eq(ID,IDs1) ->
848 true
849 ; memberchk_eq(ID,IDs2) ->
850 true
851 ;
852 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
853 ),
854 passive(RuleNb,ID).
856 check_pragma(Pragma, PragmaRule) :-
857 Pragma = already_in_heads,
858 !,
859 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
861 check_pragma(Pragma, PragmaRule) :-
862 Pragma = already_in_head(_),
863 !,
864 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
866 check_pragma(Pragma,PragmaRule) :-
867 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
869 format_rule(PragmaRule) :-
870 PragmaRule = pragma(_,_,_,MaybeName,N),
871 ( MaybeName = yes(Name) ->
872 write('rule '), write(Name)
873 ;
874 write('rule number '), write(N)
875 ).
877 check_rule_indexing(PragmaRule) :-
878 PragmaRule = pragma(Rule,_,_,_,_),
879 Rule = rule(H1,H2,G,_),
880 term_variables(H1-H2,HeadVars),
881 remove_anti_monotonic_guards(G,HeadVars,NG),
882 check_indexing(H1,NG-H2),
883 check_indexing(H2,NG-H1),
884 % EXPERIMENT
885 ( chr_pp_flag(term_indexing,on) ->
886 term_variables(G,GuardVariables),
887 append(H1,H2,Heads),
888 check_specs_indexing(Heads,GuardVariables,Specs)
889 ;
890 true
891 ).
893 :- chr_constraint
894 indexing_spec/2,
895 get_indexing_spec/2.
897 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
898 get_indexing_spec(_,Spec) <=> Spec = [].
900 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
901 <=>
902 append(Specs1,Specs2,Specs),
903 indexing_spec(FA,Specs).
905 remove_anti_monotonic_guards(G,Vars,NG) :-
906 conj2list(G,GL),
907 remove_anti_monotonic_guard_list(GL,Vars,NGL),
908 list2conj(NGL,NG).
910 remove_anti_monotonic_guard_list([],_,[]).
911 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
912 ( G = var(X),
913 memberchk_eq(X,Vars) ->
914 NGs = RGs
915 ;
916 NGs = [G|RGs]
917 ),
918 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
920 check_indexing([],_).
921 check_indexing([Head|Heads],Other) :-
922 functor(Head,F,A),
923 Head =.. [_|Args],
924 term_variables(Heads-Other,OtherVars),
925 check_indexing(Args,1,F/A,OtherVars),
926 check_indexing(Heads,[Head|Other]).
928 check_indexing([],_,_,_).
929 check_indexing([Arg|Args],I,FA,OtherVars) :-
930 ( is_indexed_argument(FA,I) ->
931 true
932 ; nonvar(Arg) ->
933 indexed_argument(FA,I)
934 ; % var(Arg) ->
935 term_variables(Args,ArgsVars),
936 append(ArgsVars,OtherVars,RestVars),
937 ( memberchk_eq(Arg,RestVars) ->
938 indexed_argument(FA,I)
939 ;
940 true
941 )
942 ),
943 J is I + 1,
944 term_variables(Arg,NVars),
945 append(NVars,OtherVars,NOtherVars),
946 check_indexing(Args,J,FA,NOtherVars).
948 check_specs_indexing([],_,[]).
949 check_specs_indexing([Head|Heads],Variables,Specs) :-
950 Specs = [Spec|RSpecs],
951 term_variables(Heads,OtherVariables,Variables),
952 check_spec_indexing(Head,OtherVariables,Spec),
953 term_variables(Head,NVariables,Variables),
954 check_specs_indexing(Heads,NVariables,RSpecs).
956 check_spec_indexing(Head,OtherVariables,Spec) :-
957 functor(Head,F,A),
958 Spec = spec(F,A,ArgSpecs),
959 Head =.. [_|Args],
960 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
961 indexing_spec(F/A,[ArgSpecs]).
963 check_args_spec_indexing([],_,_,[]).
964 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
965 term_variables(Args,Variables,OtherVariables),
966 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
967 ArgSpecs = [ArgSpec|RArgSpecs]
968 ;
969 ArgSpecs = RArgSpecs
970 ),
971 J is I + 1,
972 term_variables(Arg,NOtherVariables,OtherVariables),
973 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
975 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
976 ( var(Arg) ->
977 memberchk_eq(Arg,Variables),
978 ArgSpec = specinfo(I,any,[])
979 ;
980 functor(Arg,F,A),
981 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
982 Arg =.. [_|Args],
983 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
984 ).
986 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
988 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
989 % Occurrences
991 add_occurrences([]).
992 add_occurrences([Rule|Rules]) :-
993 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
994 add_occurrences(H1,IDs1,Nb),
995 add_occurrences(H2,IDs2,Nb),
996 add_occurrences(Rules).
998 add_occurrences([],[],_).
999 add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
1000 functor(H,F,A),
1001 FA = F/A,
1002 new_occurrence(FA,RuleNb,ID),
1003 add_occurrences(Hs,IDs,RuleNb).
1005 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1007 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1008 % Observation Analysis
1009 %
1010 % CLASSIFICATION
1011 % Legacy
1012 %
1013 % - approximative: should make decision in late allocation analysis per body
1014 % TODO:
1015 % remove
1017 is_observed(C,O) :-
1018 is_self_observer(C),
1019 ai_is_observed(C,O).
1021 :- chr_constraint
1022 observes/2,
1023 spawns_observer/2,
1024 observes_indirectly/2,
1025 is_self_observer/1
1026 .
1028 :- chr_option(mode,observes(+,+)).
1029 :- chr_option(mode,spawns_observer(+,+)).
1030 :- chr_option(mode,observes_indirectly(+,+)).
1032 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
1033 observes(C1,C2) \ observes(C1,C2) <=> true.
1035 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
1037 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
1038 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
1040 observes_indirectly(C,C) \ is_self_observer(C) <=> true.
1041 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off).
1042 % true if analysis has not been run,
1043 % false if analysis has been run
1045 observation_analysis(Cs) :-
1046 ( chr_pp_flag(observation_analysis,on) ->
1047 observation_analysis(Cs,Cs)
1048 ;
1049 true
1050 ).
1052 observation_analysis([],_).
1053 observation_analysis([C|Cs],Constraints) :-
1054 get_max_occurrence(C,MO),
1055 observation_analysis_occurrences(C,1,MO,Constraints),
1056 observation_analysis(Cs,Constraints).
1058 observation_analysis_occurrences(C,O,MO,Cs) :-
1059 ( O > MO ->
1060 true
1061 ;
1062 observation_analysis_occurrence(C,O,Cs),
1063 NO is O + 1,
1064 observation_analysis_occurrences(C,NO,MO,Cs)
1065 ).
1067 observation_analysis_occurrence(C,O,Cs) :-
1068 get_occurrence(C,O,RuleNb,ID),
1069 ( is_passive(RuleNb,ID) ->
1070 true
1071 ;
1072 get_rule(RuleNb,PragmaRule),
1073 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),
1074 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
1075 append(RHeads1,Heads2,OtherHeads)
1076 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
1077 append(RHeads2,Heads1,OtherHeads)
1078 ),
1079 observe_heads(C,OtherHeads),
1080 observe_body(C,Body,Cs)
1081 ).
1083 observe_heads(C,Heads) :-
1084 findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
1085 observe_all(C,Cs).
1087 observe_all(C,Cs) :-
1088 ( Cs = [C1|Cr] ->
1089 observes(C,C1),
1090 observe_all(C,Cr)
1091 ;
1092 true
1093 ).
1095 spawn_all(C,Cs) :-
1096 ( Cs = [C1|Cr] ->
1097 spawns_observer(C,C1),
1098 spawn_all(C,Cr)
1099 ;
1100 true
1101 ).
1102 spawn_all_triggers(C,Cs) :-
1103 ( Cs = [C1|Cr] ->
1104 ( may_trigger(C1) ->
1105 spawns_observer(C,C1)
1106 ;
1107 true
1108 ),
1109 spawn_all_triggers(C,Cr)
1110 ;
1111 true
1112 ).
1114 observe_body(C,Body,Cs) :-
1115 ( var(Body) ->
1116 spawn_all(C,Cs)
1117 ; Body = true ->
1118 true
1119 ; Body = fail ->
1120 true
1121 ; Body = (B1,B2) ->
1122 observe_body(C,B1,Cs),
1123 observe_body(C,B2,Cs)
1124 ; Body = (B1;B2) ->
1125 observe_body(C,B1,Cs),
1126 observe_body(C,B2,Cs)
1127 ; Body = (B1->B2) ->
1128 observe_body(C,B1,Cs),
1129 observe_body(C,B2,Cs)
1130 ; functor(Body,F,A), member(F/A,Cs) ->
1131 spawns_observer(C,F/A)
1132 ; Body = (_ = _) ->
1133 spawn_all_triggers(C,Cs)
1134 ; Body = (_ is _) ->
1135 spawn_all_triggers(C,Cs)
1136 ; binds_b(Body,Vars) ->
1137 ( Vars == [] ->
1138 true
1139 ;
1140 spawn_all_triggers(C,Cs)
1141 )
1142 ;
1143 spawn_all(C,Cs)
1144 ).
1146 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1148 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1149 % Late allocation
1151 late_allocation_analysis(Cs) :-
1152 ( chr_pp_flag(late_allocation,on) ->
1153 late_allocation(Cs)
1154 ;
1155 true
1156 ).
1158 late_allocation([]).
1159 late_allocation([C|Cs]) :-
1160 allocation_occurrence(C,1),
1161 late_allocation(Cs).
1162 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1164 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1165 %%
1166 %% Generated predicates
1167 %% attach_$CONSTRAINT
1168 %% attach_increment
1169 %% detach_$CONSTRAINT
1170 %% attr_unify_hook
1172 %% attach_$CONSTRAINT
1173 generate_attach_detach_a_constraint_all([],[]).
1174 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1175 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint)) ->
1176 generate_attach_a_constraint(Constraint,Clauses1),
1177 generate_detach_a_constraint(Constraint,Clauses2)
1178 ;
1179 Clauses1 = [],
1180 Clauses2 = []
1181 ),
1182 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1183 append([Clauses1,Clauses2,Clauses3],Clauses).
1185 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1186 generate_attach_a_constraint_empty_list(Constraint,Clause1),
1187 get_max_constraint_index(N),
1188 ( N == 1 ->
1189 generate_attach_a_constraint_1_1(Constraint,Clause2)
1190 ;
1191 generate_attach_a_constraint_t_p(Constraint,Clause2)
1192 ).
1194 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
1195 make_name('attach_',FA,Fct),
1196 Head =.. [Fct | Args],
1197 Clause = ( Head :- Body).
1199 generate_attach_a_constraint_empty_list(FA,Clause) :-
1200 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
1202 generate_attach_a_constraint_1_1(FA,Clause) :-
1203 Args = [[Var|Vars],Susp],
1204 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1205 generate_attach_body_1(FA,Var,Susp,AttachBody),
1206 make_name('attach_',FA,Fct),
1207 RecursiveCall =.. [Fct,Vars,Susp],
1208 % SWI-Prolog specific code
1209 chr_pp_flag(solver_events,NMod),
1210 ( NMod \== none ->
1211 Args = [[Var|_],Susp],
1212 get_target_module(Mod),
1213 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1214 ;
1215 Subscribe = true
1216 ),
1217 Body =
1218 (
1219 AttachBody,
1220 Subscribe,
1221 RecursiveCall
1222 ).
1224 generate_attach_body_1(FA,Var,Susp,Body) :-
1225 get_target_module(Mod),
1226 Body =
1227 ( get_attr(Var, Mod, Susps) ->
1228 NewSusps=[Susp|Susps],
1229 put_attr(Var, Mod, NewSusps)
1230 ;
1231 put_attr(Var, Mod, [Susp])
1232 ).
1234 generate_attach_a_constraint_t_p(FA,Clause) :-
1235 Args = [[Var|Vars],Susp],
1236 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1237 make_name('attach_',FA,Fct),
1238 RecursiveCall =.. [Fct,Vars,Susp],
1239 generate_attach_body_n(FA,Var,Susp,AttachBody),
1240 % SWI-Prolog specific code
1241 chr_pp_flag(solver_events,NMod),
1242 ( NMod \== none ->
1243 Args = [[Var|_],Susp],
1244 get_target_module(Mod),
1245 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1246 ;
1247 Subscribe = true
1248 ),
1249 Body =
1250 (
1251 AttachBody,
1252 Subscribe,
1253 RecursiveCall
1254 ).
1256 generate_attach_body_n(F/A,Var,Susp,Body) :-
1257 get_constraint_index(F/A,Position),
1258 or_pattern(Position,Pattern),
1259 get_max_constraint_index(Total),
1260 make_attr(Total,Mask,SuspsList,Attr),
1261 nth1(Position,SuspsList,Susps),
1262 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1263 make_attr(Total,Mask,SuspsList1,NewAttr1),
1264 substitute(Susps,SuspsList,[Susp],SuspsList2),
1265 make_attr(Total,NewMask,SuspsList2,NewAttr2),
1266 copy_term(SuspsList,SuspsList3),
1267 nth1(Position,SuspsList3,[Susp]),
1268 chr_delete(SuspsList3,[Susp],RestSuspsList),
1269 set_elems(RestSuspsList,[]),
1270 make_attr(Total,Pattern,SuspsList3,NewAttr3),
1271 get_target_module(Mod),
1272 Body =
1273 ( get_attr(Var,Mod,TAttr) ->
1274 TAttr = Attr,
1275 ( Mask /\ Pattern =:= Pattern ->
1276 put_attr(Var, Mod, NewAttr1)
1277 ;
1278 NewMask is Mask \/ Pattern,
1279 put_attr(Var, Mod, NewAttr2)
1280 )
1281 ;
1282 put_attr(Var,Mod,NewAttr3)
1283 ).
1285 %% detach_$CONSTRAINT
1286 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1287 generate_detach_a_constraint_empty_list(Constraint,Clause1),
1288 get_max_constraint_index(N),
1289 ( N == 1 ->
1290 generate_detach_a_constraint_1_1(Constraint,Clause2)
1291 ;
1292 generate_detach_a_constraint_t_p(Constraint,Clause2)
1293 ).
1295 generate_detach_a_constraint_empty_list(FA,Clause) :-
1296 make_name('detach_',FA,Fct),
1297 Args = [[],_],
1298 Head =.. [Fct | Args],
1299 Clause = ( Head :- true).
1301 generate_detach_a_constraint_1_1(FA,Clause) :-
1302 make_name('detach_',FA,Fct),
1303 Args = [[Var|Vars],Susp],
1304 Head =.. [Fct | Args],
1305 RecursiveCall =.. [Fct,Vars,Susp],
1306 generate_detach_body_1(FA,Var,Susp,DetachBody),
1307 Body =
1308 (
1309 DetachBody,
1310 RecursiveCall
1311 ),
1312 Clause = (Head :- Body).
1314 generate_detach_body_1(FA,Var,Susp,Body) :-
1315 get_target_module(Mod),
1316 Body =
1317 ( get_attr(Var,Mod,Susps) ->
1318 'chr sbag_del_element'(Susps,Susp,NewSusps),
1319 ( NewSusps == [] ->
1320 del_attr(Var,Mod)
1321 ;
1322 put_attr(Var,Mod,NewSusps)
1323 )
1324 ;
1325 true
1326 ).
1328 generate_detach_a_constraint_t_p(FA,Clause) :-
1329 make_name('detach_',FA,Fct),
1330 Args = [[Var|Vars],Susp],
1331 Head =.. [Fct | Args],
1332 RecursiveCall =.. [Fct,Vars,Susp],
1333 generate_detach_body_n(FA,Var,Susp,DetachBody),
1334 Body =
1335 (
1336 DetachBody,
1337 RecursiveCall
1338 ),
1339 Clause = (Head :- Body).
1341 generate_detach_body_n(F/A,Var,Susp,Body) :-
1342 get_constraint_index(F/A,Position),
1343 or_pattern(Position,Pattern),
1344 and_pattern(Position,DelPattern),
1345 get_max_constraint_index(Total),
1346 make_attr(Total,Mask,SuspsList,Attr),
1347 nth1(Position,SuspsList,Susps),
1348 substitute(Susps,SuspsList,[],SuspsList1),
1349 make_attr(Total,NewMask,SuspsList1,Attr1),
1350 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1351 make_attr(Total,Mask,SuspsList2,Attr2),
1352 get_target_module(Mod),
1353 Body =
1354 ( get_attr(Var,Mod,TAttr) ->
1355 TAttr = Attr,
1356 ( Mask /\ Pattern =:= Pattern ->
1357 'chr sbag_del_element'(Susps,Susp,NewSusps),
1358 ( NewSusps == [] ->
1359 NewMask is Mask /\ DelPattern,
1360 ( NewMask == 0 ->
1361 del_attr(Var,Mod)
1362 ;
1363 put_attr(Var,Mod,Attr1)
1364 )
1365 ;
1366 put_attr(Var,Mod,Attr2)
1367 )
1368 ;
1369 true
1370 )
1371 ;
1372 true
1373 ).
1375 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1376 generate_indexed_variables_clauses(Constraints,Clauses) :-
1377 ( are_none_suspended_on_variables ->
1378 Clauses = []
1379 ;
1380 generate_indexed_variables_clauses_(Constraints,Clauses)
1381 ).
1383 generate_indexed_variables_clauses_([],[]).
1384 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1385 ( is_stored(C) ->
1386 Clauses = [Clause|RestClauses],
1387 generate_indexed_variables_clause(C,Clause)
1388 ;
1389 Clauses = RestClauses
1390 ),
1391 generate_indexed_variables_clauses_(Cs,RestClauses).
1393 %===============================================================================
1394 :- chr_constraint generate_indexed_variables_clause/2.
1395 :- chr_option(mode,generate_indexed_variables_clause(+,+)).
1396 %-------------------------------------------------------------------------------
1397 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_clause(F/A,Clause) <=>
1398 functor(Term,F,A),
1399 get_indexing_spec(F/A,Specs),
1400 ( chr_pp_flag(term_indexing,on) ->
1401 spectermvars(Specs,Term,F,A,Body,Vars)
1402 ;
1403 Term =.. [_|Args],
1404 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1405 ( MaybeBody == empty ->
1407 Body = (Vars = [])
1408 ; N == 0 ->
1409 Body = term_variables(Susp,Vars)
1410 ;
1411 MaybeBody = Body
1412 )
1413 ),
1414 Clause =
1415 ( '$indexed_variables'(Susp,Vars) :-
1416 Susp = Term,
1417 Body
1418 ).
1419 generate_indexed_variables_clause(FA,_) <=>
1420 chr_error(internal,'generate_indexed_variables_clause: missing mode info for ~w.\n',[FA]).
1421 %===============================================================================
1423 create_indexed_variables_body([],[],_,_,_,empty,0).
1424 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1425 J is I + 1,
1426 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1427 ( Mode \== (+),
1428 is_indexed_argument(FA,I) ->
1429 ( RBody == empty ->
1430 Body = term_variables(V,Vars)
1431 ;
1432 Body = (term_variables(V,Vars,Tail),RBody)
1433 ),
1434 N = M
1435 ;
1436 Vars = Tail,
1437 Body = RBody,
1438 N is M + 1
1439 ).
1440 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1441 % EXPERIMENTAL
1442 spectermvars(Specs,Term,F,A,Goal,Vars) :-
1443 Term =.. [_|Args],
1444 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1446 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1447 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1448 Goal = (ArgGoal,RGoal),
1449 argspecs(Specs,I,TempArgSpecs,RSpecs),
1450 merge_argspecs(TempArgSpecs,ArgSpecs),
1451 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1452 J is I + 1,
1453 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1455 argspecs([],_,[],[]).
1456 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1457 argspecs(Rest,I,ArgSpecs,RestSpecs).
1458 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1459 ( I == J ->
1460 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1461 ( Specs = [] ->
1462 RRestSpecs = RestSpecs
1463 ;
1464 RestSpecs = [Specs|RRestSpecs]
1465 )
1466 ;
1467 ArgSpecs = RArgSpecs,
1468 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1469 ),
1470 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1472 merge_argspecs(In,Out) :-
1473 sort(In,Sorted),
1474 merge_argspecs_(Sorted,Out).
1476 merge_argspecs_([],[]).
1477 merge_argspecs_([X],R) :- !, R = [X].
1478 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1479 ( (F1 == any ; F2 == any) ->
1480 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1481 ; F1 == F2 ->
1482 append(A1,A2,A),
1483 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1484 ;
1485 R = [specinfo(I,F1,A1)|RR],
1486 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1487 ).
1489 arggoal(List,Arg,Goal,L,T) :-
1490 ( List == [] ->
1491 L = T,
1492 Goal = true
1493 ; List = [specinfo(_,any,_)] ->
1494 Goal = term_variables(Arg,L,T)
1495 ;
1496 Goal =
1497 ( var(Arg) ->
1498 L = [Arg|T]
1499 ;
1500 Cases
1501 ),
1502 arggoal_cases(List,Arg,L,T,Cases)
1503 ).
1505 arggoal_cases([],_,L,T,L=T).
1506 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1507 ( ArgSpecs == [] ->
1508 Cases = RCases
1509 ; ArgSpecs == [[]] ->
1510 Cases = RCases
1511 ; FA = F/A ->
1512 Cases = (Case ; RCases),
1513 functor(Term,F,A),
1514 Term =.. [_|Args],
1515 Case = (Arg = Term -> ArgsGoal),
1516 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1517 ),
1518 arggoal_cases(Rest,Arg,L,T,RCases).
1519 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1521 generate_extra_clauses(Constraints,List) :-
1522 generate_activate_clause(List,Tail0),
1523 generate_remove_clause(Tail0,Tail1),
1524 generate_allocate_clause(Tail1,Tail2),
1525 generate_insert_constraint_internal(Tail2,Tail3),
1526 global_indexed_variables_clause(Constraints,Tail3,[]).
1528 generate_remove_clause(List,Tail) :-
1529 ( is_used_auxiliary_predicate(remove_constraint_internal) ->
1530 List = [RemoveClause|Tail],
1531 use_auxiliary_predicate(chr_indexed_variables),
1532 ( are_none_suspended_on_variables ->
1533 RemoveClause =
1534 (
1535 remove_constraint_internal(Susp) :-
1536 arg( 2, Susp, Mref),
1537 'chr update_mutable'( removed, Mref)
1538 )
1539 ;
1540 RemoveClause =
1541 (
1542 remove_constraint_internal(Susp, Agenda, Delete) :-
1543 arg( 2, Susp, Mref),
1544 'chr get_mutable'( State, Mref),
1545 'chr update_mutable'( removed, Mref), % mark in any case
1546 ( compound(State) -> % passive/1
1547 Agenda = [],
1548 Delete = no
1549 ; State==removed ->
1550 Agenda = [],
1551 Delete = no
1552 %; State==triggered ->
1553 % Agenda = []
1554 ;
1555 Delete = yes,
1556 chr_indexed_variables(Susp,Agenda)
1557 )
1558 )
1559 )
1560 ;
1561 List = Tail
1562 ).
1564 generate_activate_clause(List,Tail) :-
1565 ( is_used_auxiliary_predicate(activate_constraint) ->
1566 List = [ActivateClause|Tail],
1567 use_auxiliary_predicate(chr_indexed_variables),
1568 ActivateClause =
1569 (
1570 activate_constraint(Store, Vars, Susp, Generation) :-
1571 arg( 2, Susp, Mref),
1572 'chr get_mutable'( State, Mref),
1573 'chr update_mutable'( active, Mref),
1574 ( nonvar(Generation) -> % aih
1575 true
1576 ;
1577 arg( 4, Susp, Gref),
1578 'chr get_mutable'( Gen, Gref),
1579 Generation is Gen+1,
1580 'chr update_mutable'( Generation, Gref)
1581 ),
1582 ( compound(State) -> % passive/1
1583 term_variables( State, Vars),
1584 'chr none_locked'( Vars),
1585 Store = yes
1586 ; State == removed -> % the price for eager removal ...
1587 chr_indexed_variables(Susp,Vars),
1588 Store = yes
1589 ;
1590 Vars = [],
1591 Store = no
1592 )
1593 )
1594 ;
1595 List = Tail
1596 ).
1598 generate_allocate_clause(List,Tail) :-
1599 ( is_used_auxiliary_predicate(allocate_constraint) ->
1600 List = [AllocateClause|Tail],
1601 use_auxiliary_predicate(chr_indexed_variables),
1602 AllocateClause =
1603 (
1604 allocate_constraint( Closure, Self, F, Args) :-
1605 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1606 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1607 'chr empty_history'(History),
1608 'chr create_mutable'(History,Href), % Href = mutable(History),
1609 chr_indexed_variables(Self,Vars),
1610 'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)),
1611 'chr gen_id'( Id)
1612 )
1613 ;
1614 List = Tail
1615 ).
1617 generate_insert_constraint_internal(List,Tail) :-
1618 ( is_used_auxiliary_predicate(insert_constraint_internal) ->
1619 ( are_none_suspended_on_variables ->
1620 List = [Clause1,Clause2|Tail],
1621 % is clause1 needed????
1622 Clause1 =
1623 (
1624 insert_constraint_internal(yes, [], Self, Closure, F, Args) :-
1625 'chr create_mutable'(active,Active),
1626 'chr create_mutable'(0,Zero),
1627 'chr create_mutable'(t,Tee),
1628 Self =.. [suspension,Id,Active,Closure,Zero,Tee,F|Args],
1629 'chr gen_id'(Id)
1630 ),
1631 Clause2 =
1632 (
1633 insert_constraint_internal(Self, F, Args) :-
1634 'chr create_mutable'(active,Active),
1635 'chr create_mutable'(0,Zero),
1636 'chr create_mutable'(t,Tee),
1637 Self =.. [suspension,Id,Active,true,Zero,Tee,F|Args],
1638 'chr gen_id'(Id)
1639 )
1640 ;
1641 List = [Clause|Tail],
1642 use_auxiliary_predicate(chr_indexed_variables),
1643 Clause =
1644 (
1645 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1646 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1647 chr_indexed_variables(Self,Vars),
1648 'chr none_locked'(Vars),
1649 'chr create_mutable'(active,Mref), % Mref = mutable(active),
1650 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1651 'chr empty_history'(History),
1652 'chr create_mutable'(History,Href), % Href = mutable(History),
1653 'chr gen_id'(Id)
1654 )
1655 )
1656 ;
1657 List = Tail
1658 ).
1660 global_indexed_variables_clause(Constraints,List,Tail) :-
1661 ( is_used_auxiliary_predicate(chr_indexed_variables) ->
1662 List = [Clause|Tail],
1663 ( chr_pp_flag(reduced_indexing,on) ->
1664 ( are_none_suspended_on_variables ->
1665 Body = true,
1666 Vars = []
1667 ;
1668 Body = (Susp =.. [_,_,_,_,_,_|Term],
1669 Term1 =.. Term,
1670 '$indexed_variables'(Term1,Vars))
1671 ),
1672 Clause = ( chr_indexed_variables(Susp,Vars) :- Body )
1673 ;
1674 Clause =
1675 ( chr_indexed_variables(Susp,Vars) :-
1676 'chr chr_indexed_variables'(Susp,Vars)
1677 )
1678 )
1679 ;
1680 List = Tail
1681 ).
1683 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1684 generate_attach_increment(Clauses) :-
1685 get_max_constraint_index(N),
1686 ( N > 0 ->
1687 Clauses = [Clause1,Clause2],
1688 generate_attach_increment_empty(Clause1),
1689 ( N == 1 ->
1690 generate_attach_increment_one(Clause2)
1691 ;
1692 generate_attach_increment_many(N,Clause2)
1693 )
1694 ;
1695 Clauses = []
1696 ).
1698 generate_attach_increment_empty((attach_increment([],_) :- true)).
1700 generate_attach_increment_one(Clause) :-
1701 Head = attach_increment([Var|Vars],Susps),
1702 get_target_module(Mod),
1703 Body =
1704 (
1705 'chr not_locked'(Var),
1706 ( get_attr(Var,Mod,VarSusps) ->
1707 sort(VarSusps,SortedVarSusps),
1708 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
1709 put_attr(Var,Mod,MergedSusps)
1710 ;
1711 put_attr(Var,Mod,Susps)
1712 ),
1713 attach_increment(Vars,Susps)
1714 ),
1715 Clause = (Head :- Body).
1717 generate_attach_increment_many(N,Clause) :-
1718 make_attr(N,Mask,SuspsList,Attr),
1719 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1720 Head = attach_increment([Var|Vars],Attr),
1721 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1722 list2conj(Gs,SortGoals),
1723 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1724 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1725 get_target_module(Mod),
1726 Body =
1727 (
1728 'chr not_locked'(Var),
1729 ( get_attr(Var,Mod,TOtherAttr) ->
1730 TOtherAttr = OtherAttr,
1731 SortGoals,
1732 MergedMask is Mask \/ OtherMask,
1733 put_attr(Var,Mod,NewAttr)
1734 ;
1735 put_attr(Var,Mod,Attr)
1736 ),
1737 attach_increment(Vars,Attr)
1738 ),
1739 Clause = (Head :- Body).
1741 %% attr_unify_hook
1742 generate_attr_unify_hook(Clauses) :-
1743 get_max_constraint_index(N),
1744 ( N == 0 ->
1745 Clauses = []
1746 ;
1747 Clauses = [Clause],
1748 ( N == 1 ->
1749 generate_attr_unify_hook_one(Clause)
1750 ;
1751 generate_attr_unify_hook_many(N,Clause)
1752 )
1753 ).
1755 generate_attr_unify_hook_one(Clause) :-
1756 Head = attr_unify_hook(Susps,Other),
1757 get_target_module(Mod),
1758 make_run_suspensions(NewSusps,WakeNewSusps),
1759 make_run_suspensions(Susps,WakeSusps),
1760 Body =
1761 (
1762 sort(Susps, SortedSusps),
1763 ( var(Other) ->
1764 ( get_attr(Other,Mod,OtherSusps) ->
1765 true
1766 ;
1767 OtherSusps = []
1768 ),
1769 sort(OtherSusps,SortedOtherSusps),
1770 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1771 put_attr(Other,Mod,NewSusps),
1772 WakeNewSusps
1773 ;
1774 ( compound(Other) ->
1775 term_variables(Other,OtherVars),
1776 attach_increment(OtherVars, SortedSusps)
1777 ;
1778 true
1779 ),
1780 WakeSusps
1781 )
1782 ),
1783 Clause = (Head :- Body).
1785 generate_attr_unify_hook_many(N,Clause) :-
1786 make_attr(N,Mask,SuspsList,Attr),
1787 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1788 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1789 list2conj(SortGoalList,SortGoals),
1790 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1791 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1792 C = (sort(E,F),
1793 'chr merge_attributes'(D,F,G)) ),
1794 SortMergeGoalList),
1795 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1796 list2conj(SortMergeGoalList,SortMergeGoals),
1797 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1798 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1799 Head = attr_unify_hook(Attr,Other),
1800 get_target_module(Mod),
1801 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1802 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1803 Body =
1804 (
1805 SortGoals,
1806 ( var(Other) ->
1807 ( get_attr(Other,Mod,TOtherAttr) ->
1808 TOtherAttr = OtherAttr,
1809 SortMergeGoals,
1810 MergedMask is Mask \/ OtherMask,
1811 put_attr(Other,Mod,MergedAttr),
1812 WakeMergedSusps
1813 ;
1814 put_attr(Other,Mod,SortedAttr),
1815 WakeSortedSusps
1816 )
1817 ;
1818 ( compound(Other) ->
1819 term_variables(Other,OtherVars),
1820 attach_increment(OtherVars,SortedAttr)
1821 ;
1822 true
1823 ),
1824 WakeSortedSusps
1825 )
1826 ),
1827 Clause = (Head :- Body).
1829 make_run_suspensions(Susps,Goal) :-
1830 ( chr_pp_flag(debugable,on) ->
1831 Goal = 'chr run_suspensions_d'(Susps)
1832 ;
1833 Goal = 'chr run_suspensions'(Susps)
1834 ).
1836 make_run_suspensions_loop(SuspsList,Goal) :-
1837 ( chr_pp_flag(debugable,on) ->
1838 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1839 ;
1840 Goal = 'chr run_suspensions_loop'(SuspsList)
1841 ).
1843 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1844 % $insert_in_store_F/A
1845 % $delete_from_store_F/A
1847 generate_insert_delete_constraints([],[]).
1848 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1849 ( is_stored(FA) ->
1850 Clauses = [IClause,DClause|RestClauses],
1851 generate_insert_delete_constraint(FA,IClause,DClause)
1852 ;
1853 Clauses = RestClauses
1854 ),
1855 generate_insert_delete_constraints(Rest,RestClauses).
1857 generate_insert_delete_constraint(FA,IClause,DClause) :-
1858 get_store_type(FA,StoreType),
1859 generate_insert_constraint(StoreType,FA,IClause),
1860 generate_delete_constraint(StoreType,FA,DClause).
1862 generate_insert_constraint(StoreType,C,Clause) :-
1863 make_name('$insert_in_store_',C,ClauseName),
1864 Head =.. [ClauseName,Susp],
1865 generate_insert_constraint_body(StoreType,C,Susp,Body),
1866 ( chr_pp_flag(store_counter,on) ->
1867 InsertCounterInc = '$insert_counter_inc'
1868 ;
1869 InsertCounterInc = true
1870 ),
1871 Clause = (Head :- InsertCounterInc,Body).
1873 generate_insert_constraint_body(default,C,Susp,Body) :-
1874 get_target_module(Mod),
1875 get_max_constraint_index(Total),
1876 ( Total == 1 ->
1877 generate_attach_body_1(C,Store,Susp,AttachBody)
1878 ;
1879 generate_attach_body_n(C,Store,Susp,AttachBody)
1880 ),
1881 Body =
1882 (
1883 'chr default_store'(Store),
1884 AttachBody
1885 ).
1886 generate_insert_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
1887 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
1888 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1889 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1890 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1891 global_ground_store_name(C,StoreName),
1892 make_get_store_goal(StoreName,Store,GetStoreGoal),
1893 make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
1894 Body =
1895 (
1896 GetStoreGoal, % nb_getval(StoreName,Store),
1897 UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
1898 ).
1899 generate_insert_constraint_body(global_singleton,C,Susp,Body) :-
1900 global_singleton_store_name(C,StoreName),
1901 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
1902 Body =
1903 (
1904 UpdateStoreGoal % b_setval(StoreName,Susp)
1905 ).
1906 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1907 find_with_var_identity(
1908 B,
1909 [Susp],
1910 (
1911 member(ST,StoreTypes),
1912 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1913 ),
1914 Bodies
1915 ),
1916 list2conj(Bodies,Body).
1918 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
1919 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1920 multi_hash_store_name(FA,Index,StoreName),
1921 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1922 Body =
1923 (
1924 KeyBody,
1925 nb_getval(StoreName,Store),
1926 insert_iht(Store,Key,Susp)
1927 ),
1928 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1929 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1930 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1931 multi_hash_store_name(FA,Index,StoreName),
1932 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1933 make_get_store_goal(StoreName,Store,GetStoreGoal),
1934 Body =
1935 (
1936 KeyBody,
1937 GetStoreGoal, % nb_getval(StoreName,Store),
1938 insert_ht(Store,Key,Susp)
1939 ),
1940 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1942 generate_delete_constraint(StoreType,FA,Clause) :-
1943 make_name('$delete_from_store_',FA,ClauseName),
1944 Head =.. [ClauseName,Susp],
1945 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1946 ( chr_pp_flag(store_counter,on) ->
1947 DeleteCounterInc = '$delete_counter_inc'
1948 ;
1949 DeleteCounterInc = true
1950 ),
1951 Clause = (Head :- DeleteCounterInc, Body).
1953 generate_delete_constraint_body(default,C,Susp,Body) :-
1954 get_target_module(Mod),
1955 get_max_constraint_index(Total),
1956 ( Total == 1 ->
1957 generate_detach_body_1(C,Store,Susp,DetachBody),
1958 Body =
1959 (
1960 'chr default_store'(Store),
1961 DetachBody
1962 )
1963 ;
1964 generate_detach_body_n(C,Store,Susp,DetachBody),
1965 Body =
1966 (
1967 'chr default_store'(Store),
1968 DetachBody
1969 )
1970 ).
1971 generate_delete_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
1972 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
1973 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1974 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1975 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1976 global_ground_store_name(C,StoreName),
1977 make_get_store_goal(StoreName,Store,GetStoreGoal),
1978 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
1979 Body =
1980 (
1981 GetStoreGoal, % nb_getval(StoreName,Store),
1982 'chr sbag_del_element'(Store,Susp,NStore),
1983 UpdateStoreGoal % b_setval(StoreName,NStore)
1984 ).
1985 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
1986 global_singleton_store_name(C,StoreName),
1987 make_update_store_goal(StoreName,[],UpdateStoreGoal),
1988 Body =
1989 (
1990 UpdateStoreGoal % b_setval(StoreName,[])
1991 ).
1992 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1993 find_with_var_identity(
1994 B,
1995 [Susp],
1996 (
1997 member(ST,StoreTypes),
1998 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1999 ),
2000 Bodies
2001 ),
2002 list2conj(Bodies,Body).
2004 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
2005 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2006 multi_hash_store_name(FA,Index,StoreName),
2007 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2008 Body =
2009 (
2010 KeyBody,
2011 nb_getval(StoreName,Store),
2012 delete_iht(Store,Key,Susp)
2013 ),
2014 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2015 generate_multi_hash_delete_constraint_bodies([],_,_,true).
2016 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2017 multi_hash_store_name(FA,Index,StoreName),
2018 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2019 make_get_store_goal(StoreName,Store,GetStoreGoal),
2020 Body =
2021 (
2022 KeyBody,
2023 GetStoreGoal, % nb_getval(StoreName,Store),
2024 delete_ht(Store,Key,Susp)
2025 ),
2026 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2028 generate_delete_constraint_call(FA,Susp,Call) :-
2029 make_name('$delete_from_store_',FA,Functor),
2030 Call =.. [Functor,Susp].
2032 generate_insert_constraint_call(FA,Susp,Call) :-
2033 make_name('$insert_in_store_',FA,Functor),
2034 Call =.. [Functor,Susp].
2036 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2038 :- chr_constraint
2039 module_initializer/1,
2040 module_initializers/1.
2042 module_initializers(G), module_initializer(Initializer) <=>
2043 G = (Initializer,Initializers),
2044 module_initializers(Initializers).
2046 module_initializers(G) <=>
2047 G = true.
2049 generate_attach_code(Constraints,[Enumerate|L]) :-
2050 enumerate_stores_code(Constraints,Enumerate),
2051 generate_attach_code(Constraints,L,T),
2052 module_initializers(Initializers),
2053 prolog_global_variables_code(PrologGlobalVariables),
2054 T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables].
2056 generate_attach_code([],L,L).
2057 generate_attach_code([C|Cs],L,T) :-
2058 get_store_type(C,StoreType),
2059 generate_attach_code(StoreType,C,L,L1),
2060 generate_attach_code(Cs,L1,T).
2062 generate_attach_code(default,_,L,L).
2063 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
2064 multi_inthash_store_initialisations(Indexes,C,L,L1),
2065 multi_inthash_via_lookups(Indexes,C,L1,T).
2066 generate_attach_code(multi_hash(Indexes),C,L,T) :-
2067 multi_hash_store_initialisations(Indexes,C,L,L1),
2068 multi_hash_via_lookups(Indexes,C,L1,T).
2069 generate_attach_code(global_ground,C,L,T) :-
2070 global_ground_store_initialisation(C,L,T).
2071 generate_attach_code(global_singleton,C,L,T) :-
2072 global_singleton_store_initialisation(C,L,T).
2073 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
2074 multi_store_generate_attach_code(StoreTypes,C,L,T).
2076 multi_store_generate_attach_code([],_,L,L).
2077 multi_store_generate_attach_code([ST|STs],C,L,T) :-
2078 generate_attach_code(ST,C,L,L1),
2079 multi_store_generate_attach_code(STs,C,L1,T).
2081 multi_inthash_store_initialisations([],_,L,L).
2082 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
2083 multi_hash_store_name(FA,Index,StoreName),
2084 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
2085 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
2086 L1 = L,
2087 multi_inthash_store_initialisations(Indexes,FA,L1,T).
2088 multi_hash_store_initialisations([],_,L,L).
2089 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
2090 multi_hash_store_name(FA,Index,StoreName),
2091 prolog_global_variable(StoreName),
2092 make_init_store_goal(StoreName,HT,InitStoreGoal),
2093 module_initializer((new_ht(HT),InitStoreGoal)),
2094 L1 = L,
2095 multi_hash_store_initialisations(Indexes,FA,L1,T).
2097 global_ground_store_initialisation(C,L,T) :-
2098 global_ground_store_name(C,StoreName),
2099 prolog_global_variable(StoreName),
2100 make_init_store_goal(StoreName,[],InitStoreGoal),
2101 module_initializer(InitStoreGoal),
2102 L = T.
2103 global_singleton_store_initialisation(C,L,T) :-
2104 global_singleton_store_name(C,StoreName),
2105 prolog_global_variable(StoreName),
2106 make_init_store_goal(StoreName,[],InitStoreGoal),
2107 module_initializer(InitStoreGoal),
2108 L = T.
2110 multi_inthash_via_lookups([],_,L,L).
2111 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
2112 multi_hash_via_lookup_name(C,Index,PredName),
2113 Head =.. [PredName,Key,SuspsList],
2114 multi_hash_store_name(C,Index,StoreName),
2115 Body =
2116 (
2117 nb_getval(StoreName,HT),
2118 lookup_iht(HT,Key,SuspsList)
2119 ),
2120 L = [(Head :- Body)|L1],
2121 multi_inthash_via_lookups(Indexes,C,L1,T).
2122 multi_hash_via_lookups([],_,L,L).
2123 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
2124 multi_hash_via_lookup_name(C,Index,PredName),
2125 Head =.. [PredName,Key,SuspsList],
2126 multi_hash_store_name(C,Index,StoreName),
2127 make_get_store_goal(StoreName,HT,GetStoreGoal),
2128 Body =
2129 (
2130 GetStoreGoal, % nb_getval(StoreName,HT),
2131 lookup_ht(HT,Key,SuspsList)
2132 ),
2133 L = [(Head :- Body)|L1],
2134 multi_hash_via_lookups(Indexes,C,L1,T).
2136 multi_hash_via_lookup_name(F/A,Index,Name) :-
2137 ( integer(Index) ->
2138 IndexName = Index
2139 ; is_list(Index) ->
2140 atom_concat_list(Index,IndexName)
2141 ),
2142 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
2144 multi_hash_store_name(F/A,Index,Name) :-
2145 get_target_module(Mod),
2146 ( integer(Index) ->
2147 IndexName = Index
2148 ; is_list(Index) ->
2149 atom_concat_list(Index,IndexName)
2150 ),
2151 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
2153 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
2154 ( ( integer(Index) ->
2155 I = Index
2156 ;
2157 Index = [I]
2158 ) ->
2159 SuspIndex is I + 6,
2160 KeyBody = arg(SuspIndex,Susp,Key)
2161 ; is_list(Index) ->
2162 sort(Index,Indexes),
2163 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
2164 pairup(Bodies,Keys,ArgKeyPairs),
2165 Key =.. [k|Keys],
2166 list2conj(Bodies,KeyBody)
2167 ).
2169 multi_hash_key_args(Index,Head,KeyArgs) :-
2170 ( integer(Index) ->
2171 arg(Index,Head,Arg),
2172 KeyArgs = [Arg]
2173 ; is_list(Index) ->
2174 sort(Index,Indexes),
2175 term_variables(Head,Vars),
2176 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
2177 ).
2179 global_ground_store_name(F/A,Name) :-
2180 get_target_module(Mod),
2181 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
2182 global_singleton_store_name(F/A,Name) :-
2183 get_target_module(Mod),
2184 atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
2186 :- chr_constraint
2187 prolog_global_variable/1,
2188 prolog_global_variables/1.
2190 :- chr_option(mode,prolog_global_variable(+)).
2191 :- chr_option(mode,prolog_global_variable(2)).
2193 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
2195 prolog_global_variables(List), prolog_global_variable(Name) <=>
2196 List = [Name|Tail],
2197 prolog_global_variables(Tail).
2198 prolog_global_variables(List) <=> List = [].
2200 %% SWI begin
2201 prolog_global_variables_code(Code) :-
2202 prolog_global_variables(Names),
2203 ( Names == [] ->
2204 Code = []
2205 ;
2206 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
2207 Code = [(:- dynamic user:exception/3),
2208 (:- multifile user:exception/3),
2209 (user:exception(undefined_global_variable,Name,retry) :-
2210 (
2211 '$chr_prolog_global_variable'(Name),
2212 '$chr_initialization'
2213 )
2214 )
2215 |
2216 NameDeclarations
2217 ]
2218 ).
2219 %% SWI end
2220 %% SICStus begin
2221 prolog_global_variables_code([]).
2222 %% SICStus end
2223 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2224 %sbag_member_call(S,L,sysh:mem(S,L)).
2225 sbag_member_call(S,L,'chr sbag_member'(S,L)).
2227 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2229 enumerate_stores_code(Constraints,Clause) :-
2230 Head = '$enumerate_suspensions'(Susp),
2231 enumerate_store_bodies(Constraints,Susp,Bodies),
2232 list2disj(Bodies,Body),
2233 Clause = (Head :- Body).
2235 enumerate_store_bodies([],_,[]).
2236 enumerate_store_bodies([C|Cs],Susp,L) :-
2237 ( is_stored(C) ->
2238 get_store_type(C,StoreType),
2239 enumerate_store_body(StoreType,C,Susp,B),
2240 L = [B|T]
2241 ;
2242 L = T
2243 ),
2244 enumerate_store_bodies(Cs,Susp,T).
2246 enumerate_store_body(default,C,Susp,Body) :-
2247 get_constraint_index(C,Index),
2248 get_target_module(Mod),
2249 get_max_constraint_index(MaxIndex),
2250 Body1 =
2251 (
2252 'chr default_store'(GlobalStore),
2253 get_attr(GlobalStore,Mod,Attr)
2254 ),
2255 ( MaxIndex > 1 ->
2256 NIndex is Index + 1,
2257 sbag_member_call(Susp,List,Sbag),
2258 Body2 =
2259 (
2260 arg(NIndex,Attr,List),
2261 Sbag
2262 )
2263 ;
2264 sbag_member_call(Susp,Attr,Sbag),
2265 Body2 = Sbag
2266 ),
2267 Body = (Body1,Body2).
2268 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
2269 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
2270 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
2271 multi_hash_enumerate_store_body(Index,C,Susp,Body).
2272 enumerate_store_body(global_ground,C,Susp,Body) :-
2273 global_ground_store_name(C,StoreName),
2274 sbag_member_call(Susp,List,Sbag),
2275 make_get_store_goal(StoreName,List,GetStoreGoal),
2276 Body =
2277 (
2278 GetStoreGoal, % nb_getval(StoreName,List),
2279 Sbag
2280 ).
2281 enumerate_store_body(global_singleton,C,Susp,Body) :-
2282 global_singleton_store_name(C,StoreName),
2283 make_get_store_goal(StoreName,Susp,GetStoreGoal),
2284 Body =
2285 (
2286 GetStoreGoal, % nb_getval(StoreName,Susp),
2287 Susp \== []
2288 ).
2289 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
2290 once((
2291 member(ST,STs),
2292 enumerate_store_body(ST,C,Susp,Body)
2293 )).
2295 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
2296 multi_hash_store_name(C,I,StoreName),
2297 B =
2298 (
2299 nb_getval(StoreName,HT),
2300 value_iht(HT,Susp)
2301 ).
2302 multi_hash_enumerate_store_body(I,C,Susp,B) :-
2303 multi_hash_store_name(C,I,StoreName),
2304 make_get_store_goal(StoreName,HT,GetStoreGoal),
2305 B =
2306 (
2307 GetStoreGoal, % nb_getval(StoreName,HT),
2308 value_ht(HT,Susp)
2309 ).
2311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2314 :- chr_constraint
2315 prev_guard_list/7,
2316 simplify_guards/1,
2317 set_all_passive/1.
2319 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
2320 :- chr_option(mode,simplify_guards(+)).
2321 :- chr_option(mode,set_all_passive(+)).
2323 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2324 % GUARD SIMPLIFICATION
2325 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2326 % If the negation of the guards of earlier rules entails (part of)
2327 % the current guard, the current guard can be simplified. We can only
2328 % use earlier rules with a head that matches if the head of the current
2329 % rule does, and which make it impossible for the current rule to match
2330 % if they fire (i.e. they shouldn't be propagation rules and their
2331 % head constraints must be subsets of those of the current rule).
2332 % At this point, we know for sure that the negation of the guard
2333 % of such a rule has to be true (otherwise the earlier rule would have
2334 % fired, because of the refined operational semantics), so we can use
2335 % that information to simplify the guard by replacing all entailed
2336 % conditions by true/0. As a consequence, the never-stored analysis
2337 % (in a further phase) will detect more cases of never-stored constraints.
2338 %
2339 % e.g. c(X),d(Y) <=> X > 0 | ...
2340 % e(X) <=> X < 0 | ...
2341 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
2342 % \____________/
2343 % true
2345 guard_simplification :-
2346 ( chr_pp_flag(guard_simplification,on) ->
2347 multiple_occ_constraints_checked([]),
2348 simplify_guards(1)
2349 ;
2350 true
2351 ).
2353 % for every rule, we create a prev_guard_list where the last argument
2354 % eventually is a list of the negations of earlier guards
2355 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=>
2356 Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
2357 append(Head1,Head2,Heads),
2358 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
2359 add_guard_to_head(Heads,G,GHeads),
2360 PrevRule is RuleNb-1,
2361 prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
2362 multiple_occ_constraints_checked([]),
2363 NextRule is RuleNb+1, simplify_guards(NextRule).
2365 simplify_guards(_) <=> true.
2367 % the negation of the guard of a non-propagation rule is added
2368 % if its kept head constraints are a subset of the kept constraints of
2369 % the rule we're working on, and its removed head constraints (at least one)
2370 % are a subset of the removed constraints
2371 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
2372 Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
2373 H1 \== [],
2374 append(H1,H2,Heads),
2375 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
2376 % term_variables(UniqueVarsHeads+H,HVars),
2377 % strip_attributes(HVars,HVarAttrs), % this seems to be necessairy to get past the setof
2378 setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
2379 % restore_attributes(HVars,HVarAttrs),
2380 Renamings \= []
2381 |
2382 compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
2383 append(GuardList,DerivedInfo,GL1),
2384 list2conj(GL1,GL_),
2385 conj2list(GL_,GL),
2386 append(GH_New1,GH,GH1),
2387 list2conj(GH1,GH_),
2388 conj2list(GH_,GH_New),
2389 N1 is N-1,
2390 prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
2393 % if this isn't the case, we skip this one and try the next rule
2394 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
2395 N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
2397 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
2398 GH \== [] |
2399 add_type_information_(H,GH,TypeInfo),
2400 conj2list(TypeInfo,TI),
2401 term_variables(H,HeadVars),
2402 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
2403 list2conj(Info,InfoC),
2404 conj2list(InfoC,InfoL),
2405 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
2407 add_type_information_(H,[],true) :- !.
2408 add_type_information_(H,[GH|GHs],TI) :- !,
2409 add_type_information(H,GH,TI1),
2410 TI = (TI1, TI2),
2411 add_type_information_(H,GHs,TI2).
2413 % when all earlier guards are added or skipped, we simplify the guard.
2414 % if it's different from the original one, we change the rule
2415 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=>
2416 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2417 G \== true, % let's not try to simplify this ;)
2418 append(M,GuardList,Info),
2419 simplify_guard(G,B,Info,SimpleGuard,NB),
2420 G \== SimpleGuard |
2421 % ( prolog_flag(verbose,V), V == yes ->
2422 % format(' * Guard simplification in ~@\n',[format_rule(Rule)]),
2423 % format(' was: ~w\n',[G]),
2424 % format(' now: ~w\n',[SimpleGuard]),
2425 % (NB\==B -> format(' new body: ~w\n',[NB]) ; true)
2426 % ;
2427 % true
2428 % ),
2429 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
2430 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
2433 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2434 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
2435 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2437 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
2439 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
2440 copy_term(Matchings-G2,FreshMatchings),
2441 variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
2442 append(Renaming1,ExtraRenaming,Renaming2),
2443 list2conj(Matchings,Match),
2444 negate_b(Match,HeadsDontMatch),
2445 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
2446 list2conj(HeadsMatch,HeadsMatchBut),
2447 term_variables(Renaming2,RenVars),
2448 term_variables(Matchings-G2-HeadsMatch,MGVars),
2449 new_vars(MGVars,RenVars,ExtraRenaming2),
2450 append(Renaming2,ExtraRenaming2,Renaming),
2451 negate_b(G2,TheGuardFailed),
2452 ( G2 == true -> % true can't fail
2453 Info_ = HeadsDontMatch
2454 ;
2455 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
2456 ),
2457 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
2458 copy_with_variable_replacement(G2,RenamedG2,Renaming),
2459 copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
2460 list2conj(RenamedMatchings_,RenamedMatchings),
2461 add_guard_to_head(H,RenamedG2,GH2),
2462 add_guard_to_head(GH2,RenamedMatchings,GH3),
2463 compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
2464 append([DerivedInfo1],DerivedInfo2,DerivedInfo),
2465 append([GH3],GH_New2,GH_New).
2468 simplify_guard(G,B,Info,SG,NB) :-
2469 conj2list(G,LG),
2470 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
2471 list2conj(SGL,SG).
2474 new_vars([],_,[]).
2475 new_vars([A|As],RV,ER) :-
2476 ( memberchk_eq(A,RV) ->
2477 new_vars(As,RV,ER)
2478 ;
2479 ER = [A-NewA,NewA-A|ER2],
2480 new_vars(As,RV,ER2)
2481 ).
2483 % check if a list of constraints is a subset of another list of constraints
2484 % (multiset-subset), meanwhile computing a variable renaming to convert
2485 % one into the other.
2486 head_subset(H,Head,Renaming) :-
2487 head_subset(H,Head,Renaming,[],_).
2489 % empty list is a subset of everything
2490 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
2491 Renaming = Cumul,
2492 Headleft = Head.
2494 % first constraint has to be in the list, the rest has to be a subset
2495 % of the list with one occurrence of the first constraint removed
2496 % (has to be multiset-subset)
2497 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
2498 head_subset(A,Head,R1,Cumul,Headleft1),
2499 head_subset(B,Headleft1,R2,R1,Headleft2),
2500 Renaming = R2,
2501 Headleft = Headleft2.
2503 % check if A is in the list, remove it from Headleft
2504 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
2505 ( head_subset(A,X,R1,Cumul,HL1),
2506 Renaming = R1,
2507 Headleft = Y
2508 ;
2509 head_subset(A,Y,R2,Cumul,HL2),
2510 Renaming = R2,
2511 Headleft = [X|HL2]
2512 ).
2514 % A is X if there's a variable renaming to make them identical
2515 head_subset(A,X,Renaming,Cumul,Headleft) :-
2516 variable_replacement(A,X,Cumul,Renaming),
2517 Headleft = [].
2519 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
2520 extract_variables(Heads,VH1),
2521 make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
2522 insert_variables(H1_,Heads,UniqueVarsHeads).
2524 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
2525 extract_variables(Heads,VH1),
2526 make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
2527 insert_variables(H1_,Heads,UniqueVarsHeads).
2529 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
2530 extract_variables(Heads,VH1),
2531 extract_variables(UniqueVarsHeads,UV),
2532 make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
2535 extract_variables([],[]).
2536 extract_variables([X|R],V) :-
2537 X =.. [_|Args],
2538 extract_variables(R,V2),
2539 append(Args,V2,V).
2541 insert_variables([],[],[]) :- !.
2542 insert_variables(Vars,[C|R],[C2|R2]) :-
2543 C =.. [F | Args],
2544 length(Args,N),
2545 take_first_N(Vars,N,Args2,RestVars),
2546 C2 =.. [F | Args2],
2547 insert_variables(RestVars,R,R2).
2549 take_first_N(Vars,0,[],Vars) :- !.
2550 take_first_N([X|R],N,[X|R2],RestVars) :-
2551 N1 is N-1,
2552 take_first_N(R,N1,R2,RestVars).
2554 make_matchings_explicit([],[],_,MC,MC,[]).
2555 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
2556 ( var(X) ->
2557 ( memberchk_eq(X,C) ->
2558 list2disj(MC,MC_disj),
2559 M = [(MC_disj ; NewVar == X)|M2], % or only = ??
2560 C2 = C
2561 ;
2562 M = M2,
2563 NewVar = X,
2564 C2 = [X|C]
2565 ),
2566 MC2 = MC
2567 ;
2568 functor(X,F,A),
2569 X =.. [F|Args],
2570 make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
2571 X_ =.. [F|NewArgs],
2572 (ArgM == [] ->
2573 M = [functor(NewVar,F,A) |M2]
2574 ;
2575 list2conj(ArgM,ArgM_conj),
2576 list2disj(MC,MC_disj),
2577 ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
2578 M = [ functor(NewVar,F,A) , ArgM_|M2]
2579 ),
2580 MC2 = [ NewVar \= X_ |MC_],
2581 term_variables(Args,ArgVars),
2582 append(C,ArgVars,C2)
2583 ),
2584 make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
2587 make_matchings_explicit_not_negated([],[],_,[]).
2588 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
2589 M = [NewVar = X|M2],
2590 C2 = C,
2591 make_matchings_explicit_not_negated(R,R2,C2,M2).
2594 add_guard_to_head([],G,[]).
2595 add_guard_to_head([H|RH],G,[GH|RGH]) :-
2596 (var(H) ->
2597 find_guard_info_for_var(H,G,GH)
2598 ;
2599 functor(H,F,A),
2600 H =.. [F|HArgs],
2601 add_guard_to_head(HArgs,G,NewHArgs),
2602 GH =.. [F|NewHArgs]
2603 ),
2604 add_guard_to_head(RH,G,RGH).
2606 find_guard_info_for_var(H,(G1,G2),GH) :- !,
2607 find_guard_info_for_var(H,G1,GH1),
2608 find_guard_info_for_var(GH1,G2,GH).
2610 find_guard_info_for_var(H,G,GH) :-
2611 (G = (H1 = A), H == H1 ->
2612 GH = A
2613 ;
2614 (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
2615 length(GHArg,HA),
2616 GH =.. [HF|GHArg]
2617 ;
2618 GH = H
2619 )
2620 ).
2622 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2623 % ALWAYS FAILING HEADS
2624 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2626 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=>
2627 chr_pp_flag(check_impossible_rules,on),
2628 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2629 append(M,GuardList,Info),
2630 guard_entailment:entails_guard(Info,fail) |
2631 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
2632 set_all_passive(RuleNb).
2634 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2635 % HEAD SIMPLIFICATION
2636 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2638 % now we check the head matchings (guard may have been simplified meanwhile)
2639 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=>
2640 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2641 simplify_heads(M,GuardList,G,B,NewM,NewB),
2642 NewM \== [],
2643 extract_variables(Head1,VH1),
2644 extract_variables(Head2,VH2),
2645 extract_variables(H,VH),
2646 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
2647 insert_variables(H1,Head1,NewH1),
2648 insert_variables(H2,Head2,NewH2),
2649 append(NewB,NewB_,NewBody),
2650 list2conj(NewBody,BodyMatchings),
2651 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
2652 (Head1 \== NewH1 ; Head2 \== NewH2 )
2653 |
2654 % ( prolog_flag(verbose,V), V == yes ->
2655 % format(' * Head simplification in ~@\n',[format_rule(Rule)]),
2656 % format(' was: ~w \\ ~w \n',[Head2,Head1]),
2657 % format(' now: ~w \\ ~w \n',[NewH2,NewH1]),
2658 % format(' extra body: ~w \n',[BodyMatchings])
2659 % ;
2660 % true
2661 % ),
2662 rule(RuleNb,NewRule).
2666 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2667 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
2668 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2670 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
2671 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
2672 ( NH == M ->
2673 H2_ = M,
2674 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
2675 ;
2676 (M = functor(X,F,A), NH == X ->
2677 length(A_args,A),
2678 (var(H2) ->
2679 NewB1 = [],
2680 H2_ =.. [F|A_args]
2681 ;
2682 H2 =.. [F|OrigArgs],
2683 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2684 H2_ =.. [F|A_args_]
2685 ),
2686 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
2687 append(NewB1,NewB2,NewB)
2688 ;
2689 H2_ = H2,
2690 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
2691 )
2692 ).
2694 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
2695 ( NH == M ->
2696 H1_ = M,
2697 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
2698 ;
2699 (M = functor(X,F,A), NH == X ->
2700 length(A_args,A),
2701 (var(H1) ->
2702 NewB1 = [],
2703 H1_ =.. [F|A_args]
2704 ;
2705 H1 =.. [F|OrigArgs],
2706 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2707 H1_ =.. [F|A_args_]
2708 ),
2709 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
2710 append(NewB1,NewB2,NewB)
2711 ;
2712 H1_ = H1,
2713 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
2714 )
2715 ).
2717 use_same_args([],[],[],_,_,[]).
2718 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2719 var(OA),!,
2720 Out = OA,
2721 use_same_args(ROA,RNA,ROut,G,Body,NewB).
2722 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2723 nonvar(OA),!,
2724 ( vars_occur_in(OA,Body) ->
2725 NewB = [NA = OA|NextB]
2726 ;
2727 NewB = NextB
2728 ),
2729 Out = NA,
2730 use_same_args(ROA,RNA,ROut,G,Body,NextB).
2733 simplify_heads([],_GuardList,_G,_Body,[],[]).
2734 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
2735 M = (A = B),
2736 ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
2737 guard_entailment:entails_guard(GuardList,(A=B)) ->
2738 ( vars_occur_in(B,G-RM-GuardList) ->
2739 NewB = NextB,
2740 NewM = NextM
2741 ;
2742 ( vars_occur_in(B,Body) ->
2743 NewB = [A = B|NextB]
2744 ;
2745 NewB = NextB
2746 ),
2747 NewM = [A|NextM]
2748 )
2749 ;
2750 ( nonvar(B), functor(B,BFu,BAr),
2751 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
2752 NewB = NextB,
2753 ( vars_occur_in(B,G-RM-GuardList) ->
2754 NewM = NextM
2755 ;
2756 NewM = [functor(A,BFu,BAr)|NextM]
2757 )
2758 ;
2759 NewM = NextM,
2760 NewB = NextB
2761 )
2762 ),
2763 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
2765 vars_occur_in(B,G) :-
2766 term_variables(B,BVars),
2767 term_variables(G,GVars),
2768 intersect_eq(BVars,GVars,L),
2769 L \== [].
2772 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2773 % ALWAYS FAILING GUARDS
2774 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2776 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID) ==> passive(RuleNb,ID).
2777 set_all_passive(_) <=> true.
2779 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==>
2780 chr_pp_flag(check_impossible_rules,on),
2781 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
2782 conj2list(G,GL),
2783 guard_entailment:entails_guard(GL,fail) |
2784 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
2785 set_all_passive(RuleNb).
2789 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2790 % OCCURRENCE SUBSUMPTION
2791 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2793 :- chr_constraint
2794 first_occ_in_rule/4,
2795 next_occ_in_rule/6,
2796 multiple_occ_constraints_checked/1.
2798 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
2799 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
2800 :- chr_option(mode,multiple_occ_constraints_checked(+)).
2804 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2805 occurrence(C,O,RuleNb,ID), occurrence(C,O2,RuleNb,ID2), rule(RuleNb,Rule)
2806 \ multiple_occ_constraints_checked(Done) <=>
2807 O < O2,
2808 chr_pp_flag(occurrence_subsumption,on),
2809 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
2810 H1 \== [],
2811 \+ memberchk_eq(C,Done) |
2812 first_occ_in_rule(RuleNb,C,O,ID),
2813 multiple_occ_constraints_checked([C|Done]).
2816 occurrence(C,O,RuleNb,ID) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 |
2817 first_occ_in_rule(RuleNb,C,O,ID).
2819 first_occ_in_rule(RuleNb,C,O,ID_o1) <=>
2820 C = F/A,
2821 functor(FreshHead,F,A),
2822 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
2824 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2)
2825 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
2826 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
2829 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2830 occurrence(C,O2,RuleNb,ID_o2), rule(RuleNb,Rule) \
2831 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
2832 O2 is O+1,
2833 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
2834 |
2835 append(H1,H2,Heads),
2836 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
2837 ( ExtraCond == [chr_pp_void_info] ->
2838 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
2839 ;
2840 append(ExtraCond,Cond,NewCond),
2841 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
2842 copy_term(GuardList,FGuardList),
2843 variable_replacement(GuardList,FGuardList,GLRepl),
2844 copy_with_variable_replacement(GuardList,GuardList2,Repl),
2845 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
2846 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
2847 append(NewCond,GuardList2,BigCond),
2848 append(BigCond,GuardList3,BigCond2),
2849 copy_with_variable_replacement(M,M2,Repl),
2850 copy_with_variable_replacement(M,M3,Repl2),
2851 append(M3,BigCond2,BigCond3),
2852 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
2853 list2conj(CheckCond,OccSubsum),
2854 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
2855 term_variables(NewCond2-FH2,InfoVars),
2856 flatten_stuff(Info2,Info3),
2857 flatten_stuff(OccSubsum2,OccSubsum3),
2858 ( OccSubsum \= chr_pp_void_info,
2859 unify_stuff(InfoVars,Info3,OccSubsum3), !,
2860 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
2861 % ( prolog_flag(verbose,V), V == yes ->
2862 % format(' * Occurrence subsumption detected in ~@\n',[format_rule(Rule)]),
2863 % format(' passive: constraint ~w, occurrence number ~w (id ~w)\n',[C,O2,ID_o2]),
2864 % ;
2865 % true
2866 % ),
2867 passive(RuleNb,ID_o2)
2868 ;
2869 true
2870 )
2871 ; true
2872 ),!,
2873 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
2874 ).
2877 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
2878 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2879 multiple_occ_constraints_checked(Done) <=> true.
2881 flatten_stuff([A|B],C) :- !,
2882 flatten_stuff(A,C1),
2883 flatten_stuff(B,C2),
2884 append(C1,C2,C).
2885 flatten_stuff((A;B),C) :- !,
2886 flatten_stuff(A,C1),
2887 flatten_stuff(B,C2),
2888 append(C1,C2,C).
2889 flatten_stuff((A,B),C) :- !,
2890 flatten_stuff(A,C1),
2891 flatten_stuff(B,C2),
2892 append(C1,C2,C).
2894 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
2895 flatten_stuff(X,[]).
2897 unify_stuff(AllInfo,[],[]).
2899 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
2900 H \== I,
2901 term_variables(H,HVars),
2902 term_variables(I,IVars),
2903 intersect_eq(HVars,IVars,SharedVars),
2904 check_safe_unif(H,I,SharedVars),
2905 variable_replacement(H,I,Repl),
2906 check_replacement(Repl),
2907 term_variables(Repl,ReplVars),
2908 list_difference_eq(ReplVars,HVars,LDiff),
2909 intersect_eq(AllInfo,LDiff,LDiff2),
2910 LDiff2 == [],
2911 H = I,
2912 unify_stuff(AllInfo,RInfo,ROS),!.
2914 unify_stuff(AllInfo,X,[Y|ROS]) :-
2915 unify_stuff(AllInfo,X,ROS).
2917 unify_stuff(AllInfo,[Y|RInfo],X) :-
2918 unify_stuff(AllInfo,RInfo,X).
2920 check_safe_unif(H,I,SV) :- var(H), !, var(I),
2921 ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
2922 H == I
2923 ;
2924 true
2925 ).
2927 check_safe_unif([],[],SV) :- !.
2928 check_safe_unif([H|Hs],[I|Is],SV) :- !,
2929 check_safe_unif(H,I,SV),!,
2930 check_safe_unif(Hs,Is,SV).
2932 check_safe_unif(H,I,SV) :-
2933 nonvar(H),!,nonvar(I),
2934 H =.. [F|HA],
2935 I =.. [F|IA],
2936 check_safe_unif(HA,IA,SV).
2938 check_safe_unif2(H,I) :- var(H), !.
2940 check_safe_unif2([],[]) :- !.
2941 check_safe_unif2([H|Hs],[I|Is]) :- !,
2942 check_safe_unif2(H,I),!,
2943 check_safe_unif2(Hs,Is).
2945 check_safe_unif2(H,I) :-
2946 nonvar(H),!,nonvar(I),
2947 H =.. [F|HA],
2948 I =.. [F|IA],
2949 check_safe_unif2(HA,IA).
2952 check_replacement(Repl) :-
2953 check_replacement(Repl,FirstVars),
2954 sort(FirstVars,Sorted),
2955 length(Sorted,L),!,
2956 length(FirstVars,L).
2958 check_replacement([],[]).
2959 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
2962 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
2963 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
2964 append(ID2,ID1,IDs),
2965 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
2966 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
2967 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
2968 copy_with_variable_replacement(G,FG,Repl),
2969 extract_explicit_matchings(FG,FG2),
2970 negate_b(FG2,NotFG),
2971 copy_with_variable_replacement(MPCond,FMPCond,Repl),
2972 ( check_safe_unif2(FH,FH2), FH=FH2 ->
2973 FailCond = [(NotFG;FMPCond)]
2974 ;
2975 % in this case, not much can be done
2976 % e.g. c(f(...)), c(g(...)) <=> ...
2977 FailCond = [chr_pp_void_info]
2978 ).
2982 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
2983 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
2984 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
2985 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
2986 Cond = (chr_pp_not_in_store(H);Cond1),
2987 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
2990 extract_explicit_matchings(A=B) :-
2991 var(A), var(B), !, A=B.
2992 extract_explicit_matchings(A==B) :-
2993 var(A), var(B), !, A=B.
2995 extract_explicit_matchings((A,B),D) :- !,
2996 ( extract_explicit_matchings(A) ->
2997 extract_explicit_matchings(B,D)
2998 ;
2999 D = (A,E),
3000 extract_explicit_matchings(B,E)
3001 ).
3002 extract_explicit_matchings(A,D) :- !,
3003 ( extract_explicit_matchings(A) ->
3004 D = true
3005 ;
3006 D = A
3007 ).
3012 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3013 % TYPE INFORMATION
3014 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3016 :- chr_constraint
3017 type_definition/2,
3018 type_alias/2,
3019 constraint_type/2,
3020 get_type_definition/2,
3021 get_constraint_type/2,
3022 add_type_information/3.
3025 :- chr_option(mode,type_definition(?,?)).
3026 :- chr_option(mode,type_alias(?,?)).
3027 :- chr_option(mode,constraint_type(+,+)).
3028 :- chr_option(mode,add_type_information(+,+,?)).
3029 :- chr_option(type_declaration,add_type_information(list,list,any)).
3031 type_alias(T,T) <=>
3032 chr_error(cyclic_alias(T),'',[]).
3033 type_alias(T,B) \ type_alias(A,T) <=> type_alias(A,B).
3035 type_alias(T,D) \ get_type_definition(T2,Def) <=>
3036 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A) |
3037 copy_term((T,D),(T1,D1)),T1=T2, get_type_definition(D1,Def).
3039 type_definition(T,D) \ get_type_definition(T2,Def) <=>
3040 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A) |
3041 copy_term((T,D),(T1,D1)),T1=T2,Def = D1.
3042 get_type_definition(_,_) <=> fail.
3043 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
3044 get_constraint_type(_,_) <=> fail.
3046 add_type_information([],[],T) <=> T=true.
3048 constraint_mode(F/A,Modes)
3049 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
3050 functor(Head,F,A) |
3051 Head =.. [_|Args],
3052 RealHead =.. [_|RealArgs],
3053 add_mode_info(Modes,Args,ModeInfo),
3054 TypeInfo = (ModeInfo, TI),
3055 (get_constraint_type(F/A,Types) ->
3056 types2condition(Types,Args,RealArgs,Modes,TI2),
3057 list2conj(TI2,ConjTI),
3058 TI = (ConjTI,RTI),
3059 add_type_information(R,RRH,RTI)
3060 ;
3061 add_type_information(R,RRH,TI)
3062 ).
3065 add_type_information([Head|R],_,TypeInfo) <=>
3066 functor(Head,F,A),
3067 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
3070 add_mode_info([],[],true).
3071 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
3072 MI = (ground(A), ModeInfo),
3073 add_mode_info(Modes,Args,ModeInfo).
3074 add_mode_info([M|Modes],[A|Args],MI) :-
3075 add_mode_info(Modes,Args,MI).
3078 types2condition([],[],[],[],[]).
3079 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
3080 (get_type_definition(Type,Def) ->
3081 type2condition(Def,Arg,RealArg,TC),
3082 (Mode \== (+) ->
3083 TC_ = [(\+ ground(Arg))|TC]
3084 ;
3085 TC_ = TC
3086 ),
3087 list2disj(TC_,DisjTC),
3088 TI = [DisjTC|RTI],
3089 types2condition(Types,Args,RAs,Modes,RTI)
3090 ;
3091 ( builtin_type(Type,Arg,C) ->
3092 TI = [C|RTI],
3093 types2condition(Types,Args,RAs,Modes,RTI)
3094 ;
3095 chr_error(internal,'Undefined type ~w.\n',[Type])
3096 )
3097 ).
3099 type2condition([],Arg,_,[]).
3100 type2condition([Def|Defs],Arg,RealArg,TC) :-
3101 ( builtin_type(Def,Arg,C) ->
3102 true
3103 ;
3104 real_type(Def,Arg,RealArg,C)
3105 ),
3106 item2list(C,LC),
3107 type2condition(Defs,Arg,RealArg,RTC),
3108 append(LC,RTC,TC).
3110 item2list([],[]) :- !.
3111 item2list([X|Y],[X|Y]) :- !.
3112 item2list(N,L) :- L = [N].
3114 builtin_type(X,Arg,true) :- var(X),!.
3115 builtin_type(any,Arg,true).
3116 builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
3117 builtin_type(int,Arg,integer(Arg)).
3118 builtin_type(number,Arg,number(Arg)).
3119 builtin_type(float,Arg,float(Arg)).
3120 builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
3122 real_type(Def,Arg,RealArg,C) :-
3123 ( nonvar(Def) ->
3124 functor(Def,F,A),
3125 ( A == 0 ->
3126 C = (Arg = F)
3127 ;
3128 Def =.. [_|TArgs],
3129 length(AA,A),
3130 Def2 =.. [F|AA],
3131 ( var(RealArg) ->
3132 C = functor(Arg,F,A)
3133 ;
3134 ( functor(RealArg,F,A) ->
3135 RealArg =.. [_|RAArgs],
3136 nested_types(TArgs,AA,RAArgs,ACond),
3137 C = (functor(Arg,F,A),Arg=Def2,ACond)
3138 ;
3139 C = functor(Arg,F,A)
3140 )
3141 )
3142 )
3143 ;
3144 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
3145 ).
3146 nested_types([],[],[],true).
3147 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
3148 (get_type_definition(T,Def) ->
3149 type2condition(Def,A,RealA,TC),
3150 list2disj(TC,DisjTC),
3151 C = (DisjTC, RC),
3152 nested_types(RT,RA,RRA,RC)
3153 ;
3154 ( builtin_type(T,A,Cond) ->
3155 C = (Cond, RC),
3156 nested_types(RT,RA,RRA,RC)
3157 ;
3158 chr_error(internal,'Undefined type ~w inside type definition.\n',[T])
3159 )
3160 ).
3163 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3165 :- chr_constraint
3166 stored/3, % constraint,occurrence,(yes/no/maybe)
3167 stored_completing/3,
3168 stored_complete/3,
3169 is_stored/1,
3170 is_finally_stored/1,
3171 check_all_passive/2.
3173 :- chr_option(mode,stored(+,+,+)).
3174 :- chr_option(type_declaration,stored(any,int,storedinfo)).
3175 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
3176 :- chr_option(mode,stored_complete(+,+,+)).
3177 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
3178 :- chr_option(mode,guard_list(+,+,+,+)).
3179 :- chr_option(mode,check_all_passive(+,+)).
3181 % change yes in maybe when yes becomes passive
3182 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID) \
3183 stored(C,O,yes), stored_complete(C,RO,Yesses)
3184 <=> O < RO | NYesses is Yesses - 1,
3185 stored(C,O,maybe), stored_complete(C,RO,NYesses).
3186 % change yes in maybe when not observed
3187 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
3188 <=> O < RO |
3189 NYesses is Yesses - 1,
3190 stored(C,O,maybe), stored_complete(C,RO,NYesses).
3192 occurrence(_,_,RuleNb,ID), occurrence(C2,_,RuleNb,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
3193 ==> RO =< MO2 | % C2 is never stored
3194 passive(RuleNb,ID).
3199 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3201 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
3202 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
3203 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
3205 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
3206 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
3207 check_all_passive(RuleNb,IDs2).
3209 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
3210 check_all_passive(RuleNb,IDs).
3212 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
3213 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
3215 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3217 % collect the storage information
3218 stored(C,O,yes) \ stored_completing(C,O,Yesses)
3219 <=> NO is O + 1, NYesses is Yesses + 1,
3220 stored_completing(C,NO,NYesses).
3221 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
3222 <=> NO is O + 1,
3223 stored_completing(C,NO,Yesses).
3225 stored(C,O,no) \ stored_completing(C,O,Yesses)
3226 <=> stored_complete(C,O,Yesses).
3227 stored_completing(C,O,Yesses)
3228 <=> stored_complete(C,O,Yesses).
3230 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id) ==>
3231 O2 > O | passive(RuleNb,Id).
3233 % decide whether a constraint is stored
3234 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
3235 <=> RO =< MO | fail.
3236 is_stored(C) <=> true.
3238 % decide whether a constraint is suspends after occurrences
3239 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
3240 <=> RO =< MO | fail.
3241 is_finally_stored(C) <=> true.
3243 storage_analysis(Constraints) :-
3244 ( chr_pp_flag(storage_analysis,on) ->
3245 check_constraint_storages(Constraints)
3246 ;
3247 true
3248 ).
3250 check_constraint_storages([]).
3251 check_constraint_storages([C|Cs]) :-
3252 check_constraint_storage(C),
3253 check_constraint_storages(Cs).
3255 check_constraint_storage(C) :-
3256 get_max_occurrence(C,MO),
3257 check_occurrences_storage(C,1,MO).
3259 check_occurrences_storage(C,O,MO) :-
3260 ( O > MO ->
3261 stored_completing(C,1,0)
3262 ;
3263 check_occurrence_storage(C,O),
3264 NO is O + 1,
3265 check_occurrences_storage(C,NO,MO)
3266 ).
3268 check_occurrence_storage(C,O) :-
3269 get_occurrence(C,O,RuleNb,ID),
3270 ( is_passive(RuleNb,ID) ->
3271 stored(C,O,maybe)
3272 ;
3273 get_rule(RuleNb,PragmaRule),
3274 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
3275 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
3276 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
3277 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
3278 check_storage_head2(Head2,O,Heads1,Body)
3279 )
3280 ).
3282 check_storage_head1(Head,O,H1,H2,G) :-
3283 functor(Head,F,A),
3284 C = F/A,
3285 ( H1 == [Head],
3286 H2 == [],
3287 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
3288 Head =.. [_|L],
3289 no_matching(L,[]) ->
3290 stored(C,O,no)
3291 ;
3292 stored(C,O,maybe)
3293 ).
3295 no_matching([],_).
3296 no_matching([X|Xs],Prev) :-
3297 var(X),
3298 \+ memberchk_eq(X,Prev),
3299 no_matching(Xs,[X|Prev]).
3301 check_storage_head2(Head,O,H1,B) :-
3302 functor(Head,F,A),
3303 C = F/A,
3304 ( ( (H1 \== [], B == true ) ;
3305 \+ is_observed(F/A,O) ) ->
3306 stored(C,O,maybe)
3307 ;
3308 stored(C,O,yes)
3309 ).
3311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3313 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3314 %% ____ _ ____ _ _ _ _
3315 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
3316 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
3317 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
3318 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
3319 %% |_|
3321 constraints_code(Constraints,Clauses) :-
3322 (chr_pp_flag(reduced_indexing,on),
3323 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
3324 none_suspended_on_variables
3325 ;
3326 true
3327 ),
3328 constraints_code1(Constraints,L,[]),
3329 clean_clauses(L,Clauses).
3331 %===============================================================================
3332 :- chr_constraint constraints_code1/3.
3333 :- chr_option(mode,constraints_code1(+,+,+)).
3334 :- chr_option(type_declaration,constraints_code(list,any,any)).
3335 %-------------------------------------------------------------------------------
3336 constraints_code1([],L,T) <=> L = T.
3337 constraints_code1([C|RCs],L,T)
3338 <=>
3339 constraint_code(C,L,T1),
3340 constraints_code1(RCs,T1,T).
3341 %===============================================================================
3342 :- chr_constraint constraint_code/3.
3343 :- chr_option(mode,constraint_code(+,+,+)).
3344 %-------------------------------------------------------------------------------
3345 %% Generate code for a single CHR constraint
3346 constraint_code(Constraint, L, T)
3347 <=> true
3348 | ( (chr_pp_flag(debugable,on) ;
3349 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
3350 ( may_trigger(Constraint) ;
3351 get_allocation_occurrence(Constraint,AO),
3352 get_max_occurrence(Constraint,MO), MO >= AO ) )
3353 ->
3354 constraint_prelude(Constraint,Clause),
3355 L = [Clause | L1]
3356 ;
3357 L = L1
3358 ),
3359 Id = [0],
3360 occurrences_code(Constraint,1,Id,NId,L1,L2),
3361 gen_cond_attach_clause(Constraint,NId,L2,T).
3363 %===============================================================================
3364 %% Generate prelude predicate for a constraint.
3365 %% f(...) :- f/a_0(...,Susp).
3366 constraint_prelude(F/A, Clause) :-
3367 vars_susp(A,Vars,Susp,VarsSusp),
3368 Head =.. [ F | Vars],
3369 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
3370 build_head(F,A,[0],VarsSusp,Delegate),
3371 FTerm =.. [F|Vars],
3372 ( chr_pp_flag(debugable,on) ->
3373 use_auxiliary_predicate(insert_constraint_internal),
3374 generate_insert_constraint_call(F/A,Susp,InsertCall),
3375 make_name('attach_',F/A,AttachF),
3376 AttachCall =.. [AttachF,Vars2,Susp],
3377 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
3378 Clause =
3379 ( Head :-
3380 insert_constraint_internal(Stored,Vars2,Susp,Continuation,F,Vars),
3381 InsertCall,
3382 AttachCall,
3383 Inactive,
3384 (
3385 'chr debug_event'(call(Susp)),
3386 Delegate
3387 ;
3388 'chr debug_event'(fail(Susp)), !,
3389 fail
3390 ),
3391 (
3392 'chr debug_event'(exit(Susp))
3393 ;
3394 'chr debug_event'(redo(Susp)),
3395 fail
3396 )
3397 )
3398 ; get_allocation_occurrence(F/A,0) ->
3399 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
3400 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
3401 Clause = ( Head :- Goal, Inactive, Delegate )
3402 ;
3403 Clause = ( Head :- Delegate )
3404 ).
3406 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
3407 ( may_trigger(F/A) ->
3408 get_target_module(Mod),
3409 build_head(F,A,[0],VarsSusp,Delegate),
3410 Goal = Mod:Delegate
3411 ;
3412 Goal = true
3413 ).
3415 %===============================================================================
3416 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
3417 %-------------------------------------------------------------------------------
3418 has_active_occurrence(C) <=> has_active_occurrence(C,1).
3420 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
3421 O > MO | fail.
3422 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID) \
3423 has_active_occurrence(C,O) <=>
3424 NO is O + 1,
3425 has_active_occurrence(C,NO).
3426 has_active_occurrence(C,O) <=> true.
3427 %===============================================================================
3429 gen_cond_attach_clause(F/A,Id,L,T) :-
3430 ( is_finally_stored(F/A) ->
3431 get_allocation_occurrence(F/A,AllocationOccurrence),
3432 get_max_occurrence(F/A,MaxOccurrence),
3433 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
3434 ( only_ground_indexed_arguments(F/A) ->
3435 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
3436 ;
3437 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
3438 )
3439 ; vars_susp(A,Args,Susp,AllArgs),
3440 gen_uncond_attach_goal(F/A,Susp,Body,_)
3441 ),
3442 ( chr_pp_flag(debugable,on) ->
3443 Constraint =.. [F|Args],
3444 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
3445 ;
3446 DebugEvent = true
3447 ),
3448 build_head(F,A,Id,AllArgs,Head),
3449 Clause = ( Head :- DebugEvent,Body ),
3450 L = [Clause | T]
3451 ;
3452 L = T
3453 ).
3455 :- chr_constraint
3456 use_auxiliary_predicate/1,
3457 is_used_auxiliary_predicate/1.
3459 :- chr_option(mode,use_auxiliary_predicate(+)).
3461 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
3463 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
3465 is_used_auxiliary_predicate(P) <=> fail.
3467 % only called for constraints with
3468 % at least one
3469 % non-ground indexed argument
3470 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
3471 vars_susp(A,Args,Susp,AllArgs),
3472 make_suspension_continuation_goal(F/A,AllArgs,Closure),
3473 make_name('attach_',F/A,AttachF),
3474 Attach =.. [AttachF,Vars,Susp],
3475 FTerm =.. [F|Args],
3476 generate_insert_constraint_call(F/A,Susp,InsertCall),
3477 use_auxiliary_predicate(insert_constraint_internal),
3478 use_auxiliary_predicate(activate_constraint),
3479 ( may_trigger(F/A) ->
3480 Goal =
3481 (
3482 ( var(Susp) ->
3483 insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
3484 ;
3485 activate_constraint(Stored,Vars,Susp,_)
3486 ),
3487 ( Stored == yes ->
3488 InsertCall,
3489 Attach
3490 ;
3491 true
3492 )
3493 )
3494 ;
3495 Goal =
3496 (
3497 insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
3498 InsertCall,
3499 Attach
3500 )
3501 ).
3503 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
3504 vars_susp(A,Args,Susp,AllArgs),
3505 make_suspension_continuation_goal(F/A,AllArgs,Cont),
3506 ( \+ only_ground_indexed_arguments(F/A) ->
3507 make_name('attach_',F/A,AttachF),
3508 Attach =.. [AttachF,Vars,Susp]
3509 ;
3510 Attach = true
3511 ),
3512 FTerm =.. [F|Args],
3513 generate_insert_constraint_call(F/A,Susp,InsertCall),
3514 use_auxiliary_predicate(insert_constraint_internal),
3515 ( are_none_suspended_on_variables ->
3516 Goal =
3517 (
3518 insert_constraint_internal(Susp,F,Args),
3519 InsertCall
3520 )
3521 ;
3522 Goal =
3523 (
3524 insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
3525 InsertCall,
3526 Attach
3527 )
3528 ).
3530 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
3531 ( \+ only_ground_indexed_arguments(FA) ->
3532 make_name('attach_',FA,AttachF),
3533 Attach =.. [AttachF,Vars,Susp]
3534 ;
3535 Attach = true
3536 ),
3537 generate_insert_constraint_call(FA,Susp,InsertCall),
3538 ( chr_pp_flag(late_allocation,on) ->
3539 use_auxiliary_predicate(activate_constraint),
3540 AttachGoal =
3541 (
3542 activate_constraint(Stored,Vars, Susp, Generation),
3543 ( Stored == yes ->
3544 InsertCall,
3545 Attach
3546 ;
3547 true
3548 )
3549 )
3550 ;
3551 use_auxiliary_predicate(activate_constraint),
3552 AttachGoal =
3553 (
3554 activate_constraint(Stored,Vars, Susp, Generation)
3555 )
3556 ).
3558 %-------------------------------------------------------------------------------
3559 :- chr_constraint occurrences_code/6.
3560 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
3561 %-------------------------------------------------------------------------------
3562 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
3563 <=> O > MO
3564 | NId = Id, L = T.
3565 occurrences_code(C,O,Id,NId,L,T)
3566 <=>
3567 occurrence_code(C,O,Id,Id1,L,L1),
3568 NO is O + 1,
3569 occurrences_code(C,NO,Id1,NId,L1,T).
3570 %-------------------------------------------------------------------------------
3571 :- chr_constraint occurrence_code/6.
3572 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
3573 %-------------------------------------------------------------------------------
3574 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
3575 <=> NId = Id, L = T.
3576 occurrence(C,O,RuleNb,ID), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
3577 <=> true |
3578 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
3579 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
3580 NId = Id,
3581 head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
3582 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
3583 head2_code(Head2,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
3584 inc_id(Id,NId),
3585 ( unconditional_occurrence(C,O) ->
3586 L1 = T
3587 ;
3588 gen_alloc_inc_clause(C,O,Id,L1,T)
3589 )
3590 ).
3592 occurrence_code(C,O,_,_,_,_)
3593 <=>
3594 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
3595 %-------------------------------------------------------------------------------
3597 %% Generate code based on one removed head of a CHR rule
3598 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3599 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3600 Rule = rule(_,Head2,_,_),
3601 ( Head2 == [] ->
3602 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3603 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
3604 ;
3605 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
3606 ).
3608 %% Generate code based on one persistent head of a CHR rule
3609 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3610 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3611 Rule = rule(Head1,_,_,_),
3612 ( Head1 == [] ->
3613 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3614 propagation_code(Head,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
3615 ;
3616 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
3617 ).
3619 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
3620 vars_susp(A,Vars,Susp,VarsSusp),
3621 build_head(F,A,Id,VarsSusp,Head),
3622 inc_id(Id,IncId),
3623 build_head(F,A,IncId,VarsSusp,CallHead),
3624 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConditionalAlloc),
3625 Clause =
3626 (
3627 Head :-
3628 ConditionalAlloc,
3629 CallHead
3630 ),
3631 L = [Clause|T].
3633 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
3634 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
3635 ConstraintAllocationGoal =
3636 ( var(Susp) ->
3637 UncondConstraintAllocationGoal
3638 ;
3639 true
3640 ).
3641 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
3642 ( may_trigger(F/A) ->
3643 build_head(F,A,[0],VarsSusp,Term),
3644 get_target_module(Mod),
3645 Cont = Mod : Term
3646 ;
3647 Cont = true
3648 ),
3649 FTerm =.. [F|Vars],
3650 use_auxiliary_predicate(allocate_constraint),
3651 ConstraintAllocationGoal = allocate_constraint(Cont, Susp, F, Vars).
3653 gen_occ_allocation(FA,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal) :-
3654 get_allocation_occurrence(FA,AO),
3655 ( chr_pp_flag(debugable,off), O == AO ->
3656 ( may_trigger(FA) ->
3657 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3658 ;
3659 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3660 )
3661 ;
3662 ConstraintAllocationGoal = true
3663 ).
3664 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3667 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3669 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
3670 ( chr_pp_flag(guard_via_reschedule,on) ->
3671 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
3672 ;
3673 append(Retrievals,GuardList,GoalList),
3674 list2conj(GoalList,Goal)
3675 ).
3677 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
3678 initialize_unit_dictionary(Prelude,Dict),
3679 build_units(Retrievals,GuardList,Dict,Units),
3680 dependency_reorder(Units,NUnits),
3681 units2goal(NUnits,Goal).
3683 units2goal([],true).
3684 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
3685 units2goal(Units,Goals).
3687 dependency_reorder(Units,NUnits) :-
3688 dependency_reorder(Units,[],NUnits).
3690 dependency_reorder([],Acc,Result) :-
3691 reverse(Acc,Result).
3693 dependency_reorder([Unit|Units],Acc,Result) :-
3694 Unit = unit(_GID,_Goal,Type,GIDs),
3695 ( Type == fixed ->
3696 NAcc = [Unit|Acc]
3697 ;
3698 dependency_insert(Acc,Unit,GIDs,NAcc)
3699 ),
3700 dependency_reorder(Units,NAcc,Result).
3702 dependency_insert([],Unit,_,[Unit]).
3703 dependency_insert([X|Xs],Unit,GIDs,L) :-
3704 X = unit(GID,_,_,_),
3705 ( memberchk(GID,GIDs) ->
3706 L = [Unit,X|Xs]
3707 ;
3708 L = [X | T],
3709 dependency_insert(Xs,Unit,GIDs,T)
3710 ).
3712 build_units(Retrievals,Guard,InitialDict,Units) :-
3713 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
3714 build_guard_units(Guard,N,Dict,Tail).
3717 build_retrieval_units([],N,N,Dict,Dict,L,L).
3718 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
3719 term_variables(U,Vs),
3720 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3721 L = [unit(N,U,movable,GIDs)|L1],
3722 N1 is N + 1,
3723 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
3725 build_retrieval_units2([],N,N,Dict,Dict,L,L).
3726 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
3727 term_variables(U,Vs),
3728 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3729 L = [unit(N,U,fixed,GIDs)|L1],
3730 N1 is N + 1,
3731 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
3733 initialize_unit_dictionary(Term,Dict) :-
3734 term_variables(Term,Vars),
3735 pair_all_with(Vars,0,Dict).
3737 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
3738 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3739 ( lookup_eq(Dict,V,GID) ->
3740 ( (GID == This ; memberchk(GID,GIDs) ) ->
3741 GIDs1 = GIDs
3742 ;
3743 GIDs1 = [GID|GIDs]
3744 ),
3745 Dict1 = Dict
3746 ;
3747 Dict1 = [V - This|Dict],
3748 GIDs1 = GIDs
3749 ),
3750 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3752 build_guard_units(Guard,N,Dict,Units) :-
3753 ( Guard = [Goal] ->
3754 Units = [unit(N,Goal,fixed,[])]
3755 ; Guard = [Goal|Goals] ->
3756 term_variables(Goal,Vs),
3757 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
3758 Units = [unit(N,Goal,movable,GIDs)|RUnits],
3759 N1 is N + 1,
3760 build_guard_units(Goals,N1,NDict,RUnits)
3761 ).
3763 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
3764 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3765 ( lookup_eq(Dict,V,GID) ->
3766 ( (GID == This ; memberchk(GID,GIDs) ) ->
3767 GIDs1 = GIDs
3768 ;
3769 GIDs1 = [GID|GIDs]
3770 ),
3771 Dict1 = [V - This|Dict]
3772 ;
3773 Dict1 = [V - This|Dict],
3774 GIDs1 = GIDs
3775 ),
3776 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3778 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3780 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3781 %% ____ _ ____ _ _
3782 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
3783 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
3784 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
3785 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
3786 %%
3787 %% _ _ _ ___ __
3788 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
3789 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
3790 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
3791 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
3792 %% |_|
3793 :- chr_constraint
3794 functional_dependency/4,
3795 get_functional_dependency/4.
3797 :- chr_option(mode,functional_dependency(+,+,?,?)).
3799 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_) \ functional_dependency(C,RuleNb,Pattern,Key)
3800 <=>
3801 RuleNb > 1, AO > O
3802 |
3803 functional_dependency(C,1,Pattern,Key).
3805 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
3806 <=>
3807 RuleNb2 >= RuleNb1
3808 |
3809 QPattern = Pattern, QKey = Key.
3810 get_functional_dependency(_,_,_,_)
3811 <=>
3812 fail.
3814 functional_dependency_analysis(Rules) :-
3815 ( chr_pp_flag(functional_dependency_analysis,on) ->
3816 functional_dependency_analysis_main(Rules)
3817 ;
3818 true
3819 ).
3821 functional_dependency_analysis_main([]).
3822 functional_dependency_analysis_main([PRule|PRules]) :-
3823 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
3824 functional_dependency(C,RuleNb,Pattern,Key)
3825 ;
3826 true
3827 ),
3828 functional_dependency_analysis_main(PRules).
3830 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
3831 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
3832 Rule = rule(H1,H2,Guard,_),
3833 ( H1 = [C1],
3834 H2 = [C2] ->
3835 true
3836 ; H1 = [C1,C2],
3837 H2 == [] ->
3838 true
3839 ),
3840 check_unique_constraints(C1,C2,Guard,RuleNb,List),
3841 term_variables(C1,Vs),
3842 \+ (
3843 member(V1,Vs),
3844 lookup_eq(List,V1,V2),
3845 memberchk_eq(V2,Vs)
3846 ),
3847 select_pragma_unique_variables(Vs,List,Key1),
3848 copy_term_nat(C1-Key1,Pattern-Key),
3849 functor(C1,F,A).
3851 select_pragma_unique_variables([],_,[]).
3852 select_pragma_unique_variables([V|Vs],List,L) :-
3853 ( lookup_eq(List,V,_) ->
3854 L = T
3855 ;
3856 L = [V|T]
3857 ),
3858 select_pragma_unique_variables(Vs,List,T).
3860 % depends on functional dependency analysis
3861 % and shape of rule: C1 \ C2 <=> true.
3862 set_semantics_rules(Rules) :-
3863 ( chr_pp_flag(set_semantics_rule,on) ->
3864 set_semantics_rules_main(Rules)
3865 ;
3866 true
3867 ).
3869 set_semantics_rules_main([]).
3870 set_semantics_rules_main([R|Rs]) :-
3871 set_semantics_rule_main(R),
3872 set_semantics_rules_main(Rs).
3874 set_semantics_rule_main(PragmaRule) :-
3875 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
3876 ( Rule = rule([C1],[C2],true,_),
3877 IDs = ids([ID1],[ID2]),
3878 \+ is_passive(RuleNb,ID1),
3879 functor(C1,F,A),
3880 get_functional_dependency(F/A,RuleNb,Pattern,Key),
3881 copy_term_nat(Pattern-Key,C1-Key1),
3882 copy_term_nat(Pattern-Key,C2-Key2),
3883 Key1 == Key2 ->
3884 passive(RuleNb,ID2)
3885 ;
3886 true
3887 ).
3889 check_unique_constraints(C1,C2,G,RuleNb,List) :-
3890 \+ any_passive_head(RuleNb),
3891 variable_replacement(C1-C2,C2-C1,List),
3892 copy_with_variable_replacement(G,OtherG,List),
3893 negate_b(G,NotG),
3894 once(entails_b(NotG,OtherG)).
3896 % checks for rules of the shape ...,C1,C2... (<|=)==> ...
3897 % where C1 and C2 are symmteric constraints
3898 symmetry_analysis(Rules) :-
3899 ( chr_pp_flag(check_unnecessary_active,off) ->
3900 true
3901 ;
3902 symmetry_analysis_main(Rules)
3903 ).
3905 symmetry_analysis_main([]).
3906 symmetry_analysis_main([R|Rs]) :-
3907 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
3908 Rule = rule(H1,H2,_,_),
3909 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
3910 ; H2 == [] ), H1 \== [] ->
3911 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
3912 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
3913 ;
3914 true
3915 ),
3916 symmetry_analysis_main(Rs).
3918 symmetry_analysis_heads([],[],_,_,_,_).
3919 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
3920 ( \+ is_passive(RuleNb,ID),
3921 member2(PreHs,PreIDs,PreH-PreID),
3922 \+ is_passive(RuleNb,PreID),
3923 variable_replacement(PreH,H,List),
3924 copy_with_variable_replacement(Rule,Rule2,List),
3925 identical_rules(Rule,Rule2) ->
3926 passive(RuleNb,ID)
3927 ;
3928 true
3929 ),
3930 symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
3932 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3934 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3935 %% ____ _ _ _ __ _ _ _
3936 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
3937 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
3938 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
3939 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
3940 %% |_|
3942 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
3943 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
3944 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
3945 build_head(F,A,Id,HeadVars,ClauseHead),
3946 get_constraint_mode(F/A,Mode),
3947 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
3949 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
3951 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3952 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
3954 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
3955 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
3957 ( chr_pp_flag(debugable,on) ->
3958 Rule = rule(_,_,Guard,Body),
3959 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
3960 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
3961 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody)),
3962 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
3963 ;
3964 Cut = ActualCut
3965 ),
3966 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
3967 Clause = ( ClauseHead :-
3968 FirstMatching,
3969 RescheduledTest,
3970 Cut,
3971 SuspsDetachments,
3972 SuspDetachment,
3973 BodyCopy
3974 ),
3975 L = [Clause | T].
3977 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
3978 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
3980 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
3981 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
3982 list2conj(GoalList,Goal).
3984 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
3985 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
3986 ( var(Arg) ->
3987 ( lookup_eq(VarDict,Arg,OtherVar) ->
3988 ( Mode = (+) ->
3989 ( memberchk_eq(Arg,GroundVars) ->
3990 GoalList = [Var = OtherVar | RestGoalList],
3991 GroundVars1 = GroundVars
3992 ;
3993 GoalList = [Var == OtherVar | RestGoalList],
3994 GroundVars1 = [Arg|GroundVars]
3995 )
3996 ;
3997 GoalList = [Var == OtherVar | RestGoalList],
3998 GroundVars1 = GroundVars
3999 ),
4000 VarDict1 = VarDict
4001 ; VarDict1 = [Arg-Var | VarDict],
4002 GoalList = RestGoalList,
4003 ( Mode = (+) ->
4004 GroundVars1 = [Arg|GroundVars]
4005 ;
4006 GroundVars1 = GroundVars
4007 )
4008 ),
4009 Pairs = Rest,
4010 RestModes = Modes
4011 ; atomic(Arg) ->
4012 ( Mode = (+) ->
4013 GoalList = [ Var = Arg | RestGoalList]
4014 ;
4015 GoalList = [ Var == Arg | RestGoalList]
4016 ),
4017 VarDict = VarDict1,
4018 GroundVars1 = GroundVars,
4019 Pairs = Rest,
4020 RestModes = Modes
4021 ; Mode == (+), is_ground(GroundVars,Arg) ->
4022 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
4023 GoalList = [ Var = ArgCopy | RestGoalList],
4024 VarDict = VarDict1,
4025 GroundVars1 = GroundVars,
4026 Pairs = Rest,
4027 RestModes = Modes
4028 ; Arg =.. [_|Args],
4029 functor(Arg,Fct,N),
4030 functor(Term,Fct,N),
4031 Term =.. [_|Vars],
4032 ( Mode = (+) ->
4033 GoalList = [ Var = Term | RestGoalList ]
4034 ;
4035 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
4036 ),
4037 pairup(Args,Vars,NewPairs),
4038 append(NewPairs,Rest,Pairs),
4039 replicate(N,Mode,NewModes),
4040 append(NewModes,Modes,RestModes),
4041 VarDict1 = VarDict,
4042 GroundVars1 = GroundVars
4043 ),
4044 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
4046 is_ground(GroundVars,Term) :-
4047 ( ground(Term) ->
4048 true
4049 ; compound(Term) ->
4050 Term =.. [_|Args],
4051 maplist(is_ground(GroundVars),Args)
4052 ;
4053 memberchk_eq(Term,GroundVars)
4054 ).
4056 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
4057 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
4059 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
4060 ( Heads = [_|_] ->
4061 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
4062 ;
4063 GoalList = [],
4064 Susps = [],
4065 VarDict = NVarDict,
4066 GroundVars = NGroundVars
4067 ).
4069 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,AttrDict,GroundVars,GroundVars) :-
4070 instantiate_pattern_goals(AttrDict).
4071 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
4072 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict,GroundVars,NGroundVars) :-
4073 functor(H,F,A),
4074 head_info(H,A,Vars,_,_,Pairs),
4075 get_store_type(F/A,StoreType),
4076 ( StoreType == default ->
4077 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
4078 get_max_constraint_index(N),
4079 ( N == 1 ->
4080 VarSusps = Attr
4081 ;
4082 get_constraint_index(F/A,Pos),
4083 make_attr(N,_Mask,SuspsList,Attr),
4084 nth1(Pos,SuspsList,VarSusps)
4085 ),
4086 create_get_mutable_ref(active,State,GetMutable),
4087 get_constraint_mode(F/A,Mode),
4088 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
4089 NPairs = Pairs,
4090 sbag_member_call(Susp,VarSusps,Sbag),
4091 ExistentialLookup = (
4092 ViaGoal,
4093 Sbag,
4094 Susp = Suspension, % not inlined
4095 GetMutable
4096 )
4097 ;
4098 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,State,ExistentialLookup,Susp,Pairs,NPairs),
4099 get_constraint_mode(F/A,Mode),
4100 filter_mode(NPairs,Pairs,Mode,NMode),
4101 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
4102 NewAttrDict = AttrDict
4103 ),
4104 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
4105 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
4106 append(NPairs,VarDict1,DA_), % order important here
4107 translate(GroundVars1,DA_,GroundVarsA),
4108 translate(GroundVars1,VarDict1,GroundVarsB),
4109 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
4110 Goal =
4111 (
4112 ExistentialLookup,
4113 DiffSuspGoals,
4114 MatchingGoal2
4115 ),
4116 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict,GroundVars1,NGroundVars).
4118 inline_matching_goal(A==B,true,GVA,GVB) :-
4119 memberchk_eq(A,GVA),
4120 memberchk_eq(B,GVB),
4121 A=B, !.
4124 inline_matching_goal(A=B,true,_,_) :- A=B, !.
4125 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
4126 inline_matching_goal(A,A2,GVA,GVB),
4127 inline_matching_goal(B,B2,GVA,GVB).
4128 inline_matching_goal(X,X,_,_).
4131 filter_mode([],_,_,[]).
4132 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
4133 ( Var == V ->
4134 Modes = [M|MT],
4135 filter_mode(Rest,R,Ms,MT)
4136 ;
4137 filter_mode([Arg-Var|Rest],R,Ms,Modes)
4138 ).
4140 instantiate_pattern_goals([]).
4141 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
4142 get_max_constraint_index(N),
4143 ( N == 1 ->
4144 Goal = true
4145 ;
4146 make_attr(N,Mask,_,Attr),
4147 or_list(Bits,Pattern), !,
4148 Goal = (Mask /\ Pattern =:= Pattern)
4149 ),
4150 instantiate_pattern_goals(Rest).
4153 check_unique_keys([],_).
4154 check_unique_keys([V|Vs],Dict) :-
4155 lookup_eq(Dict,V,_),
4156 check_unique_keys(Vs,Dict).
4158 % Generates tests to ensure the found constraint differs from previously found constraints
4159 % TODO: detect more cases where constraints need be different
4160 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
4161 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
4162 list2conj(DiffSuspGoalList,DiffSuspGoals).
4164 different_from_other_susps_(_,[],_,_,[]) :- !.
4165 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
4166 ( functor(Head,F,A), functor(PreHead,F,A),
4167 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
4168 \+ \+ PreHeadCopy = HeadCopy ->
4170 List = [Susp \== PreSusp | Tail]
4171 ;
4172 List = Tail
4173 ),
4174 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
4176 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
4177 functor(Head,F,A),
4178 get_constraint_index(F/A,Pos),
4179 common_variables(Head,PrevHeads,CommonVars),
4180 translate(CommonVars,VarDict,Vars),
4181 or_pattern(Pos,Bit),
4182 ( permutation(Vars,PermutedVars),
4183 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
4184 member(Bit,Positions), !,
4185 NewAttrDict = AttrDict,
4186 Goal = true
4187 ;
4188 Goal = (Goal1, PatternGoal),
4189 gen_get_mod_constraints(Vars,Goal1,Attr),
4190 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
4191 ).
4193 common_variables(T,Ts,Vs) :-
4194 term_variables(T,V1),
4195 term_variables(Ts,V2),
4196 intersect_eq(V1,V2,Vs).
4198 gen_get_mod_constraints(L,Goal,Susps) :-
4199 get_target_module(Mod),
4200 ( L == [] ->
4201 Goal =
4202 ( 'chr default_store'(Global),
4203 get_attr(Global,Mod,TSusps),
4204 TSusps = Susps
4205 )
4206 ;
4207 ( L = [A] ->
4208 VIA = 'chr via_1'(A,V)
4209 ; ( L = [A,B] ->
4210 VIA = 'chr via_2'(A,B,V)
4211 ; VIA = 'chr via'(L,V)
4212 )
4213 ),
4214 Goal =
4215 ( VIA,
4216 get_attr(V,Mod,TSusps),
4217 TSusps = Susps
4218 )
4219 ).
4221 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
4222 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
4223 list2conj(GuardCopyList,GuardCopy).
4225 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
4226 Rule = rule(H,_,Guard,Body),
4227 conj2list(Guard,GuardList),
4228 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
4229 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
4231 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
4232 term_variables(RestGuardList,GuardVars),
4233 term_variables(RestGuardListCopyCore,GuardCopyVars),
4234 % variables that are declared to be ground don't need to be locked
4235 ground_vars(H,GroundVars),
4236 list_difference_eq(GuardVars,GroundVars,GuardVars_),
4237 ( chr_pp_flag(guard_locks,on),
4238 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
4239 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
4240 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
4241 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
4242 ),
4243 LocksUnlocks) ->
4244 once(pairup(Locks,Unlocks,LocksUnlocks))
4245 ;
4246 Locks = [],
4247 Unlocks = []
4248 ),
4249 list2conj(Locks,LockPhase),
4250 list2conj(Unlocks,UnlockPhase),
4251 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
4252 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
4253 my_term_copy(Body,VarDict2,BodyCopy).
4256 split_off_simple_guard([],_,[],[]).
4257 split_off_simple_guard([G|Gs],VarDict,S,C) :-
4258 ( simple_guard(G,VarDict) ->
4259 S = [G|Ss],
4260 split_off_simple_guard(Gs,VarDict,Ss,C)
4261 ;
4262 S = [],
4263 C = [G|Gs]
4264 ).
4266 % simple guard: cheap and benign (does not bind variables)
4267 simple_guard(G,VarDict) :-
4268 binds_b(G,Vars),
4269 \+ (( member(V,Vars),
4270 lookup_eq(VarDict,V,_)
4271 )).
4273 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
4274 ( is_stored(FA) ->
4275 ( (Id == [0];
4276 (get_allocation_occurrence(FA,AO),
4277 get_max_occurrence(FA,MO),
4278 MO < AO )),
4279 only_ground_indexed_arguments(FA), chr_pp_flag(late_allocation,on) ->
4280 SuspDetachment = true
4281 ;
4282 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
4283 ( chr_pp_flag(late_allocation,on) ->
4284 SuspDetachment =
4285 ( var(Susp) ->
4286 true
4287 ; UnCondSuspDetachment
4288 )
4289 ;
4290 SuspDetachment = UnCondSuspDetachment
4291 )
4292 )
4293 ;
4294 SuspDetachment = true
4295 ).
4297 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
4298 ( is_stored(FA) ->
4299 ( \+ only_ground_indexed_arguments(FA) ->
4300 make_name('detach_',FA,Fct),
4301 Detach =.. [Fct,Vars,Susp]
4302 ;
4303 Detach = true
4304 ),
4305 ( chr_pp_flag(debugable,on) ->
4306 DebugEvent = 'chr debug_event'(remove(Susp))
4307 ;
4308 DebugEvent = true
4309 ),
4310 generate_delete_constraint_call(FA,Susp,DeleteCall),
4311 use_auxiliary_predicate(remove_constraint_internal),
4312 ( are_none_suspended_on_variables ->
4313 SuspDetachment =
4314 (
4315 DebugEvent,
4316 remove_constraint_internal(Susp),
4317 DeleteCall,
4318 Detach
4319 )
4320 ;
4321 SuspDetachment =
4322 (
4323 DebugEvent,
4324 remove_constraint_internal(Susp, Vars, Delete),
4325 ( Delete == yes ->
4326 DeleteCall,
4327 Detach
4328 ;
4329 true
4330 )
4331 )
4332 )
4333 ;
4334 SuspDetachment = true
4335 ).
4337 gen_uncond_susps_detachments([],[],true).
4338 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
4339 functor(Term,F,A),
4340 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
4341 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
4343 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4345 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4346 %% ____ _ _ _ _
4347 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
4348 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
4349 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
4350 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
4351 %% |_| |___/
4353 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
4354 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
4355 Rule = rule(_Heads,Heads2,Guard,Body),
4357 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
4358 get_constraint_mode(F/A,Mode),
4359 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
4361 build_head(F,A,Id,HeadVars,ClauseHead),
4363 append(RestHeads,Heads2,Heads),
4364 append(OtherIDs,Heads2IDs,IDs),
4365 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
4366 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
4367 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
4369 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
4370 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
4372 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
4373 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
4375 ( chr_pp_flag(debugable,on) ->
4376 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4377 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
4378 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
4379 instrument_goal((!),DebugTry,DebugApply,Cut)
4380 ;
4381 Cut = (!)
4382 ),
4384 Clause = ( ClauseHead :-
4385 FirstMatching,
4386 RescheduledTest,
4387 Cut,
4388 SuspsDetachments,
4389 SuspDetachment,
4390 BodyCopy
4391 ),
4392 L = [Clause | T].
4394 split_by_ids([],[],_,[],[]).
4395 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
4396 ( memberchk_eq(I,I1s) ->
4397 S1s = [S | R1s],
4398 S2s = R2s
4399 ;
4400 S1s = R1s,
4401 S2s = [S | R2s]
4402 ),
4403 split_by_ids(Is,Ss,I1s,R1s,R2s).
4405 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4408 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4409 %% ____ _ _ _ ____
4410 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
4411 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
4412 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
4413 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
4414 %% |_| |___/
4416 %% Genereate prelude + worker predicate
4417 %% prelude calls worker
4418 %% worker iterates over one type of removed constraints
4419 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
4420 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
4421 Rule = rule(Heads1,_,Guard,Body),
4422 append(Heads1,RestHeads2,Heads),
4423 append(IDs1,RestIDs,IDs),
4424 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
4425 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
4426 extend_id(Id,Id1),
4427 ( memberchk_eq(NID,IDs2) ->
4428 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
4429 ;
4430 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
4431 ),
4432 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
4433 simpagation_head2_new_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
4435 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
4436 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
4437 Heads = [Head|RHeads],
4438 inc_id(Id,Id1),
4439 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
4440 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
4441 ( memberchk_eq(ID,IDs2) ->
4442 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
4443 ;
4444 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
4445 ).
4447 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4448 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
4449 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4450 build_head(F,A,Id1,VarsSusp,ClauseHead),
4451 get_constraint_mode(F/A,Mode),
4452 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
4454 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
4456 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal),
4458 extend_id(Id1,DelegateId),
4459 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
4460 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
4461 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
4463 PreludeClause =
4464 ( ClauseHead :-
4465 FirstMatching,
4466 ModConstraintsGoal,
4467 !,
4468 ConstraintAllocationGoal,
4469 Delegate
4470 ),
4471 L = [PreludeClause|T].
4473 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
4474 Term =.. [_|Args],
4475 delegate_variables(Term,Terms,VarDict,Args,Vars).
4477 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
4478 term_variables(PrevTerms,PrevVars),
4479 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
4481 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
4482 term_variables(Term,V1),
4483 term_variables(Terms,V2),
4484 intersect_eq(V1,V2,V3),
4485 list_difference_eq(V3,PrevVars,V4),
4486 translate(V4,VarDict,Vars).
4489 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4490 simpagation_head2_new_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
4492 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
4493 Rule = rule(_,_,Guard,Body),
4494 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,PreSusps),
4496 gen_var(OtherSusp),
4497 gen_var(OtherSusps),
4499 functor(CurrentHead,OtherF,OtherA),
4500 gen_vars(OtherA,OtherVars),
4501 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
4502 get_constraint_mode(OtherF/OtherA,Mode),
4503 % head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
4504 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
4506 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4507 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
4508 create_get_mutable_ref(active,State,GetMutable),
4509 CurrentSuspTest = (
4510 OtherSusp = OtherSuspension,
4511 GetMutable,
4512 DiffSuspGoals,
4513 FirstMatching
4514 ),
4516 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4517 build_head(F,A,Id,ClauseVars,ClauseHead),
4519 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
4520 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
4521 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
4523 gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
4525 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4526 build_head(F,A,Id,RecursiveVars,RecursiveCall),
4527 RecursiveVars2 = [[]|PreVarsAndSusps],
4528 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
4530 guard_body_copies2(Rule,VarDict2,GuardCopyList,BodyCopy),
4531 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,CurrentSuspTest),RescheduledTest),
4532 ( BodyCopy \== true, is_observed(F/A,O) ->
4533 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4534 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
4535 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
4536 ; Attachment = true,
4537 ConditionalRecursiveCall = RecursiveCall,
4538 ConditionalRecursiveCall2 = RecursiveCall2
4539 ),
4541 ( chr_pp_flag(debugable,on) ->
4542 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4543 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
4544 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
4545 ;
4546 DebugTry = true,
4547 DebugApply = true
4548 ),
4550 ( member(unique(ID1,UniqueKeys), Pragmas),
4551 check_unique_keys(UniqueKeys,VarDict) ->
4552 Clause =
4553 ( ClauseHead :-
4554 ( CurrentSuspTest ->
4555 ( RescheduledTest,
4556 DebugTry ->
4557 DebugApply,
4558 Susps1Detachments,
4559 Attachment,
4560 BodyCopy,
4561 ConditionalRecursiveCall2
4562 ;
4563 RecursiveCall2
4564 )
4565 ;
4566 RecursiveCall
4567 )
4568 )
4569 ;
4570 Clause =
4571 ( ClauseHead :-
4572 ( CurrentSuspTest,
4573 RescheduledTest,
4574 DebugTry ->
4575 DebugApply,
4576 Susps1Detachments,
4577 Attachment,
4578 BodyCopy,
4579 ConditionalRecursiveCall
4580 ;
4581 RecursiveCall
4582 )
4583 )
4584 ),
4585 L = [Clause | T].
4587 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
4588 length(Args,N),
4589 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
4590 create_get_mutable_ref(active,State,GetState),
4591 create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
4592 ConditionalCall =
4593 ( Susp = Suspension,
4594 GetState,
4595 GetGeneration ->
4596 'chr update_mutable'(inactive,State),
4597 Call
4598 ; true
4599 ).
4601 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4604 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4605 %% ____ _ _
4606 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
4607 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
4608 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
4609 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
4610 %% |_| |___/
4612 propagation_code(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4613 ( RestHeads == [] ->
4614 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
4615 ;
4616 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
4617 ).
4618 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4619 %% Single headed propagation
4620 %% everything in a single clause
4621 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
4622 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4623 build_head(F,A,Id,VarsSusp,ClauseHead),
4625 inc_id(Id,NextId),
4626 build_head(F,A,NextId,VarsSusp,NextHead),
4628 get_constraint_mode(F/A,Mode),
4629 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
4630 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4631 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,Allocation),
4633 % - recursive call -
4634 RecursiveCall = NextHead,
4635 ( BodyCopy \== true, is_observed(F/A,O) ->
4636 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4637 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4638 ; Attachment = true,
4639 ConditionalRecursiveCall = RecursiveCall
4640 ),
4642 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
4643 ActualCut = true
4644 ;
4645 ActualCut = !
4646 ),
4648 ( chr_pp_flag(debugable,on) ->
4649 Rule = rule(_,_,Guard,Body),
4650 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4651 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
4652 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
4653 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4654 ;
4655 Cut = ActualCut
4656 ),
4658 ( may_trigger(F/A) ->
4659 NovelProduction = 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
4660 ExtendHistory = 'chr extend_history'(Susp,RuleNb)
4661 ;
4662 NovelProduction = true,
4663 ExtendHistory = true
4664 ),
4666 Clause = (
4667 ClauseHead :-
4668 HeadMatching,
4669 Allocation,
4670 NovelProduction,
4671 GuardCopy,
4672 Cut,
4673 ExtendHistory,
4674 Attachment,
4675 BodyCopy,
4676 ConditionalRecursiveCall
4677 ),
4678 ProgramList = [Clause | ProgramTail].
4680 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4681 %% multi headed propagation
4682 %% prelude + predicates to accumulate the necessary combinations of suspended
4683 %% constraints + predicate to execute the body
4684 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4685 RestHeads = [First|Rest],
4686 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
4687 extend_id(Id,ExtendedId),
4688 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
4690 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4691 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
4692 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4693 build_head(F,A,Id,VarsSusp,PreludeHead),
4694 get_constraint_mode(F/A,Mode),
4695 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
4696 Rule = rule(_,_,Guard,Body),
4697 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
4699 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
4701 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,CondAllocation),
4703 extend_id(Id,NestedId),
4704 append([Susps|VarsSusp],ExtraVars,NestedVars),
4705 build_head(F,A,NestedId,NestedVars,NestedHead),
4706 NestedCall = NestedHead,
4708 Prelude = (
4709 PreludeHead :-
4710 FirstMatching,
4711 FirstSuspGoal,
4712 !,
4713 CondAllocation,
4714 NestedCall
4715 ),
4716 L = [Prelude|T].
4718 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4719 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4720 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
4721 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
4724 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4725 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
4726 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
4727 inc_id(Id,IncId),
4728 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
4730 check_fd_lookup_condition(_,_,_,_) :- fail.
4731 %check_fd_lookup_condition(F,A,_,_) :-
4732 % get_store_type(F/A,global_singleton), !.
4733 %check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
4734 % get_functional_dependency(F/A,1,P,K),
4735 % copy_term(P-K,CurrentHead-Key),
4736 % term_variables(PreHeads,PreVars),
4737 % intersect_eq(Key,PreVars,Key).
4739 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
4740 Rule = rule(_,_,Guard,Body),
4741 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
4742 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
4743 init(AllSusps,RestSusps),
4744 last(AllSusps,Susp),
4745 gen_var(OtherSusp),
4746 gen_var(OtherSusps),
4747 functor(CurrentHead,OtherF,OtherA),
4748 gen_vars(OtherA,OtherVars),
4749 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4750 create_get_mutable_ref(active,State,GetMutable),
4751 CurrentSuspTest = (
4752 OtherSusp = Suspension,
4753 GetMutable
4754 ),
4755 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4756 build_head(F,A,Id,ClauseVars,ClauseHead),
4757 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
4758 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
4759 RecursiveVars = PreVarsAndSusps1
4760 ;
4761 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4762 PrevId = Id
4763 ),
4764 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
4765 RecursiveCall = RecursiveHead,
4766 CurrentHead =.. [_|OtherArgs],
4767 pairup(OtherArgs,OtherVars,OtherPairs),
4768 get_constraint_mode(OtherF/OtherA,Mode),
4769 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
4771 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
4772 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4774 ( BodyCopy \== true, is_observed(F/A,O) ->
4775 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
4776 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4777 ; Attach = true,
4778 ConditionalRecursiveCall = RecursiveCall
4779 ),
4780 ( is_least_occurrence(RuleNb) ->
4781 NovelProduction = true,
4782 ExtendHistory = true
4783 ;
4784 get_occurrence(F/A,O,_,ID),
4786 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
4787 Tuple =.. [t,RuleNb|HistorySusps],
4788 bagof('chr novel_production'(X,Y),( lists:member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
4789 list2conj(NovelProductionsList,NovelProductions),
4790 NovelProduction = ( TupleVar = Tuple, NovelProductions),
4791 ExtendHistory = 'chr extend_history'(Susp,TupleVar)
4792 ),
4795 ( chr_pp_flag(debugable,on) ->
4796 Rule = rule(_,_,Guard,Body),
4797 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4798 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
4799 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
4800 ;
4801 DebugTry = true,
4802 DebugApply = true
4803 ),
4805 Clause = (
4806 ClauseHead :-
4807 ( CurrentSuspTest,
4808 DiffSuspGoals,
4809 Matching,
4810 NovelProduction,
4811 GuardCopy,
4812 DebugTry ->
4813 DebugApply,
4814 ExtendHistory,
4815 Attach,
4816 BodyCopy,
4817 ConditionalRecursiveCall
4818 ; RecursiveCall
4819 )
4820 ),
4821 L = [Clause|T].
4823 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
4824 reverse(ReversedRestSusps,RestSusps),
4825 pairup([ID|RestIDs],[Susp|RestSusps],IDSusps),
4826 sort(IDSusps,SortedIDSusps),
4827 pairup(_,HistorySusps,SortedIDSusps).
4829 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
4830 !,
4831 functor(Head,F,A),
4832 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
4833 get_constraint_mode(F/A,Mode),
4834 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
4835 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4836 append(VarsSusp,ExtraVars,HeadVars).
4837 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
4838 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
4839 functor(Head,F,A),
4840 gen_var(Susps),
4841 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4842 get_constraint_mode(F/A,Mode),
4843 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4844 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4845 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
4847 % returns
4848 % VarDict for the copies of variables in the original heads
4849 % VarsSuspsList list of lists of arguments for the successive heads
4850 % FirstVarsSusp top level arguments
4851 % SuspList list of all suspensions
4852 % Iterators list of all iterators
4853 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
4854 !,
4855 functor(Head,F,A),
4856 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), % make variables for argument positions
4857 get_constraint_mode(F/A,Mode),
4858 head_arg_matches(HeadPairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
4859 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
4860 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
4861 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
4862 % gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,[SuspList],Iterators),
4863 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators), % needed almost an hour to find this nasty typo/bug
4864 functor(Head,F,A),
4865 gen_var(Susps),
4866 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4867 get_constraint_mode(F/A,Mode),
4868 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4869 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
4870 append(HeadVars,[Susp,Susps],Vars).
4872 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
4873 !,
4874 functor(Head,F,A),
4875 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
4876 get_constraint_mode(F/A,Mode),
4877 head_arg_matches(Pairs,Mode,[],_,VarDict),
4878 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4879 append(VarsSusp,ExtraVars,HeadVars).
4880 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
4881 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
4882 functor(Head,F,A),
4883 gen_var(Susps),
4884 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
4885 get_constraint_mode(F/A,Mode),
4886 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
4887 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4888 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
4890 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4892 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4893 %% ____ _ _ _ _
4894 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
4895 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
4896 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
4897 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
4898 %%
4899 %% ____ _ _ _
4900 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
4901 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
4902 %% | _ < __/ |_| | | | __/\ V / (_| | |
4903 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
4904 %%
4905 %% ____ _ _
4906 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
4907 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
4908 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
4909 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
4910 %% |___/
4912 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4913 ( chr_pp_flag(reorder_heads,on) ->
4914 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
4915 ;
4916 NRestHeads = RestHeads,
4917 NRestIDs = RestIDs
4918 ).
4920 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4921 term_variables(Head,Vars),
4922 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
4923 copy_term_nat(InitialData,InitialDataCopy),
4924 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
4925 InitialDataCopy = InitialData,
4926 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
4927 reverse(RNRestHeads,NRestHeads),
4928 reverse(RNRestIDs,NRestIDs).
4930 final_data(Entry) :-
4931 Entry = entry(_,_,_,_,[],_).
4933 expand_data(Entry,NEntry,Cost) :-
4934 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
4935 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
4936 term_variables([Head1|Vars],Vars1),
4937 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
4938 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
4940 % Assigns score to head based on known variables and heads to lookup
4941 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4942 functor(Head,F,A),
4943 get_store_type(F/A,StoreType),
4944 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
4947 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4948 term_variables(Head,HeadVars),
4949 term_variables(RestHeads,RestVars),
4950 order_score_vars(HeadVars,KnownVars,RestVars,Score).
4951 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4952 order_score_indexes(Indexes,Head,KnownVars,0,Score).
4953 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4954 order_score_indexes(Indexes,Head,KnownVars,0,Score).
4955 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4956 term_variables(Head,HeadVars),
4957 term_variables(RestHeads,RestVars),
4958 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
4959 Score is Score_ * 2.
4960 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
4961 Score = 1. % guaranteed O(1)
4963 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4964 find_with_var_identity(
4965 S,
4966 t(Head,KnownVars,RestHeads),
4967 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
4968 Scores
4969 ),
4970 min_list(Scores,Score).
4973 order_score_indexes([],_,_,Score,NScore) :-
4974 Score > 0, NScore = 100.
4975 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
4976 multi_hash_key_args(I,Head,Args),
4977 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
4978 Score1 is Score + 1
4979 ;
4980 Score1 = Score
4981 ),
4982 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
4984 order_score_vars(Vars,KnownVars,RestVars,Score) :-
4985 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
4986 ( K-R-O == 0-0-0 ->
4987 Score = 0
4988 ; K > 0 ->
4989 Score is max(10 - K,0)
4990 ; R > 0 ->
4991 Score is max(10 - R,1) * 10
4992 ;
4993 Score is max(10-O,1) * 100
4994 ).
4995 order_score_count_vars([],_,_,0-0-0).
4996 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
4997 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
4998 ( memberchk_eq(V,KnownVars) ->
4999 NK is K + 1,
5000 NR = R, NO = O
5001 ; memberchk_eq(V,RestVars) ->
5002 NR is R + 1,
5003 NK = K, NO = O
5004 ;
5005 NO is O + 1,
5006 NK = K, NR = R
5007 ).
5009 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5010 %% ___ _ _ _
5011 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
5012 %% | || '_ \| | | '_ \| | '_ \ / _` |
5013 %% | || | | | | | | | | | | | | (_| |
5014 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
5015 %% |___/
5017 %% SWI begin
5018 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
5019 %% SWI end
5021 %% SICStus begin
5022 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
5023 %% SICStus end
5025 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5027 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5028 %% _ _ _ _ _ _ _
5029 %% | | | | |_(_) (_) |_ _ _
5030 %% | | | | __| | | | __| | | |
5031 %% | |_| | |_| | | | |_| |_| |
5032 %% \___/ \__|_|_|_|\__|\__, |
5033 %% |___/
5035 gen_var(_).
5036 gen_vars(N,Xs) :-
5037 length(Xs,N).
5039 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
5040 vars_susp(A,Vars,Susp,VarsSusp),
5041 Head =.. [_|Args],
5042 pairup(Args,Vars,HeadPairs).
5044 inc_id([N|Ns],[O|Ns]) :-
5045 O is N + 1.
5046 dec_id([N|Ns],[M|Ns]) :-
5047 M is N - 1.
5049 extend_id(Id,[0|Id]).
5051 next_id([_,N|Ns],[O|Ns]) :-
5052 O is N + 1.
5054 build_head(F,A,Id,Args,Head) :-
5055 buildName(F,A,Id,Name),
5056 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
5057 ( may_trigger(F/A) ;
5058 get_allocation_occurrence(F/A,AO),
5059 get_max_occurrence(F/A,MO),
5060 MO >= AO ) ) ->
5061 Head =.. [Name|Args]
5062 ;
5063 init(Args,ArgsWOSusp), % XXX not entirely correct!
5064 Head =.. [Name|ArgsWOSusp]
5065 ).
5067 buildName(Fct,Aty,List,Result) :-
5068 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
5069 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
5070 MO >= AO ) ; List \= [0])) ) ) ->
5071 atom_concat(Fct, (/) ,FctSlash),
5072 atomic_concat(FctSlash,Aty,FctSlashAty),
5073 buildName_(List,FctSlashAty,Result)
5074 ;
5075 Result = Fct
5076 ).
5078 buildName_([],Name,Name).
5079 buildName_([N|Ns],Name,Result) :-
5080 buildName_(Ns,Name,Name1),
5081 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
5082 atomic_concat(NameDash,N,Result).
5084 vars_susp(A,Vars,Susp,VarsSusp) :-
5085 length(Vars,A),
5086 append(Vars,[Susp],VarsSusp).
5088 make_attr(N,Mask,SuspsList,Attr) :-
5089 length(SuspsList,N),
5090 Attr =.. [v,Mask|SuspsList].
5092 or_pattern(Pos,Pat) :-
5093 Pow is Pos - 1,
5094 Pat is 1 << Pow. % was 2 ** X
5096 and_pattern(Pos,Pat) :-
5097 X is Pos - 1,
5098 Y is 1 << X, % was 2 ** X
5099 Pat is (-1)*(Y + 1).
5101 make_name(Prefix,F/A,Name) :-
5102 atom_concat_list([Prefix,F,(/),A],Name).
5104 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5105 % Storetype dependent lookup
5106 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
5107 functor(Head,F,A),
5108 get_store_type(F/A,StoreType),
5109 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
5111 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
5112 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
5113 instantiate_pattern_goals(AttrDict),
5114 get_max_constraint_index(N),
5115 ( N == 1 ->
5116 AllSusps = Attr
5117 ;
5118 functor(Head,F,A),
5119 get_constraint_index(F/A,Pos),
5120 make_attr(N,_,SuspsList,Attr),
5121 nth1(Pos,SuspsList,AllSusps)
5122 ).
5123 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
5124 once((
5125 member(Index,Indexes),
5126 multi_hash_key_args(Index,Head,KeyArgs),
5127 (translate(KeyArgs,VarDict,KeyArgCopies) ;
5128 ground(KeyArgs), KeyArgCopies = KeyArgs )
5129 )),
5130 ( KeyArgCopies = [KeyCopy] ->
5131 true
5132 ;
5133 KeyCopy =.. [k|KeyArgCopies]
5134 ),
5135 functor(Head,F,A),
5136 multi_hash_via_lookup_name(F/A,Index,ViaName),
5137 Goal =.. [ViaName,KeyCopy,AllSusps],
5138 update_store_type(F/A,multi_inthash([Index])).
5139 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
5140 once((
5141 member(Index,Indexes),
5142 multi_hash_key_args(Index,Head,KeyArgs),
5143 (translate(KeyArgs,VarDict,KeyArgCopies) ;
5144 ground(KeyArgs), KeyArgCopies = KeyArgs )
5145 )),
5146 ( KeyArgCopies = [KeyCopy] ->
5147 true
5148 ;
5149 KeyCopy =.. [k|KeyArgCopies]
5150 ),
5151 functor(Head,F,A),
5152 multi_hash_via_lookup_name(F/A,Index,ViaName),
5153 Goal =.. [ViaName,KeyCopy,AllSusps],
5154 update_store_type(F/A,multi_hash([Index])).
5155 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
5156 functor(Head,F,A),
5157 global_ground_store_name(F/A,StoreName),
5158 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
5159 update_store_type(F/A,global_ground).
5160 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
5161 functor(Head,F,A),
5162 global_singleton_store_name(F/A,StoreName),
5163 make_get_store_goal(StoreName,Susp,GetStoreGoal),
5164 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
5165 update_store_type(F/A,global_singleton).
5166 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
5167 once((
5168 member(ST,StoreTypes),
5169 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
5170 )).
5172 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :- !,
5173 functor(Head,F,A),
5174 global_singleton_store_name(F/A,StoreName),
5175 make_get_store_goal(StoreName,Susp,GetStoreGoal),
5176 Goal = (
5177 GetStoreGoal, % nb_getval(StoreName,Susp),
5178 Susp \== [],
5179 Susp = SuspTerm
5180 ),
5181 update_store_type(F/A,global_singleton).
5182 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
5183 once((
5184 member(ST,StoreTypes),
5185 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs)
5186 )).
5187 existential_lookup(multi_inthash(Indexes),Head,_PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
5188 once((
5189 member(Index,Indexes),
5190 multi_hash_key_args(Index,Head,KeyArgs),
5191 (translate(KeyArgs,VarDict,KeyArgCopies) ;
5192 ground(KeyArgs), KeyArgCopies = KeyArgs )
5193 )),
5194 ( KeyArgCopies = [KeyCopy] ->
5195 true
5196 ;
5197 KeyCopy =.. [k|KeyArgCopies]
5198 ),
5199 functor(Head,F,A),
5200 multi_hash_via_lookup_name(F/A,Index,ViaName),
5201 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
5202 create_get_mutable_ref(active,State,GetMutable),
5203 sbag_member_call(Susp,AllSusps,Sbag),
5204 Goal = (
5205 LookupGoal,
5206 Sbag,
5207 Susp = SuspTerm, % not inlined
5208 GetMutable
5209 ),
5210 hash_index_filter(Pairs,Index,NPairs),
5211 update_store_type(F/A,multi_inthash([Index])).
5212 existential_lookup(multi_hash(Indexes),Head,_PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
5213 once((
5214 member(Index,Indexes),
5215 multi_hash_key_args(Index,Head,KeyArgs),
5216 (translate(KeyArgs,VarDict,KeyArgCopies) ;
5217 ground(KeyArgs), KeyArgCopies = KeyArgs )
5218 )),
5219 ( KeyArgCopies = [KeyCopy] ->
5220 true
5221 ;
5222 KeyCopy =.. [k|KeyArgCopies]
5223 ),
5224 functor(Head,F,A),
5225 multi_hash_via_lookup_name(F/A,Index,ViaName),
5226 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
5227 sbag_member_call(Susp,AllSusps,Sbag),
5228 create_get_mutable_ref(active,State,GetMutable),
5229 Goal = (
5230 LookupGoal,
5231 Sbag,
5232 Susp = SuspTerm, % not inlined
5233 GetMutable
5234 ),
5235 hash_index_filter(Pairs,Index,NPairs),
5236 update_store_type(F/A,multi_hash([Index])).
5237 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :-
5238 lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),
5239 sbag_member_call(Susp,Susps,Sbag),
5240 create_get_mutable_ref(active,State,GetMutable),
5241 Goal = (
5242 UGoal,
5243 Sbag,
5244 Susp = SuspTerm, % not inlined
5245 GetMutable
5246 ).
5250 hash_index_filter(Pairs,Index,NPairs) :-
5251 ( integer(Index) ->
5252 NIndex = [Index]
5253 ;
5254 NIndex = Index
5255 ),
5256 hash_index_filter(Pairs,NIndex,1,NPairs).
5258 hash_index_filter([],_,_,[]).
5259 hash_index_filter([P|Ps],Index,N,NPairs) :-
5260 ( Index = [I|Is] ->
5261 NN is N + 1,
5262 ( I > N ->
5263 NPairs = [P|NPs],
5264 hash_index_filter(Ps,[I|Is],NN,NPs)
5265 ; I == N ->
5266 NPairs = NPs,
5267 hash_index_filter(Ps,Is,NN,NPs)
5268 )
5269 ;
5270 NPairs = [P|Ps]
5271 ).
5273 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5274 assume_constraint_stores([]).
5275 assume_constraint_stores([C|Cs]) :-
5276 ( only_ground_indexed_arguments(C),
5277 is_stored(C),
5278 get_store_type(C,default) ->
5279 get_indexed_arguments(C,IndexedArgs),
5280 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
5281 predsort(longer_list,UnsortedIndexes,Indexes),
5282 ( get_functional_dependency(C,1,Pattern,Key),
5283 all_distinct_var_args(Pattern), Key == [] ->
5284 assumed_store_type(C,global_singleton)
5285 ;
5286 ( get_constraint_type(C,Type),
5287 findall(Index,(sublist(Index,IndexedArgs), Index = [I],
5288 nth(I,Type,dense_int)),IndexesA),
5289 IndexesA \== [] ->
5290 list_difference_eq(Indexes,IndexesA,IndexesB),
5291 ( IndexesB \== [] ->
5292 assumed_store_type(C,multi_store([multi_inthash(IndexesA),multi_hash(IndexesB),global_ground]))
5293 ;
5294 assumed_store_type(C,multi_store([multi_inthash(IndexesA),global_ground]))
5295 )
5296 ;
5297 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
5298 )
5299 )
5300 ;
5301 true
5302 ),
5303 assume_constraint_stores(Cs).
5305 longer_list(R,L1,L2) :-
5306 length(L1,N1),
5307 length(L2,N2),
5308 compare(Rt,N2,N1),
5309 ( Rt == (=) ->
5310 compare(R,L1,L2)
5311 ;
5312 R = Rt
5313 ).
5315 all_distinct_var_args(Term) :-
5316 Term =.. [_|Args],
5317 copy_term_nat(Args,NArgs),
5318 all_distinct_var_args_(NArgs).
5320 all_distinct_var_args_([]).
5321 all_distinct_var_args_([X|Xs]) :-
5322 var(X),
5323 X = t,
5324 all_distinct_var_args_(Xs).
5326 get_indexed_arguments(C,IndexedArgs) :-
5327 C = F/A,
5328 get_indexed_arguments(1,A,C,IndexedArgs).
5330 get_indexed_arguments(I,N,C,L) :-
5331 ( I > N ->
5332 L = []
5333 ; ( is_indexed_argument(C,I) ->
5334 L = [I|T]
5335 ;
5336 L = T
5337 ),
5338 J is I + 1,
5339 get_indexed_arguments(J,N,C,T)
5340 ).
5342 validate_store_type_assumptions([]).
5343 validate_store_type_assumptions([C|Cs]) :-
5344 validate_store_type_assumption(C),
5345 validate_store_type_assumptions(Cs).
5347 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5348 % new code generation
5349 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
5350 Rule = rule(H1,_,Guard,Body),
5351 ( H1 == [],
5352 functor(CurrentHead,CF,CA),
5353 check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
5354 L = T
5355 ;
5356 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
5357 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
5358 flatten(VarsAndSuspsList,VarsAndSusps),
5359 Vars = [ [] | VarsAndSusps],
5360 build_head(F,A,Id,Vars,Head),
5361 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
5362 Clause = ( Head :- PredecessorCall),
5363 L = [Clause | T]
5364 ).
5366 % skips back intelligently over global_singleton lookups
5367 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
5368 ( Id = [0|_] ->
5369 next_id(Id,PrevId),
5370 PrevVarsAndSusps = BaseCallArgs
5371 ;
5372 VarsAndSuspsList = [_|AllButFirstList],
5373 dec_id(Id,PrevId1),
5374 ( PrevHeads = [PrevHead|PrevHeads1],
5375 functor(PrevHead,F,A),
5376 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
5377 PrevIterators = [_|PrevIterators1],
5378 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
5379 ;
5380 PrevId = PrevId1,
5381 flatten(AllButFirstList,AllButFirst),
5382 PrevIterators = [PrevIterator|_],
5383 PrevVarsAndSusps = [PrevIterator|AllButFirst]
5384 )
5385 ).
5387 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
5388 Rule = rule(_,_,Guard,Body),
5389 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
5390 init(AllSusps,PreSusps),
5391 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
5392 gen_var(OtherSusps),
5393 functor(CurrentHead,OtherF,OtherA),
5394 gen_vars(OtherA,OtherVars),
5395 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
5396 get_constraint_mode(OtherF/OtherA,Mode),
5397 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
5399 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
5401 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
5402 create_get_mutable_ref(active,State,GetMutable),
5403 CurrentSuspTest = (
5404 OtherSusp = OtherSuspension,
5405 GetMutable,
5406 DiffSuspGoals,
5407 FirstMatching
5408 ),
5409 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
5410 inc_id(Id,NestedId),
5411 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5412 build_head(F,A,Id,ClauseVars,ClauseHead),
5413 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
5414 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
5415 build_head(F,A,NestedId,NestedVars,NestedHead),
5417 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
5418 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
5419 RecursiveVars = PreVarsAndSusps1
5420 ;
5421 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5422 PrevId = Id
5423 ),
5424 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
5426 Clause = (
5427 ClauseHead :-
5428 ( CurrentSuspTest,
5429 NextSuspGoal
5430 ->
5431 NestedHead
5432 ; RecursiveHead
5433 )
5434 ),
5435 L = [Clause|T].
5437 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5440 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5441 % Observation Analysis
5442 %
5443 % CLASSIFICATION
5444 % Enabled
5445 %
5446 % Analysis based on Abstract Interpretation paper.
5447 %
5448 % TODO:
5449 % stronger analysis domain [research]
5451 :- chr_constraint
5452 initial_call_pattern/1,
5453 call_pattern/1,
5454 final_answer_pattern/2,
5455 abstract_constraints/1,
5456 depends_on/2,
5457 depends_on_ap/4,
5458 depends_on_goal/2,
5459 ai_observed/2,
5460 ai_not_observed/2,
5461 ai_is_observed/2,
5462 depends_on_as/3.
5464 :- chr_option(mode,initial_call_pattern(+)).
5465 :- chr_option(mode,call_pattern(+)).
5466 :- chr_option(mode,final_answer_pattern(+,+)).
5467 :- chr_option(mode,abstract_constraints(+)).
5468 :- chr_option(mode,depends_on(+,+)).
5469 :- chr_option(mode,depends_on_as(+,+,+)).
5470 :- chr_option(mode,depends_on_ap(+,+,+,+)).
5471 :- chr_option(mode,depends_on_goal(+,+)).
5472 :- chr_option(mode,ai_observed(+,+)).
5473 :- chr_option(mode,ai_is_observed(+,+)).
5474 :- chr_option(mode,ai_not_observed(+,+)).
5476 ai_observed(C,O) \ ai_not_observed(C,O) <=> true.
5477 ai_not_observed(C,O) \ ai_not_observed(C,O) <=> true.
5478 ai_observed(C,O) \ ai_observed(C,O) <=> true.
5480 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
5481 ai_is_observed(_,_) <=> true.
5483 ai_observation_analysis(ACs) :-
5484 ( chr_pp_flag(ai_observation_analysis,on),
5485 get_target_module(Module), Module \== chr_translate ->
5486 list_to_ord_set(ACs,ACSet),
5487 abstract_constraints(ACs),
5488 ai_observation_schedule_initial_calls(ACs)
5489 ;
5490 true
5491 ).
5493 ai_observation_schedule_initial_calls([]).
5494 ai_observation_schedule_initial_calls([AC|ACs]) :-
5495 ai_observation_schedule_initial_call(AC),
5496 ai_observation_schedule_initial_calls(ACs).
5498 ai_observation_schedule_initial_call(AC) :-
5499 ai_observation_top(AC,CallPattern),
5500 initial_call_pattern(CallPattern).
5502 ai_observation_schedule_new_calls([],AP).
5503 ai_observation_schedule_new_calls([AC|ACs],AP) :-
5504 AP = odom(_,Set),
5505 initial_call_pattern(odom(AC,Set)),
5506 ai_observation_schedule_new_calls(ACs,AP).
5508 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
5509 <=>
5510 ai_observation_leq(AP2,AP1)
5511 |
5512 true.
5514 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
5516 initial_call_pattern(CP) ==> call_pattern(CP).
5518 initial_call_pattern(CP), final_answer_pattern(CP,AP),
5519 abstract_constraints(ACs) ==>
5520 ai_observation_schedule_new_calls(ACs,AP).
5522 call_pattern(CP) \ call_pattern(CP) <=> true.
5524 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
5525 final_answer_pattern(CP1,AP).
5527 % AbstractGoala
5528 call_pattern(odom([],Set)) ==>
5529 final_answer_pattern(odom([],Set),odom([],Set)).
5531 % AbstractGoalb
5532 call_pattern(odom([G|Gs],Set)) ==>
5533 CP1 = odom(G,Set),
5534 depends_on_goal(odom([G|Gs],Set),CP1),
5535 call_pattern(CP1).
5537 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_)
5538 <=> true.
5539 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
5540 ==>
5541 CP1 = odom([_|Gs],_),
5542 AP2 = odom([],Set),
5543 CCP = odom(Gs,Set),
5544 call_pattern(CCP),
5545 depends_on(CP1,CCP).
5547 % AbstractSolve
5548 call_pattern(odom(builtin,Set)) ==>
5549 % writeln(' - AbstractSolve'),
5550 ord_empty(EmptySet),
5551 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
5553 % AbstractDrop
5554 call_pattern(odom(occ(C,O),Set)), max_occurrence(C,MO) ==>
5555 O > MO |
5556 % writeln(' - AbstractDrop'),
5557 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)).
5559 % AbstractActivate
5560 call_pattern(odom(AC,Set)), abstract_constraints(ACs)
5561 ==>
5562 memberchk_eq(AC,ACs)
5563 |
5564 % writeln(' - AbstractActivate'),
5565 CP = odom(occ(AC,1),Set),
5566 call_pattern(CP),
5567 depends_on(odom(AC,Set),CP).
5569 % AbstractSimplify (passive)
5570 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule)
5571 ==>
5572 Rule = pragma(rule(H1,H2,G,Body),ids(IDs1,_),_,_,_),
5573 memberchk_eq(ID,IDs1), is_passive(RuleNb,ID) |
5574 % writeln(' - AbstractSimplify(passive)'(C,O)),
5575 % DEFAULT
5576 NO is O + 1,
5577 DCP = odom(occ(C,NO),Set),
5578 call_pattern(DCP),
5579 % final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
5580 depends_on(odom(occ(C,O),Set),DCP).
5583 % AbstractSimplify
5584 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
5585 Rule = pragma(rule(H1,H2,G,Body),ids(IDs1,_),_,_,_),
5586 memberchk_eq(ID,IDs1), \+ is_passive(RuleNb,ID) |
5587 % writeln(' - AbstractSimplify'(C,O)),
5588 % SIMPLIFICATION
5589 select2(ID,_,IDs1,H1,_,RestH1),
5590 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
5591 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
5592 ai_observation_abstract_constraints(H2,ACs,AH2),
5593 ai_observation_observe_list(odom([],Set1),AH2,odom([],Set2)),
5594 ai_observation_abstract_goal_(H1,H2,G,Body,ACs,AG),
5595 call_pattern(odom(AG,Set2)),
5596 % DEFAULT
5597 NO is O + 1,
5598 DCP = odom(occ(C,NO),Set),
5599 call_pattern(DCP),
5600 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
5601 % DEADLOCK AVOIDANCE
5602 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)).
5604 depends_on_as(CP,CPS,CPD),
5605 final_answer_pattern(CPS,APS),
5606 final_answer_pattern(CPD,APD) ==>
5607 ai_observation_lub(APS,APD,AP),
5608 final_answer_pattern(CP,AP).
5610 % AbstractPropagate (passive)
5611 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
5612 Rule = pragma(rule(H1,H2,G,Body),ids(_,IDs2),_,_,_),
5613 memberchk_eq(ID,IDs2), is_passive(RuleNb,ID)
5614 |
5615 % writeln(' - AbstractPropagate (passive)'(C,O)),
5616 % DEFAULT
5617 NO is O + 1,
5618 DCP = odom(occ(C,NO),Set),
5619 call_pattern(DCP),
5620 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
5621 depends_on(odom(occ(C,O),Set),DCP).
5623 % AbstractPropagate
5624 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
5625 Rule = pragma(rule(H1,H2,G,Body),ids(_,IDs2),_,_,_),
5626 memberchk_eq(ID,IDs2), \+ is_passive(RuleNb,ID)
5627 |
5628 % writeln(' - AbstractPropagate'(C,O)),
5629 % observe partners
5630 select2(ID,_,IDs2,H2,_,RestH2),
5631 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
5632 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
5633 ai_observation_abstract_constraints(H1,ACs,AH1),
5634 ai_observation_observe_list(odom([],Set1),AH1,odom([],Set2)),
5635 ord_add_element(Set2,C,Set3),
5636 ai_observation_abstract_goal_(H1,H2,G,Body,ACs,AG),
5637 call_pattern(odom(AG,Set3)),
5638 ( ord_memberchk(C,Set2) ->
5639 Delete = no
5640 ;
5641 Delete = yes
5642 ),
5643 % DEFAULT
5644 NO is O + 1,
5645 DCP = odom(occ(C,NO),Set),
5646 call_pattern(DCP),
5647 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete).
5650 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
5651 true |
5652 final_answer_pattern(CP,APD).
5653 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
5654 final_answer_pattern(CPD,APD) ==>
5655 true |
5656 CP = odom(occ(C,O),_),
5657 ( ai_observation_is_observed(APP,C) ->
5658 ai_observed(C,O)
5659 ;
5660 ai_not_observed(C,O)
5661 ),
5662 ( Delete == yes ->
5663 APP = odom([],Set0),
5664 ord_del_element(Set0,C,Set),
5665 NAPP = odom([],Set)
5666 ;
5667 NAPP = APP
5668 ),
5669 ai_observation_lub(NAPP,APD,AP),
5670 final_answer_pattern(CP,AP).
5672 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
5673 ord_intersection(S1,S2,S3).
5675 ai_observation_top(AG,odom(AG,EmptyS)) :-
5676 ord_empty(EmptyS).
5678 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
5679 ord_subset(S2,S1).
5681 ai_observation_observe_list(odom(AG,S),ACs,odom(AG,NS)) :-
5682 list_to_ord_set(ACs,ACSet),
5683 ord_subtract(S,ACSet,NS).
5685 ai_observation_abstract_constraint(C,ACs,AC) :-
5686 functor(C,F,A),
5687 AC = F / A,
5688 member(AC,ACs).
5690 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
5691 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
5693 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
5694 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
5695 term_variables((H1,H2,Guard),HVars),
5696 append(H1,H2,Heads),
5697 % variables that are declared to be ground are safe,
5698 ground_vars(Heads,GroundVars),
5699 % so we remove them from the list of 'dangerous' head variables
5700 list_difference_eq(HVars,GroundVars,HV),
5701 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
5702 % HV are 'dangerous' variables, all others are fresh and safe
5704 ground_vars([],[]).
5705 ground_vars([H|Hs],GroundVars) :-
5706 functor(H,F,A),
5707 get_constraint_mode(F/A,Mode),
5708 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
5709 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
5710 ground_vars(Hs,GroundVars2),
5711 append(GroundVars1,GroundVars2,GroundVars).
5713 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
5714 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
5715 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
5716 ai_observation_abstract_goal((G1;G2),ACs,List,Tail,HV) :- !, % disjunction
5717 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
5718 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
5719 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
5720 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
5721 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
5722 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
5723 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
5724 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
5725 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
5726 % non-CHR constraint is safe if it only binds fresh variables
5727 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
5728 binds_b(G,Vars),
5729 intersect_eq(Vars,HV,[]),
5730 % writeln(safe(G)),
5731 !.
5732 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
5733 AG = builtin. % default case if goal is not recognized/safe
5735 ai_observation_is_observed(odom(_,ACSet),AC) :-
5736 \+ ord_memberchk(AC,ACSet).
5738 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5739 unconditional_occurrence(C,O) :-
5740 get_occurrence(C,O,RuleNb,ID),
5741 get_rule(RuleNb,PRule),
5742 PRule = pragma(ORule,_,_,_,_),
5743 copy_term_nat(ORule,Rule),
5744 Rule = rule(H1,H2,Guard,_),
5745 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
5746 once((
5747 H1 = [Head], H2 == []
5748 ;
5749 H2 = [Head], H1 == [], \+ may_trigger(C)
5750 )),
5751 functor(Head,F,A),
5752 Head =.. [_|Args],
5753 unconditional_occurrence_args(Args).
5755 unconditional_occurrence_args([]).
5756 unconditional_occurrence_args([X|Xs]) :-
5757 var(X),
5758 X = x,
5759 unconditional_occurrence_args(Xs).
5761 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5762 % Generate rules that implement chr_show_store/1 functionality.
5763 %
5764 % CLASSIFICATION
5765 % Experimental
5766 % Unused
5767 %
5768 % Generates additional rules:
5769 %
5770 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
5771 % ...
5772 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
5773 % $show <=> true.
5775 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
5776 ( chr_pp_flag(show,on) ->
5777 Constraints = ['$show'/0|Constraints0],
5778 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
5779 inc_rule_count(RuleNb),
5780 Rule = pragma(
5781 rule(['$show'],[],true,true),
5782 ids([0],[]),
5783 [],
5784 no,
5785 RuleNb
5786 )
5787 ;
5788 Constraints = Constraints0,
5789 Rules = Rules0
5790 ).
5792 generate_show_rules([],Rules,Rules).
5793 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
5794 functor(C,F,A),
5795 inc_rule_count(RuleNb),
5796 Rule = pragma(
5797 rule([],['$show',C],true,writeln(C)),
5798 ids([],[0,1]),
5799 [passive(1)],
5800 no,
5801 RuleNb
5802 ),
5803 generate_show_rules(Rest,Tail,Rules).