| blob | 9b32a1f94baf06f128686ae77cccb39ae408041c |
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)).
146 :- use_module(hprolog).
147 :- use_module(library(assoc)).
148 :- use_module(pairlist).
149 :- use_module(library(ordsets)).
150 :- use_module(a_star).
151 :- use_module(listmap).
152 :- use_module(clean_code).
153 :- use_module(builtins).
154 :- use_module(find).
155 :- use_module(guard_entailment).
156 :- use_module(chr_compiler_options).
157 :- use_module(chr_compiler_utility).
158 :- use_module(chr_compiler_errors).
159 :- include(chr_op).
160 :- op(1150, fx, chr_type).
161 :- op(1130, xfx, --->).
162 :- op(980, fx, (+)).
163 :- op(980, fx, (-)).
164 :- op(980, fx, (?)).
165 :- op(1150, fx, constraints).
166 :- op(1150, fx, chr_constraint).
168 :- chr_option(debug,off).
169 :- chr_option(optimize,full).
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 :- chr_constraint
174 target_module/1, % target_module(Module)
175 get_target_module/1,
177 indexed_argument/2, % argument instantiation may enable applicability of rule
178 is_indexed_argument/2,
180 constraint_mode/2,
181 get_constraint_mode/2,
183 may_trigger/1,
184 only_ground_indexed_arguments/1,
185 none_suspended_on_variables/0,
186 are_none_suspended_on_variables/0,
188 store_type/2,
189 get_store_type/2,
190 update_store_type/2,
191 actual_store_types/2,
192 assumed_store_type/2,
193 validate_store_type_assumption/1,
195 rule_count/1,
196 inc_rule_count/1,
198 passive/2,
199 is_passive/2,
200 any_passive_head/1,
202 new_occurrence/3,
203 occurrence/4,
204 get_occurrence/4,
206 max_occurrence/2,
207 get_max_occurrence/2,
209 allocation_occurrence/2,
210 get_allocation_occurrence/2,
211 rule/2,
212 get_rule/2,
213 least_occurrence/2,
214 is_least_occurrence/1
215 .
217 :- chr_option(check_guard_bindings,off).
219 :- chr_option(mode,target_module(+)).
220 :- chr_option(mode,indexed_argument(+,+)).
221 :- chr_option(mode,constraint_mode(+,+)).
222 :- chr_option(mode,may_trigger(+)).
223 :- chr_option(mode,store_type(+,+)).
224 :- chr_option(mode,actual_store_types(+,+)).
225 :- chr_option(mode,assumed_store_type(+,+)).
226 :- chr_option(mode,rule_count(+)).
227 :- chr_option(mode,passive(+,+)).
228 :- chr_option(mode,occurrence(+,+,+,+)).
229 :- chr_option(mode,max_occurrence(+,+)).
230 :- chr_option(mode,allocation_occurrence(+,+)).
231 :- chr_option(mode,rule(+,+)).
232 :- chr_option(mode,least_occurrence(+,+)).
233 :- chr_option(mode,is_least_occurrence(+)).
235 :- chr_option(type_definition,type(list,[ [], [any|list] ])).
236 :- chr_option(type_definition,type(constraint,[ any / any ])).
238 :- chr_option(type_declaration,constraint_mode(constraint,list)).
240 target_module(_) \ target_module(_) <=> true.
241 target_module(Mod) \ get_target_module(Query)
242 <=> Query = Mod .
243 get_target_module(Query)
244 <=> Query = user.
246 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
247 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
248 is_indexed_argument(_,_) <=> fail.
250 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
252 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
253 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
254 Q = Mode.
255 get_constraint_mode(FA,Q) <=>
256 FA = _ / N,
257 replicate(N,(?),Q).
259 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
261 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
262 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
263 nth(I,Mode,M),
264 M \== (+) |
265 is_stored(FA).
266 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
268 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
269 <=>
270 nth(I,Mode,M),
271 M \== (+)
272 |
273 fail.
274 only_ground_indexed_arguments(_) <=>
275 true.
277 none_suspended_on_variables \ none_suspended_on_variables <=> true.
278 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
279 are_none_suspended_on_variables <=> fail.
280 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
282 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
283 store_type(FA,Store) \ get_store_type(FA,Query)
284 <=> Query = Store.
285 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
286 <=> Query = Store.
287 get_store_type(_,Query)
288 <=> Query = default.
290 actual_store_types(C,STs) \ update_store_type(C,ST)
291 <=> member(ST,STs) | true.
292 update_store_type(C,ST), actual_store_types(C,STs)
293 <=>
294 actual_store_types(C,[ST|STs]).
295 update_store_type(C,ST)
296 <=>
297 actual_store_types(C,[ST]).
299 % refine store type assumption
300 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
301 <=>
302 store_type(C,multi_store(STs)).
303 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
304 <=>
305 store_type(C,multi_store(STs)).
306 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
307 <=> store_type(C,global_ground).
308 validate_store_type_assumption(C)
309 <=> true.
311 rule_count(C), inc_rule_count(NC)
312 <=> NC is C + 1, rule_count(NC).
313 inc_rule_count(NC)
314 <=> NC = 1, rule_count(NC).
316 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
317 passive(R,ID) \ passive(R,ID) <=> true.
319 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
320 is_passive(_,_) <=> fail.
322 passive(RuleNb,_) \ any_passive_head(RuleNb)
323 <=> true.
324 any_passive_head(_)
325 <=> fail.
326 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
328 max_occurrence(C,N) \ max_occurrence(C,M)
329 <=> N >= M | true.
331 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID) <=>
332 NO is MO + 1,
333 occurrence(C,NO,RuleNb,ID),
334 max_occurrence(C,NO).
335 new_occurrence(C,RuleNb,ID) <=>
336 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
338 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
339 <=> Q = MON.
340 get_max_occurrence(C,Q)
341 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
343 occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
344 <=> Rule = QRule, ID = QID.
345 get_occurrence(C,O,_,_)
346 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[]).
348 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
350 % cannot store constraint at passive occurrence
351 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
352 <=> NO is O + 1, allocation_occurrence(C,NO).
353 % need not store constraint that is removed
354 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
355 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
356 | NO is O + 1, allocation_occurrence(C,NO).
357 % need not store constraint when body is true
358 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
359 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
360 | NO is O + 1, allocation_occurrence(C,NO).
361 % need not store constraint if does not observe itself
362 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
363 <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
364 | NO is O + 1, allocation_occurrence(C,NO).
365 % need not store constraint if does not observe itself and cannot trigger
366 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_), least_occurrence(RuleNb,[])
367 \ allocation_occurrence(C,O)
368 <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
369 | NO is O + 1, allocation_occurrence(C,NO).
371 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID), allocation_occurrence(C,AO)
372 \ least_occurrence(RuleNb,[ID|IDs])
373 <=> AO >= O, \+ may_trigger(C) |
374 least_occurrence(RuleNb,IDs).
375 rule(RuleNb,Rule), passive(RuleNb,ID)
376 \ least_occurrence(RuleNb,[ID|IDs])
377 <=> least_occurrence(RuleNb,IDs).
379 rule(RuleNb,Rule)
380 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
381 least_occurrence(RuleNb,IDs).
383 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
384 <=> true.
385 is_least_occurrence(_)
386 <=> fail.
388 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
389 <=> Q = O.
390 get_allocation_occurrence(_,Q)
391 <=> chr_pp_flag(late_allocation,off), Q=0.
392 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
394 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
395 <=> Q = Rule.
396 get_rule(_,_)
397 <=> fail.
399 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
402 :- chr_constraint
403 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
404 get_constraint_index/2,
405 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
406 get_max_constraint_index/1.
408 :- chr_option(mode,constraint_index(+,+)).
409 :- chr_option(mode,max_constraint_index(+)).
411 constraint_index(C,Index) \ get_constraint_index(C,Query)
412 <=> Query = Index.
413 get_constraint_index(C,Query)
414 <=> fail.
416 max_constraint_index(Index) \ get_max_constraint_index(Query)
417 <=> Query = Index.
418 get_max_constraint_index(Query)
419 <=> Query = 0.
421 set_constraint_indices(Constraints) :-
422 set_constraint_indices(Constraints,1).
423 set_constraint_indices([],M) :-
424 N is M - 1,
425 max_constraint_index(N).
426 set_constraint_indices([C|Cs],N) :-
427 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C) ; is_stored(C), get_store_type(C,default)) ->
428 constraint_index(C,N),
429 M is N + 1,
430 set_constraint_indices(Cs,M)
431 ;
432 set_constraint_indices(Cs,N)
433 ).
435 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
440 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
441 %%
442 %% Translation
444 chr_translate(Declarations,NewDeclarations) :-
445 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',[]),
446 init_chr_pp_flags,
447 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
448 check_declared_constraints(Constraints0),
449 generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
450 add_constraints(Constraints),
451 add_rules(Rules),
452 % start analysis
453 check_rules(Rules,Constraints),
454 add_occurrences(Rules),
455 functional_dependency_analysis(Rules),
456 set_semantics_rules(Rules),
457 symmetry_analysis(Rules),
458 guard_simplification,
459 storage_analysis(Constraints),
460 observation_analysis(Constraints),
461 ai_observation_analysis(Constraints),
462 late_allocation_analysis(Constraints),
463 assume_constraint_stores(Constraints),
464 set_constraint_indices(Constraints),
465 % end analysis
466 constraints_code(Constraints,ConstraintClauses),
467 validate_store_type_assumptions(Constraints),
468 store_management_preds(Constraints,StoreClauses), % depends on actual code used
469 insert_declarations(OtherClauses, Clauses0),
470 chr_module_declaration(CHRModuleDeclaration),
471 append_lists([Clauses0,
472 StoreClauses,
473 ConstraintClauses,
474 CHRModuleDeclaration,
475 [end_of_file]
476 ],
477 NewDeclarations).
479 store_management_preds(Constraints,Clauses) :-
480 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
481 generate_indexed_variables_clauses(Constraints,IndexedClauses),
482 generate_attach_increment(AttachIncrementClauses),
483 generate_attr_unify_hook(AttrUnifyHookClauses),
484 generate_extra_clauses(Constraints,ExtraClauses),
485 generate_insert_delete_constraints(Constraints,DeleteClauses),
486 generate_attach_code(Constraints,StoreClauses),
487 generate_counter_code(CounterClauses),
488 append_lists([AttachAConstraintClauses
489 ,IndexedClauses
490 ,AttachIncrementClauses
491 ,AttrUnifyHookClauses
492 ,ExtraClauses
493 ,DeleteClauses
494 ,StoreClauses
495 ,CounterClauses
496 ]
497 ,Clauses).
499 %% SWI begin
500 extra_declaration([ :- use_module(chr(chr_runtime))
501 , :- use_module(chr(chr_hashtable_store))
502 , :- use_module(library('clp/clp_events'))
503 ]).
504 %% SWI end
506 %% SICStus begin
507 %% extra_declaration([ (:- use_module(library('chr/chr_runtime')))
508 %% , (:- use_module(library('chr/chr_hashtable_store')))
509 %% , (:- use_module(library('chr/hprolog')))
510 %% ]).
511 %% SICStus end
515 insert_declarations(Clauses0, Clauses) :-
516 extra_declaration(Decls),
517 append(Clauses0, Decls, Clauses).
519 generate_counter_code(Clauses) :-
520 ( chr_pp_flag(store_counter,on) ->
521 Clauses = [
522 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
523 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
524 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
525 (:- '$counter_init'('$insert_counter')),
526 (:- '$counter_init'('$delete_counter')),
527 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
528 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
529 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
530 ]
531 ;
532 Clauses = []
533 ).
535 % for systems with multifile declaration
536 chr_module_declaration(CHRModuleDeclaration) :-
537 get_target_module(Mod),
538 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
539 CHRModuleDeclaration = [
540 (:- multifile chr:'$chr_module'/1),
541 chr:'$chr_module'(Mod)
542 ]
543 ;
544 CHRModuleDeclaration = []
545 ).
548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
549 %%
550 %% Partitioning of clauses into constraint declarations, chr rules and other
551 %% clauses
553 partition_clauses([],[],[],[]).
554 partition_clauses([C|Cs],Ds,Rs,OCs) :-
555 ( parse_rule(C,R) ->
556 Ds = RDs,
557 Rs = [R | RRs],
558 OCs = ROCs
559 ; is_declaration(C,D) ->
560 append(D,RDs,Ds),
561 Rs = RRs,
562 OCs = ROCs
563 ; is_module_declaration(C,Mod) ->
564 target_module(Mod),
565 Ds = RDs,
566 Rs = RRs,
567 OCs = [C|ROCs]
568 ; is_type_definition(C) ->
569 Ds = RDs,
570 Rs = RRs,
571 OCs = ROCs
572 ; C = (handler _) ->
573 chr_warning(deprecated(C),'SICStus compatibility: ignoring handler/1 declaration.\n',[]),
574 Ds = RDs,
575 Rs = RRs,
576 OCs = ROCs
577 ; C = (rules _) ->
578 chr_warning(deprecated(C),'SICStus compatibility: ignoring rules/1 declaration.\n',[]),
579 Ds = RDs,
580 Rs = RRs,
581 OCs = ROCs
582 ; C = option(OptionName,OptionValue) ->
583 chr_warning(deprecated(C),'Instead use :- chr_option(~w,~w).\n',[OptionName,OptionValue]),
584 handle_option(OptionName,OptionValue),
585 Ds = RDs,
586 Rs = RRs,
587 OCs = ROCs
588 ; C = (:- chr_option(OptionName,OptionValue)) ->
589 handle_option(OptionName,OptionValue),
590 Ds = RDs,
591 Rs = RRs,
592 OCs = ROCs
593 ; Ds = RDs,
594 Rs = RRs,
595 OCs = [C|ROCs]
596 ),
597 partition_clauses(Cs,RDs,RRs,ROCs).
599 is_declaration(D, Constraints) :- %% constraint declaration
600 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
601 conj2list(Cs,Constraints0)
602 ;
603 ( D = (:- Decl) ->
604 Decl =.. [constraints,Cs]
605 ;
606 D =.. [constraints,Cs]
607 ),
608 conj2list(Cs,Constraints0),
609 ( length(Constraints0,1) ->
610 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
611 ;
612 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
613 )
614 ),
615 extract_type_mode(Constraints0,Constraints).
617 extract_type_mode([],[]).
618 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
619 extract_type_mode([C|R],[C2|R2]) :-
620 functor(C,F,A),C2=F/A,
621 C =.. [_|Args],
622 extract_types_and_modes(Args,ArgTypes,ArgModes),
623 constraint_type(F/A,ArgTypes),
624 constraint_mode(F/A,ArgModes),
625 extract_type_mode(R,R2).
627 extract_types_and_modes([],[],[]).
628 extract_types_and_modes([+(T)|R],[T|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
629 extract_types_and_modes([?(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
630 extract_types_and_modes([-(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
631 extract_types_and_modes([(+)|R],[any|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
632 extract_types_and_modes([(?)|R],[any|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([Illegal|R],_,_) :-
635 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
637 is_type_definition(D) :-
638 ( D = (:- TDef) ->
639 true
640 ;
641 D = TDef
642 ),
643 TDef =.. [chr_type,TypeDef],
644 ( TypeDef = (Name ---> Def) ->
645 tdisj2list(Def,DefList),
646 type_definition(Name,DefList)
647 ;
648 chr_warning(syntax,'Illegal type definition "~w".\n\tIgnoring this malformed type definition.\n',[TypeDef])
649 ).
651 % no removal of fails, e.g. :- type bool ---> true ; fail.
652 tdisj2list(Conj,L) :-
653 tdisj2list(Conj,L,[]).
654 tdisj2list(Conj,L,T) :-
655 Conj = (G1;G2), !,
656 tdisj2list(G1,L,T1),
657 tdisj2list(G2,T1,T).
658 tdisj2list(G,[G | T],T).
661 %% Data Declaration
662 %%
663 %% pragma_rule
664 %% -> pragma(
665 %% rule,
666 %% ids,
667 %% list(pragma),
668 %% yesno(string), :: maybe rule nane
669 %% int :: rule number
670 %% )
671 %%
672 %% ids -> ids(
673 %% list(int),
674 %% list(int)
675 %% )
676 %%
677 %% rule -> rule(
678 %% list(constraint), :: constraints to be removed
679 %% list(constraint), :: surviving constraints
680 %% goal, :: guard
681 %% goal :: body
682 %% )
684 parse_rule(RI,R) :- %% name @ rule
685 RI = (Name @ RI2), !,
686 rule(RI2,yes(Name),R).
687 parse_rule(RI,R) :-
688 rule(RI,no,R).
690 rule(RI,Name,R) :-
691 RI = (RI2 pragma P), !, %% pragmas
692 is_rule(RI2,R1,IDs),
693 ( var(P) ->
694 Ps = [_] % intercept variable
695 ;
696 conj2list(P,Ps)
697 ),
698 inc_rule_count(RuleCount),
699 R = pragma(R1,IDs,Ps,Name,RuleCount).
700 rule(RI,Name,R) :-
701 is_rule(RI,R1,IDs),
702 inc_rule_count(RuleCount),
703 R = pragma(R1,IDs,[],Name,RuleCount).
705 is_rule(RI,R,IDs) :- %% propagation rule
706 RI = (H ==> B), !,
707 conj2list(H,Head2i),
708 get_ids(Head2i,IDs2,Head2),
709 IDs = ids([],IDs2),
710 ( B = (G | RB) ->
711 R = rule([],Head2,G,RB)
712 ;
713 R = rule([],Head2,true,B)
714 ).
715 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
716 RI = (H <=> B), !,
717 ( B = (G | RB) ->
718 Guard = G,
719 Body = RB
720 ; Guard = true,
721 Body = B
722 ),
723 ( H = (H1 \ H2) ->
724 conj2list(H1,Head2i),
725 conj2list(H2,Head1i),
726 get_ids(Head2i,IDs2,Head2,0,N),
727 get_ids(Head1i,IDs1,Head1,N,_),
728 IDs = ids(IDs1,IDs2)
729 ; conj2list(H,Head1i),
730 Head2 = [],
731 get_ids(Head1i,IDs1,Head1),
732 IDs = ids(IDs1,[])
733 ),
734 R = rule(Head1,Head2,Guard,Body).
736 get_ids(Cs,IDs,NCs) :-
737 get_ids(Cs,IDs,NCs,0,_).
739 get_ids([],[],[],N,N).
740 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
741 ( C = (NC # N) ->
742 true
743 ;
744 NC = C
745 ),
746 M is N + 1,
747 get_ids(Cs,IDs,NCs, M,NN).
749 is_module_declaration((:- module(Mod)),Mod).
750 is_module_declaration((:- module(Mod,_)),Mod).
752 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
754 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
755 % Add constraints
756 add_constraints([]).
757 add_constraints([C|Cs]) :-
758 max_occurrence(C,0),
759 C = _/A,
760 length(Mode,A),
761 set_elems(Mode,?),
762 constraint_mode(C,Mode),
763 add_constraints(Cs).
765 % Add rules
766 add_rules([]).
767 add_rules([Rule|Rules]) :-
768 Rule = pragma(_,_,_,_,RuleNb),
769 rule(RuleNb,Rule),
770 add_rules(Rules).
772 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
774 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
775 %% Some input verification:
777 check_declared_constraints(Constraints) :-
778 check_declared_constraints(Constraints,[]).
780 check_declared_constraints([],_).
781 check_declared_constraints([C|Cs],Acc) :-
782 ( memberchk_eq(C,Acc) ->
783 chr_error(syntax(C),'Constraint ~w multiply defined.\n\tRemove redundant declaration!\n',[C])
784 ;
785 true
786 ),
787 check_declared_constraints(Cs,[C|Acc]).
789 %% - all constraints in heads are declared constraints
790 %% - all passive pragmas refer to actual head constraints
792 check_rules([],_).
793 check_rules([PragmaRule|Rest],Decls) :-
794 check_rule(PragmaRule,Decls),
795 check_rules(Rest,Decls).
797 check_rule(PragmaRule,Decls) :-
798 check_rule_indexing(PragmaRule),
799 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
800 Rule = rule(H1,H2,_,_),
801 append(H1,H2,HeadConstraints),
802 check_head_constraints(HeadConstraints,Decls,PragmaRule),
803 check_pragmas(Pragmas,PragmaRule).
805 check_head_constraints([],_,_).
806 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
807 functor(Constr,F,A),
808 ( member(F/A,Decls) ->
809 check_head_constraints(Rest,Decls,PragmaRule)
810 ;
811 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ).
813 check_pragmas([],_).
814 check_pragmas([Pragma|Pragmas],PragmaRule) :-
815 check_pragma(Pragma,PragmaRule),
816 check_pragmas(Pragmas,PragmaRule).
818 check_pragma(Pragma,PragmaRule) :-
819 var(Pragma), !,
820 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
821 check_pragma(passive(ID), PragmaRule) :-
822 !,
823 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
824 ( memberchk_eq(ID,IDs1) ->
825 true
826 ; memberchk_eq(ID,IDs2) ->
827 true
828 ;
829 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
830 ),
831 passive(RuleNb,ID).
833 check_pragma(Pragma, PragmaRule) :-
834 Pragma = already_in_heads,
835 !,
836 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
838 check_pragma(Pragma, PragmaRule) :-
839 Pragma = already_in_head(_),
840 !,
841 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
843 check_pragma(Pragma,PragmaRule) :-
844 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
846 format_rule(PragmaRule) :-
847 PragmaRule = pragma(_,_,_,MaybeName,N),
848 ( MaybeName = yes(Name) ->
849 write('rule '), write(Name)
850 ;
851 write('rule number '), write(N)
852 ).
854 check_rule_indexing(PragmaRule) :-
855 PragmaRule = pragma(Rule,_,_,_,_),
856 Rule = rule(H1,H2,G,_),
857 term_variables(H1-H2,HeadVars),
858 remove_anti_monotonic_guards(G,HeadVars,NG),
859 check_indexing(H1,NG-H2),
860 check_indexing(H2,NG-H1).
862 remove_anti_monotonic_guards(G,Vars,NG) :-
863 conj2list(G,GL),
864 remove_anti_monotonic_guard_list(GL,Vars,NGL),
865 list2conj(NGL,NG).
867 remove_anti_monotonic_guard_list([],_,[]).
868 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
869 ( G = var(X),
870 memberchk_eq(X,Vars) ->
871 NGs = RGs
872 ;
873 NGs = [G|RGs]
874 ),
875 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
877 check_indexing([],_).
878 check_indexing([Head|Heads],Other) :-
879 functor(Head,F,A),
880 Head =.. [_|Args],
881 term_variables(Heads-Other,OtherVars),
882 check_indexing(Args,1,F/A,OtherVars),
883 check_indexing(Heads,[Head|Other]).
885 check_indexing([],_,_,_).
886 check_indexing([Arg|Args],I,FA,OtherVars) :-
887 ( is_indexed_argument(FA,I) ->
888 true
889 ; nonvar(Arg) ->
890 indexed_argument(FA,I)
891 ; % var(Arg) ->
892 term_variables(Args,ArgsVars),
893 append(ArgsVars,OtherVars,RestVars),
894 ( memberchk_eq(Arg,RestVars) ->
895 indexed_argument(FA,I)
896 ;
897 true
898 )
899 ),
900 J is I + 1,
901 term_variables(Arg,NVars),
902 append(NVars,OtherVars,NOtherVars),
903 check_indexing(Args,J,FA,NOtherVars).
905 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
907 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
908 % Occurrences
910 add_occurrences([]).
911 add_occurrences([Rule|Rules]) :-
912 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
913 add_occurrences(H1,IDs1,Nb),
914 add_occurrences(H2,IDs2,Nb),
915 add_occurrences(Rules).
917 add_occurrences([],[],_).
918 add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
919 functor(H,F,A),
920 FA = F/A,
921 new_occurrence(FA,RuleNb,ID),
922 add_occurrences(Hs,IDs,RuleNb).
924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
926 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
927 % Observation Analysis
928 %
929 % CLASSIFICATION
930 % Legacy
931 %
932 % - approximative: should make decision in late allocation analysis per body
933 % TODO:
934 % remove
936 is_observed(C,O) :-
937 is_self_observer(C),
938 ai_is_observed(C,O).
940 :- chr_constraint
941 observes/2,
942 spawns_observer/2,
943 observes_indirectly/2,
944 is_self_observer/1
945 .
947 :- chr_option(mode,observes(+,+)).
948 :- chr_option(mode,spawns_observer(+,+)).
949 :- chr_option(mode,observes_indirectly(+,+)).
951 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
952 observes(C1,C2) \ observes(C1,C2) <=> true.
954 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
956 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
957 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
959 observes_indirectly(C,C) \ is_self_observer(C) <=> true.
960 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off).
961 % true if analysis has not been run,
962 % false if analysis has been run
964 observation_analysis(Cs) :-
965 ( chr_pp_flag(observation_analysis,on) ->
966 observation_analysis(Cs,Cs)
967 ;
968 true
969 ).
971 observation_analysis([],_).
972 observation_analysis([C|Cs],Constraints) :-
973 get_max_occurrence(C,MO),
974 observation_analysis_occurrences(C,1,MO,Constraints),
975 observation_analysis(Cs,Constraints).
977 observation_analysis_occurrences(C,O,MO,Cs) :-
978 ( O > MO ->
979 true
980 ;
981 observation_analysis_occurrence(C,O,Cs),
982 NO is O + 1,
983 observation_analysis_occurrences(C,NO,MO,Cs)
984 ).
986 observation_analysis_occurrence(C,O,Cs) :-
987 get_occurrence(C,O,RuleNb,ID),
988 ( is_passive(RuleNb,ID) ->
989 true
990 ;
991 get_rule(RuleNb,PragmaRule),
992 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),
993 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
994 append(RHeads1,Heads2,OtherHeads)
995 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
996 append(RHeads2,Heads1,OtherHeads)
997 ),
998 observe_heads(C,OtherHeads),
999 observe_body(C,Body,Cs)
1000 ).
1002 observe_heads(C,Heads) :-
1003 findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
1004 observe_all(C,Cs).
1006 observe_all(C,Cs) :-
1007 ( Cs = [C1|Cr] ->
1008 observes(C,C1),
1009 observe_all(C,Cr)
1010 ;
1011 true
1012 ).
1014 spawn_all(C,Cs) :-
1015 ( Cs = [C1|Cr] ->
1016 spawns_observer(C,C1),
1017 spawn_all(C,Cr)
1018 ;
1019 true
1020 ).
1021 spawn_all_triggers(C,Cs) :-
1022 ( Cs = [C1|Cr] ->
1023 ( may_trigger(C1) ->
1024 spawns_observer(C,C1)
1025 ;
1026 true
1027 ),
1028 spawn_all_triggers(C,Cr)
1029 ;
1030 true
1031 ).
1033 observe_body(C,Body,Cs) :-
1034 ( var(Body) ->
1035 spawn_all(C,Cs)
1036 ; Body = true ->
1037 true
1038 ; Body = fail ->
1039 true
1040 ; Body = (B1,B2) ->
1041 observe_body(C,B1,Cs),
1042 observe_body(C,B2,Cs)
1043 ; Body = (B1;B2) ->
1044 observe_body(C,B1,Cs),
1045 observe_body(C,B2,Cs)
1046 ; Body = (B1->B2) ->
1047 observe_body(C,B1,Cs),
1048 observe_body(C,B2,Cs)
1049 ; functor(Body,F,A), member(F/A,Cs) ->
1050 spawns_observer(C,F/A)
1051 ; Body = (_ = _) ->
1052 spawn_all_triggers(C,Cs)
1053 ; Body = (_ is _) ->
1054 spawn_all_triggers(C,Cs)
1055 ; binds_b(Body,Vars) ->
1056 ( Vars == [] ->
1057 true
1058 ;
1059 spawn_all_triggers(C,Cs)
1060 )
1061 ;
1062 spawn_all(C,Cs)
1063 ).
1065 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1067 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1068 % Late allocation
1070 late_allocation_analysis(Cs) :-
1071 ( chr_pp_flag(late_allocation,on) ->
1072 late_allocation(Cs)
1073 ;
1074 true
1075 ).
1077 late_allocation([]).
1078 late_allocation([C|Cs]) :-
1079 allocation_occurrence(C,1),
1080 late_allocation(Cs).
1081 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1083 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1084 %%
1085 %% Generated predicates
1086 %% attach_$CONSTRAINT
1087 %% attach_increment
1088 %% detach_$CONSTRAINT
1089 %% attr_unify_hook
1091 %% attach_$CONSTRAINT
1092 generate_attach_detach_a_constraint_all([],[]).
1093 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1094 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint)) ->
1095 generate_attach_a_constraint(Constraint,Clauses1),
1096 generate_detach_a_constraint(Constraint,Clauses2)
1097 ;
1098 Clauses1 = [],
1099 Clauses2 = []
1100 ),
1101 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1102 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
1104 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1105 generate_attach_a_constraint_empty_list(Constraint,Clause1),
1106 get_max_constraint_index(N),
1107 ( N == 1 ->
1108 generate_attach_a_constraint_1_1(Constraint,Clause2)
1109 ;
1110 generate_attach_a_constraint_t_p(Constraint,Clause2)
1111 ).
1113 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
1114 make_name('attach_',FA,Fct),
1115 Head =.. [Fct | Args],
1116 Clause = ( Head :- Body).
1118 generate_attach_a_constraint_empty_list(FA,Clause) :-
1119 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
1121 generate_attach_a_constraint_1_1(FA,Clause) :-
1122 Args = [[Var|Vars],Susp],
1123 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1124 generate_attach_body_1(FA,Var,Susp,AttachBody),
1125 make_name('attach_',FA,Fct),
1126 RecursiveCall =.. [Fct,Vars,Susp],
1127 % SWI-Prolog specific code
1128 chr_pp_flag(solver_events,NMod),
1129 ( NMod \== none ->
1130 Args = [[Var|_],Susp],
1131 get_target_module(Mod),
1132 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1133 ;
1134 Subscribe = true
1135 ),
1136 Body =
1137 (
1138 AttachBody,
1139 Subscribe,
1140 RecursiveCall
1141 ).
1143 generate_attach_body_1(FA,Var,Susp,Body) :-
1144 get_target_module(Mod),
1145 Body =
1146 ( get_attr(Var, Mod, Susps) ->
1147 NewSusps=[Susp|Susps],
1148 put_attr(Var, Mod, NewSusps)
1149 ;
1150 put_attr(Var, Mod, [Susp])
1151 ).
1153 generate_attach_a_constraint_t_p(FA,Clause) :-
1154 Args = [[Var|Vars],Susp],
1155 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1156 make_name('attach_',FA,Fct),
1157 RecursiveCall =.. [Fct,Vars,Susp],
1158 generate_attach_body_n(FA,Var,Susp,AttachBody),
1159 % SWI-Prolog specific code
1160 chr_pp_flag(solver_events,NMod),
1161 ( NMod \== none ->
1162 Args = [[Var|_],Susp],
1163 get_target_module(Mod),
1164 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1165 ;
1166 Subscribe = true
1167 ),
1168 Body =
1169 (
1170 AttachBody,
1171 Subscribe,
1172 RecursiveCall
1173 ).
1175 generate_attach_body_n(F/A,Var,Susp,Body) :-
1176 get_constraint_index(F/A,Position),
1177 or_pattern(Position,Pattern),
1178 get_max_constraint_index(Total),
1179 make_attr(Total,Mask,SuspsList,Attr),
1180 nth(Position,SuspsList,Susps),
1181 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1182 make_attr(Total,Mask,SuspsList1,NewAttr1),
1183 substitute(Susps,SuspsList,[Susp],SuspsList2),
1184 make_attr(Total,NewMask,SuspsList2,NewAttr2),
1185 copy_term(SuspsList,SuspsList3),
1186 nth(Position,SuspsList3,[Susp]),
1187 chr_delete(SuspsList3,[Susp],RestSuspsList),
1188 set_elems(RestSuspsList,[]),
1189 make_attr(Total,Pattern,SuspsList3,NewAttr3),
1190 get_target_module(Mod),
1191 Body =
1192 ( get_attr(Var,Mod,TAttr) ->
1193 TAttr = Attr,
1194 ( Mask /\ Pattern =:= Pattern ->
1195 put_attr(Var, Mod, NewAttr1)
1196 ;
1197 NewMask is Mask \/ Pattern,
1198 put_attr(Var, Mod, NewAttr2)
1199 )
1200 ;
1201 put_attr(Var,Mod,NewAttr3)
1202 ).
1204 %% detach_$CONSTRAINT
1205 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1206 generate_detach_a_constraint_empty_list(Constraint,Clause1),
1207 get_max_constraint_index(N),
1208 ( N == 1 ->
1209 generate_detach_a_constraint_1_1(Constraint,Clause2)
1210 ;
1211 generate_detach_a_constraint_t_p(Constraint,Clause2)
1212 ).
1214 generate_detach_a_constraint_empty_list(FA,Clause) :-
1215 make_name('detach_',FA,Fct),
1216 Args = [[],_],
1217 Head =.. [Fct | Args],
1218 Clause = ( Head :- true).
1220 generate_detach_a_constraint_1_1(FA,Clause) :-
1221 make_name('detach_',FA,Fct),
1222 Args = [[Var|Vars],Susp],
1223 Head =.. [Fct | Args],
1224 RecursiveCall =.. [Fct,Vars,Susp],
1225 generate_detach_body_1(FA,Var,Susp,DetachBody),
1226 Body =
1227 (
1228 DetachBody,
1229 RecursiveCall
1230 ),
1231 Clause = (Head :- Body).
1233 generate_detach_body_1(FA,Var,Susp,Body) :-
1234 get_target_module(Mod),
1235 Body =
1236 ( get_attr(Var,Mod,Susps) ->
1237 'chr sbag_del_element'(Susps,Susp,NewSusps),
1238 ( NewSusps == [] ->
1239 del_attr(Var,Mod)
1240 ;
1241 put_attr(Var,Mod,NewSusps)
1242 )
1243 ;
1244 true
1245 ).
1247 generate_detach_a_constraint_t_p(FA,Clause) :-
1248 make_name('detach_',FA,Fct),
1249 Args = [[Var|Vars],Susp],
1250 Head =.. [Fct | Args],
1251 RecursiveCall =.. [Fct,Vars,Susp],
1252 generate_detach_body_n(FA,Var,Susp,DetachBody),
1253 Body =
1254 (
1255 DetachBody,
1256 RecursiveCall
1257 ),
1258 Clause = (Head :- Body).
1260 generate_detach_body_n(F/A,Var,Susp,Body) :-
1261 get_constraint_index(F/A,Position),
1262 or_pattern(Position,Pattern),
1263 and_pattern(Position,DelPattern),
1264 get_max_constraint_index(Total),
1265 make_attr(Total,Mask,SuspsList,Attr),
1266 nth(Position,SuspsList,Susps),
1267 substitute(Susps,SuspsList,[],SuspsList1),
1268 make_attr(Total,NewMask,SuspsList1,Attr1),
1269 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1270 make_attr(Total,Mask,SuspsList2,Attr2),
1271 get_target_module(Mod),
1272 Body =
1273 ( get_attr(Var,Mod,TAttr) ->
1274 TAttr = Attr,
1275 ( Mask /\ Pattern =:= Pattern ->
1276 'chr sbag_del_element'(Susps,Susp,NewSusps),
1277 ( NewSusps == [] ->
1278 NewMask is Mask /\ DelPattern,
1279 ( NewMask == 0 ->
1280 del_attr(Var,Mod)
1281 ;
1282 put_attr(Var,Mod,Attr1)
1283 )
1284 ;
1285 put_attr(Var,Mod,Attr2)
1286 )
1287 ;
1288 true
1289 )
1290 ;
1291 true
1292 ).
1294 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1295 generate_indexed_variables_clauses(Constraints,Clauses) :-
1296 ( are_none_suspended_on_variables ->
1297 Clauses = []
1298 ;
1299 generate_indexed_variables_clauses_(Constraints,Clauses)
1300 ).
1302 generate_indexed_variables_clauses_([],[]).
1303 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1304 ( is_stored(C) ->
1305 Clauses = [Clause|RestClauses],
1306 generate_indexed_variables_clause(C,Clause)
1307 ;
1308 Clauses = RestClauses
1309 ),
1310 generate_indexed_variables_clauses_(Cs,RestClauses).
1312 %===============================================================================
1313 :- chr_constraint generate_indexed_variables_clause/2.
1314 :- chr_option(mode,generate_indexed_variables_clause(+,+)).
1315 %-------------------------------------------------------------------------------
1316 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_clause(F/A,Clause) <=>
1317 functor(Term,F,A),
1318 Term =.. [_|Args],
1319 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1320 ( MaybeBody == empty ->
1322 Body = (Vars = [])
1323 ; N == 0 ->
1324 Body = term_variables(Susp,Vars)
1325 ;
1326 MaybeBody = Body
1327 ),
1328 Clause =
1329 ( '$indexed_variables'(Susp,Vars) :-
1330 Susp = Term,
1331 Body
1332 ).
1333 generate_indexed_variables_clause(FA,_) <=>
1334 chr_error(internal,'generate_indexed_variables_clause: missing mode info for ~w.\n',[FA]).
1335 %===============================================================================
1337 create_indexed_variables_body([],[],_,_,_,empty,0).
1338 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1339 J is I + 1,
1340 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1341 ( Mode \== (+),
1342 is_indexed_argument(FA,I) ->
1343 ( RBody == empty ->
1344 Body = term_variables(V,Vars)
1345 ;
1346 Body = (term_variables(V,Vars,Tail),RBody)
1347 ),
1348 N = M
1349 ;
1350 Vars = Tail,
1351 Body = RBody,
1352 N is M + 1
1353 ).
1355 generate_extra_clauses(Constraints,List) :-
1356 generate_activate_clause(List,Tail0),
1357 generate_remove_clause(Tail0,Tail1),
1358 generate_allocate_clause(Tail1,Tail2),
1359 generate_insert_constraint_internal(Tail2,Tail3),
1360 global_indexed_variables_clause(Constraints,Tail3,[]).
1362 generate_remove_clause(List,Tail) :-
1363 ( is_used_auxiliary_predicate(remove_constraint_internal) ->
1364 List = [RemoveClause|Tail],
1365 use_auxiliary_predicate(chr_indexed_variables),
1366 ( are_none_suspended_on_variables ->
1367 RemoveClause =
1368 (
1369 remove_constraint_internal(Susp) :-
1370 arg( 2, Susp, Mref),
1371 'chr update_mutable'( removed, Mref)
1372 )
1373 ;
1374 RemoveClause =
1375 (
1376 remove_constraint_internal(Susp, Agenda, Delete) :-
1377 arg( 2, Susp, Mref),
1378 'chr get_mutable'( State, Mref),
1379 'chr update_mutable'( removed, Mref), % mark in any case
1380 ( compound(State) -> % passive/1
1381 Agenda = [],
1382 Delete = no
1383 ; State==removed ->
1384 Agenda = [],
1385 Delete = no
1386 %; State==triggered ->
1387 % Agenda = []
1388 ;
1389 Delete = yes,
1390 chr_indexed_variables(Susp,Agenda)
1391 )
1392 )
1393 )
1394 ;
1395 List = Tail
1396 ).
1398 generate_activate_clause(List,Tail) :-
1399 ( is_used_auxiliary_predicate(activate_constraint) ->
1400 List = [ActivateClause|Tail],
1401 use_auxiliary_predicate(chr_indexed_variables),
1402 ActivateClause =
1403 (
1404 activate_constraint(Store, Vars, Susp, Generation) :-
1405 arg( 2, Susp, Mref),
1406 'chr get_mutable'( State, Mref),
1407 'chr update_mutable'( active, Mref),
1408 ( nonvar(Generation) -> % aih
1409 true
1410 ;
1411 arg( 4, Susp, Gref),
1412 'chr get_mutable'( Gen, Gref),
1413 Generation is Gen+1,
1414 'chr update_mutable'( Generation, Gref)
1415 ),
1416 ( compound(State) -> % passive/1
1417 term_variables( State, Vars),
1418 'chr none_locked'( Vars),
1419 Store = yes
1420 ; State == removed -> % the price for eager removal ...
1421 chr_indexed_variables(Susp,Vars),
1422 Store = yes
1423 ;
1424 Vars = [],
1425 Store = no
1426 )
1427 )
1428 ;
1429 List = Tail
1430 ).
1432 generate_allocate_clause(List,Tail) :-
1433 ( is_used_auxiliary_predicate(allocate_constraint) ->
1434 List = [AllocateClause|Tail],
1435 use_auxiliary_predicate(chr_indexed_variables),
1436 AllocateClause =
1437 (
1438 allocate_constraint( Closure, Self, F, Args) :-
1439 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1440 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1441 'chr empty_history'(History),
1442 'chr create_mutable'(History,Href), % Href = mutable(History),
1443 chr_indexed_variables(Self,Vars),
1444 'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)),
1445 'chr gen_id'( Id)
1446 )
1447 ;
1448 List = Tail
1449 ).
1451 generate_insert_constraint_internal(List,Tail) :-
1452 ( is_used_auxiliary_predicate(insert_constraint_internal) ->
1453 ( are_none_suspended_on_variables ->
1454 List = [Clause1,Clause2|Tail],
1455 % is clause1 needed????
1456 Clause1 =
1457 (
1458 insert_constraint_internal(yes, [], Self, Closure, F, Args) :-
1459 'chr create_mutable'(active,Active),
1460 'chr create_mutable'(0,Zero),
1461 'chr create_mutable'(t,Tee),
1462 Self =.. [suspension,Id,Active,Closure,Zero,Tee,F|Args],
1463 'chr gen_id'(Id)
1464 ),
1465 Clause2 =
1466 (
1467 insert_constraint_internal(Self, F, Args) :-
1468 'chr create_mutable'(active,Active),
1469 'chr create_mutable'(0,Zero),
1470 'chr create_mutable'(t,Tee),
1471 Self =.. [suspension,Id,Active,true,Zero,Tee,F|Args],
1472 'chr gen_id'(Id)
1473 )
1474 ;
1475 List = [Clause|Tail],
1476 use_auxiliary_predicate(chr_indexed_variables),
1477 Clause =
1478 (
1479 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1480 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1481 chr_indexed_variables(Self,Vars),
1482 'chr none_locked'(Vars),
1483 'chr create_mutable'(active,Mref), % Mref = mutable(active),
1484 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1485 'chr empty_history'(History),
1486 'chr create_mutable'(History,Href), % Href = mutable(History),
1487 'chr gen_id'(Id)
1488 )
1489 )
1490 ;
1491 List = Tail
1492 ).
1494 global_indexed_variables_clause(Constraints,List,Tail) :-
1495 ( is_used_auxiliary_predicate(chr_indexed_variables) ->
1496 List = [Clause|Tail],
1497 ( chr_pp_flag(reduced_indexing,on) ->
1498 ( are_none_suspended_on_variables ->
1499 Body = true,
1500 Vars = []
1501 ;
1502 Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
1503 ),
1504 Clause = ( chr_indexed_variables(Susp,Vars) :- Body )
1505 ;
1506 Clause =
1507 ( chr_indexed_variables(Susp,Vars) :-
1508 'chr chr_indexed_variables'(Susp,Vars)
1509 )
1510 )
1511 ;
1512 List = Tail
1513 ).
1515 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1516 generate_attach_increment(Clauses) :-
1517 get_max_constraint_index(N),
1518 ( N > 0 ->
1519 Clauses = [Clause1,Clause2],
1520 generate_attach_increment_empty(Clause1),
1521 ( N == 1 ->
1522 generate_attach_increment_one(Clause2)
1523 ;
1524 generate_attach_increment_many(N,Clause2)
1525 )
1526 ;
1527 Clauses = []
1528 ).
1530 generate_attach_increment_empty((attach_increment([],_) :- true)).
1532 generate_attach_increment_one(Clause) :-
1533 Head = attach_increment([Var|Vars],Susps),
1534 get_target_module(Mod),
1535 Body =
1536 (
1537 'chr not_locked'(Var),
1538 ( get_attr(Var,Mod,VarSusps) ->
1539 sort(VarSusps,SortedVarSusps),
1540 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
1541 put_attr(Var,Mod,MergedSusps)
1542 ;
1543 put_attr(Var,Mod,Susps)
1544 ),
1545 attach_increment(Vars,Susps)
1546 ),
1547 Clause = (Head :- Body).
1549 generate_attach_increment_many(N,Clause) :-
1550 make_attr(N,Mask,SuspsList,Attr),
1551 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1552 Head = attach_increment([Var|Vars],Attr),
1553 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1554 list2conj(Gs,SortGoals),
1555 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1556 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1557 get_target_module(Mod),
1558 Body =
1559 (
1560 'chr not_locked'(Var),
1561 ( get_attr(Var,Mod,TOtherAttr) ->
1562 TOtherAttr = OtherAttr,
1563 SortGoals,
1564 MergedMask is Mask \/ OtherMask,
1565 put_attr(Var,Mod,NewAttr)
1566 ;
1567 put_attr(Var,Mod,Attr)
1568 ),
1569 attach_increment(Vars,Attr)
1570 ),
1571 Clause = (Head :- Body).
1573 %% attr_unify_hook
1574 generate_attr_unify_hook(Clauses) :-
1575 get_max_constraint_index(N),
1576 ( N == 0 ->
1577 Clauses = []
1578 ;
1579 Clauses = [Clause],
1580 ( N == 1 ->
1581 generate_attr_unify_hook_one(Clause)
1582 ;
1583 generate_attr_unify_hook_many(N,Clause)
1584 )
1585 ).
1587 generate_attr_unify_hook_one(Clause) :-
1588 Head = attr_unify_hook(Susps,Other),
1589 get_target_module(Mod),
1590 make_run_suspensions(NewSusps,WakeNewSusps),
1591 make_run_suspensions(Susps,WakeSusps),
1592 Body =
1593 (
1594 sort(Susps, SortedSusps),
1595 ( var(Other) ->
1596 ( get_attr(Other,Mod,OtherSusps) ->
1597 true
1598 ;
1599 OtherSusps = []
1600 ),
1601 sort(OtherSusps,SortedOtherSusps),
1602 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1603 put_attr(Other,Mod,NewSusps),
1604 WakeNewSusps
1605 ;
1606 ( compound(Other) ->
1607 term_variables(Other,OtherVars),
1608 attach_increment(OtherVars, SortedSusps)
1609 ;
1610 true
1611 ),
1612 WakeSusps
1613 )
1614 ),
1615 Clause = (Head :- Body).
1617 generate_attr_unify_hook_many(N,Clause) :-
1618 make_attr(N,Mask,SuspsList,Attr),
1619 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1620 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1621 list2conj(SortGoalList,SortGoals),
1622 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1623 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1624 C = (sort(E,F),
1625 'chr merge_attributes'(D,F,G)) ),
1626 SortMergeGoalList),
1627 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1628 list2conj(SortMergeGoalList,SortMergeGoals),
1629 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1630 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1631 Head = attr_unify_hook(Attr,Other),
1632 get_target_module(Mod),
1633 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1634 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1635 Body =
1636 (
1637 SortGoals,
1638 ( var(Other) ->
1639 ( get_attr(Other,Mod,TOtherAttr) ->
1640 TOtherAttr = OtherAttr,
1641 SortMergeGoals,
1642 MergedMask is Mask \/ OtherMask,
1643 put_attr(Other,Mod,MergedAttr),
1644 WakeMergedSusps
1645 ;
1646 put_attr(Other,Mod,SortedAttr),
1647 WakeSortedSusps
1648 )
1649 ;
1650 ( compound(Other) ->
1651 term_variables(Other,OtherVars),
1652 attach_increment(OtherVars,SortedAttr)
1653 ;
1654 true
1655 ),
1656 WakeSortedSusps
1657 )
1658 ),
1659 Clause = (Head :- Body).
1661 make_run_suspensions(Susps,Goal) :-
1662 ( chr_pp_flag(debugable,on) ->
1663 Goal = 'chr run_suspensions_d'(Susps)
1664 ;
1665 Goal = 'chr run_suspensions'(Susps)
1666 ).
1668 make_run_suspensions_loop(SuspsList,Goal) :-
1669 ( chr_pp_flag(debugable,on) ->
1670 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1671 ;
1672 Goal = 'chr run_suspensions_loop'(SuspsList)
1673 ).
1675 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1676 % $insert_in_store_F/A
1677 % $delete_from_store_F/A
1679 generate_insert_delete_constraints([],[]).
1680 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1681 ( is_stored(FA) ->
1682 Clauses = [IClause,DClause|RestClauses],
1683 generate_insert_delete_constraint(FA,IClause,DClause)
1684 ;
1685 Clauses = RestClauses
1686 ),
1687 generate_insert_delete_constraints(Rest,RestClauses).
1689 generate_insert_delete_constraint(FA,IClause,DClause) :-
1690 get_store_type(FA,StoreType),
1691 generate_insert_constraint(StoreType,FA,IClause),
1692 generate_delete_constraint(StoreType,FA,DClause).
1694 generate_insert_constraint(StoreType,C,Clause) :-
1695 make_name('$insert_in_store_',C,ClauseName),
1696 Head =.. [ClauseName,Susp],
1697 generate_insert_constraint_body(StoreType,C,Susp,Body),
1698 ( chr_pp_flag(store_counter,on) ->
1699 InsertCounterInc = '$insert_counter_inc'
1700 ;
1701 InsertCounterInc = true
1702 ),
1703 Clause = (Head :- InsertCounterInc,Body).
1705 generate_insert_constraint_body(default,C,Susp,Body) :-
1706 get_target_module(Mod),
1707 get_max_constraint_index(Total),
1708 ( Total == 1 ->
1709 generate_attach_body_1(C,Store,Susp,AttachBody)
1710 ;
1711 generate_attach_body_n(C,Store,Susp,AttachBody)
1712 ),
1713 Body =
1714 (
1715 'chr default_store'(Store),
1716 AttachBody
1717 ).
1718 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1719 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1720 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1721 global_ground_store_name(C,StoreName),
1722 make_get_store_goal(StoreName,Store,GetStoreGoal),
1723 make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
1724 Body =
1725 (
1726 GetStoreGoal, % nb_getval(StoreName,Store),
1727 UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
1728 ).
1729 generate_insert_constraint_body(global_singleton,C,Susp,Body) :-
1730 global_singleton_store_name(C,StoreName),
1731 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
1732 Body =
1733 (
1734 UpdateStoreGoal % b_setval(StoreName,Susp)
1735 ).
1736 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1737 find_with_var_identity(
1738 B,
1739 [Susp],
1740 (
1741 member(ST,StoreTypes),
1742 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1743 ),
1744 Bodies
1745 ),
1746 list2conj(Bodies,Body).
1748 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1749 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1750 multi_hash_store_name(FA,Index,StoreName),
1751 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1752 make_get_store_goal(StoreName,Store,GetStoreGoal),
1753 Body =
1754 (
1755 KeyBody,
1756 GetStoreGoal, % nb_getval(StoreName,Store),
1757 insert_ht(Store,Key,Susp)
1758 ),
1759 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1761 generate_delete_constraint(StoreType,FA,Clause) :-
1762 make_name('$delete_from_store_',FA,ClauseName),
1763 Head =.. [ClauseName,Susp],
1764 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1765 ( chr_pp_flag(store_counter,on) ->
1766 DeleteCounterInc = '$delete_counter_inc'
1767 ;
1768 DeleteCounterInc = true
1769 ),
1770 Clause = (Head :- DeleteCounterInc, Body).
1772 generate_delete_constraint_body(default,C,Susp,Body) :-
1773 get_target_module(Mod),
1774 get_max_constraint_index(Total),
1775 ( Total == 1 ->
1776 generate_detach_body_1(C,Store,Susp,DetachBody),
1777 Body =
1778 (
1779 'chr default_store'(Store),
1780 DetachBody
1781 )
1782 ;
1783 generate_detach_body_n(C,Store,Susp,DetachBody),
1784 Body =
1785 (
1786 'chr default_store'(Store),
1787 DetachBody
1788 )
1789 ).
1790 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1791 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1792 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1793 global_ground_store_name(C,StoreName),
1794 make_get_store_goal(StoreName,Store,GetStoreGoal),
1795 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
1796 Body =
1797 (
1798 GetStoreGoal, % nb_getval(StoreName,Store),
1799 'chr sbag_del_element'(Store,Susp,NStore),
1800 UpdateStoreGoal % b_setval(StoreName,NStore)
1801 ).
1802 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
1803 global_singleton_store_name(C,StoreName),
1804 make_update_store_goal(StoreName,[],UpdateStoreGoal),
1805 Body =
1806 (
1807 UpdateStoreGoal % b_setval(StoreName,[])
1808 ).
1809 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1810 find_with_var_identity(
1811 B,
1812 [Susp],
1813 (
1814 member(ST,StoreTypes),
1815 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1816 ),
1817 Bodies
1818 ),
1819 list2conj(Bodies,Body).
1821 generate_multi_hash_delete_constraint_bodies([],_,_,true).
1822 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1823 multi_hash_store_name(FA,Index,StoreName),
1824 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1825 make_get_store_goal(StoreName,Store,GetStoreGoal),
1826 Body =
1827 (
1828 KeyBody,
1829 GetStoreGoal, % nb_getval(StoreName,Store),
1830 delete_ht(Store,Key,Susp)
1831 ),
1832 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
1834 generate_delete_constraint_call(FA,Susp,Call) :-
1835 make_name('$delete_from_store_',FA,Functor),
1836 Call =.. [Functor,Susp].
1838 generate_insert_constraint_call(FA,Susp,Call) :-
1839 make_name('$insert_in_store_',FA,Functor),
1840 Call =.. [Functor,Susp].
1842 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1844 :- chr_constraint
1845 module_initializer/1,
1846 module_initializers/1.
1848 module_initializers(G), module_initializer(Initializer) <=>
1849 G = (Initializer,Initializers),
1850 module_initializers(Initializers).
1852 module_initializers(G) <=>
1853 G = true.
1855 generate_attach_code(Constraints,[Enumerate|L]) :-
1856 enumerate_stores_code(Constraints,Enumerate),
1857 generate_attach_code(Constraints,L,T),
1858 module_initializers(Initializers),
1859 T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')].
1861 generate_attach_code([],L,L).
1862 generate_attach_code([C|Cs],L,T) :-
1863 get_store_type(C,StoreType),
1864 generate_attach_code(StoreType,C,L,L1),
1865 generate_attach_code(Cs,L1,T).
1867 generate_attach_code(default,_,L,L).
1868 generate_attach_code(multi_hash(Indexes),C,L,T) :-
1869 multi_hash_store_initialisations(Indexes,C,L,L1),
1870 multi_hash_via_lookups(Indexes,C,L1,T).
1871 generate_attach_code(global_ground,C,L,T) :-
1872 global_ground_store_initialisation(C,L,T).
1873 generate_attach_code(global_singleton,C,L,T) :-
1874 global_singleton_store_initialisation(C,L,T).
1875 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
1876 multi_store_generate_attach_code(StoreTypes,C,L,T).
1878 multi_store_generate_attach_code([],_,L,L).
1879 multi_store_generate_attach_code([ST|STs],C,L,T) :-
1880 generate_attach_code(ST,C,L,L1),
1881 multi_store_generate_attach_code(STs,C,L1,T).
1883 multi_hash_store_initialisations([],_,L,L).
1884 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
1885 multi_hash_store_name(FA,Index,StoreName),
1886 make_init_store_goal(StoreName,HT,InitStoreGoal),
1887 module_initializer((new_ht(HT),InitStoreGoal)),
1888 %% module_initializer((new_ht(HT),nb_setval(StoreName,HT))),
1889 L1 = L,
1890 multi_hash_store_initialisations(Indexes,FA,L1,T).
1892 global_ground_store_initialisation(C,L,T) :-
1893 global_ground_store_name(C,StoreName),
1894 make_init_store_goal(StoreName,[],InitStoreGoal),
1895 module_initializer(InitStoreGoal),
1896 %% module_initializer(nb_setval(StoreName,[])),
1897 L = T.
1898 global_singleton_store_initialisation(C,L,T) :-
1899 global_singleton_store_name(C,StoreName),
1900 make_init_store_goal(StoreName,[],InitStoreGoal),
1901 module_initializer(InitStoreGoal),
1902 %% module_initializer(nb_setval(StoreName,[])),
1903 L = T.
1905 multi_hash_via_lookups([],_,L,L).
1906 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
1907 multi_hash_via_lookup_name(C,Index,PredName),
1908 Head =.. [PredName,Key,SuspsList],
1909 multi_hash_store_name(C,Index,StoreName),
1910 make_get_store_goal(StoreName,HT,GetStoreGoal),
1911 Body =
1912 (
1913 GetStoreGoal, % nb_getval(StoreName,HT),
1914 lookup_ht(HT,Key,SuspsList)
1915 ),
1916 L = [(Head :- Body)|L1],
1917 multi_hash_via_lookups(Indexes,C,L1,T).
1919 multi_hash_via_lookup_name(F/A,Index,Name) :-
1920 ( integer(Index) ->
1921 IndexName = Index
1922 ; is_list(Index) ->
1923 atom_concat_list(Index,IndexName)
1924 ),
1925 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
1927 multi_hash_store_name(F/A,Index,Name) :-
1928 get_target_module(Mod),
1929 ( integer(Index) ->
1930 IndexName = Index
1931 ; is_list(Index) ->
1932 atom_concat_list(Index,IndexName)
1933 ),
1934 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
1936 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
1937 ( ( integer(Index) ->
1938 I = Index
1939 ;
1940 Index = [I]
1941 ) ->
1942 SuspIndex is I + 6,
1943 KeyBody = arg(SuspIndex,Susp,Key)
1944 ; is_list(Index) ->
1945 sort(Index,Indexes),
1946 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
1947 pairup(Bodies,Keys,ArgKeyPairs),
1948 Key =.. [k|Keys],
1949 list2conj(Bodies,KeyBody)
1950 ).
1952 multi_hash_key_args(Index,Head,KeyArgs) :-
1953 ( integer(Index) ->
1954 arg(Index,Head,Arg),
1955 KeyArgs = [Arg]
1956 ; is_list(Index) ->
1957 sort(Index,Indexes),
1958 term_variables(Head,Vars),
1959 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
1960 ).
1962 global_ground_store_name(F/A,Name) :-
1963 get_target_module(Mod),
1964 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
1965 global_singleton_store_name(F/A,Name) :-
1966 get_target_module(Mod),
1967 atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
1968 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1969 enumerate_stores_code(Constraints,Clause) :-
1970 Head = '$enumerate_suspensions'(Susp),
1971 enumerate_store_bodies(Constraints,Susp,Bodies),
1972 list2disj(Bodies,Body),
1973 Clause = (Head :- Body).
1975 enumerate_store_bodies([],_,[]).
1976 enumerate_store_bodies([C|Cs],Susp,L) :-
1977 ( is_stored(C) ->
1978 get_store_type(C,StoreType),
1979 enumerate_store_body(StoreType,C,Susp,B),
1980 L = [B|T]
1981 ;
1982 L = T
1983 ),
1984 enumerate_store_bodies(Cs,Susp,T).
1986 enumerate_store_body(default,C,Susp,Body) :-
1987 get_constraint_index(C,Index),
1988 get_target_module(Mod),
1989 get_max_constraint_index(MaxIndex),
1990 Body1 =
1991 (
1992 'chr default_store'(GlobalStore),
1993 get_attr(GlobalStore,Mod,Attr)
1994 ),
1995 ( MaxIndex > 1 ->
1996 NIndex is Index + 1,
1997 Body2 =
1998 (
1999 arg(NIndex,Attr,List),
2000 'chr sbag_member'(Susp,List)
2001 )
2002 ;
2003 Body2 = 'chr sbag_member'(Susp,Attr)
2004 ),
2005 Body = (Body1,Body2).
2006 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
2007 multi_hash_enumerate_store_body(Index,C,Susp,Body).
2008 enumerate_store_body(global_ground,C,Susp,Body) :-
2009 global_ground_store_name(C,StoreName),
2010 make_get_store_goal(StoreName,List,GetStoreGoal),
2011 Body =
2012 (
2013 GetStoreGoal, % nb_getval(StoreName,List),
2014 'chr sbag_member'(Susp,List)
2015 ).
2016 enumerate_store_body(global_singleton,C,Susp,Body) :-
2017 global_singleton_store_name(C,StoreName),
2018 make_get_store_goal(StoreName,Susp,GetStoreGoal),
2019 Body =
2020 (
2021 GetStoreGoal, % nb_getval(StoreName,Susp),
2022 Susp \== []
2023 ).
2024 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
2025 once((
2026 member(ST,STs),
2027 enumerate_store_body(ST,C,Susp,Body)
2028 )).
2030 multi_hash_enumerate_store_body(I,C,Susp,B) :-
2031 multi_hash_store_name(C,I,StoreName),
2032 make_get_store_goal(StoreName,HT,GetStoreGoal),
2033 B =
2034 (
2035 GetStoreGoal, % nb_getval(StoreName,HT),
2036 value_ht(HT,Susp)
2037 ).
2039 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2042 :- chr_constraint
2043 prev_guard_list/7,
2044 simplify_guards/1,
2045 set_all_passive/1.
2047 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
2048 :- chr_option(mode,simplify_guards(+)).
2049 :- chr_option(mode,set_all_passive(+)).
2051 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2052 % GUARD SIMPLIFICATION
2053 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2054 % If the negation of the guards of earlier rules entails (part of)
2055 % the current guard, the current guard can be simplified. We can only
2056 % use earlier rules with a head that matches if the head of the current
2057 % rule does, and which make it impossible for the current rule to match
2058 % if they fire (i.e. they shouldn't be propagation rules and their
2059 % head constraints must be subsets of those of the current rule).
2060 % At this point, we know for sure that the negation of the guard
2061 % of such a rule has to be true (otherwise the earlier rule would have
2062 % fired, because of the refined operational semantics), so we can use
2063 % that information to simplify the guard by replacing all entailed
2064 % conditions by true/0. As a consequence, the never-stored analysis
2065 % (in a further phase) will detect more cases of never-stored constraints.
2066 %
2067 % e.g. c(X),d(Y) <=> X > 0 | ...
2068 % e(X) <=> X < 0 | ...
2069 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
2070 % \____________/
2071 % true
2073 guard_simplification :-
2074 ( chr_pp_flag(guard_simplification,on) ->
2075 multiple_occ_constraints_checked([]),
2076 simplify_guards(1)
2077 ;
2078 true
2079 ).
2081 % for every rule, we create a prev_guard_list where the last argument
2082 % eventually is a list of the negations of earlier guards
2083 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=>
2084 Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
2085 append(Head1,Head2,Heads),
2086 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
2087 add_guard_to_head(Heads,G,GHeads),
2088 PrevRule is RuleNb-1,
2089 prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
2090 multiple_occ_constraints_checked([]),
2091 NextRule is RuleNb+1, simplify_guards(NextRule).
2093 simplify_guards(_) <=> true.
2095 % the negation of the guard of a non-propagation rule is added
2096 % if its kept head constraints are a subset of the kept constraints of
2097 % the rule we're working on, and its removed head constraints (at least one)
2098 % are a subset of the removed constraints
2099 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
2100 Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
2101 H1 \== [],
2102 append(H1,H2,Heads),
2103 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
2104 setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
2105 Renamings \= []
2106 |
2107 compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
2108 append(GuardList,DerivedInfo,GL1),
2109 list2conj(GL1,GL_),
2110 conj2list(GL_,GL),
2111 append(GH_New1,GH,GH1),
2112 list2conj(GH1,GH_),
2113 conj2list(GH_,GH_New),
2114 N1 is N-1,
2115 prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
2118 % if this isn't the case, we skip this one and try the next rule
2119 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
2120 N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
2122 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
2123 GH \== [] |
2124 add_type_information_(H,GH,TypeInfo),
2125 conj2list(TypeInfo,TI),
2126 term_variables(H,HeadVars),
2127 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
2128 list2conj(Info,InfoC),
2129 conj2list(InfoC,InfoL),
2130 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
2132 add_type_information_(H,[],true) :- !.
2133 add_type_information_(H,[GH|GHs],TI) :- !,
2134 add_type_information(H,GH,TI1),
2135 TI = (TI1, TI2),
2136 add_type_information_(H,GHs,TI2).
2138 % when all earlier guards are added or skipped, we simplify the guard.
2139 % if it's different from the original one, we change the rule
2140 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=>
2141 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2142 G \== true, % let's not try to simplify this ;)
2143 append(M,GuardList,Info),
2144 simplify_guard(G,B,Info,SimpleGuard,NB),
2145 G \== SimpleGuard |
2146 % ( prolog_flag(verbose,V), V == yes ->
2147 % format(' * Guard simplification in ~@\n',[format_rule(Rule)]),
2148 % format(' was: ~w\n',[G]),
2149 % format(' now: ~w\n',[SimpleGuard]),
2150 % (NB\==B -> format(' new body: ~w\n',[NB]) ; true)
2151 % ;
2152 % true
2153 % ),
2154 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
2155 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
2158 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2159 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
2160 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2162 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
2164 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
2165 copy_term(Matchings-G2,FreshMatchings),
2166 variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
2167 append(Renaming1,ExtraRenaming,Renaming2),
2168 list2conj(Matchings,Match),
2169 negate_b(Match,HeadsDontMatch),
2170 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
2171 list2conj(HeadsMatch,HeadsMatchBut),
2172 term_variables(Renaming2,RenVars),
2173 term_variables(Matchings-G2-HeadsMatch,MGVars),
2174 new_vars(MGVars,RenVars,ExtraRenaming2),
2175 append(Renaming2,ExtraRenaming2,Renaming),
2176 negate_b(G2,TheGuardFailed),
2177 ( G2 == true -> % true can't fail
2178 Info_ = HeadsDontMatch
2179 ;
2180 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
2181 ),
2182 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
2183 copy_with_variable_replacement(G2,RenamedG2,Renaming),
2184 copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
2185 list2conj(RenamedMatchings_,RenamedMatchings),
2186 add_guard_to_head(H,RenamedG2,GH2),
2187 add_guard_to_head(GH2,RenamedMatchings,GH3),
2188 compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
2189 append([DerivedInfo1],DerivedInfo2,DerivedInfo),
2190 append([GH3],GH_New2,GH_New).
2193 simplify_guard(G,B,Info,SG,NB) :-
2194 conj2list(G,LG),
2195 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
2196 list2conj(SGL,SG).
2199 new_vars([],_,[]).
2200 new_vars([A|As],RV,ER) :-
2201 ( memberchk_eq(A,RV) ->
2202 new_vars(As,RV,ER)
2203 ;
2204 ER = [A-NewA,NewA-A|ER2],
2205 new_vars(As,RV,ER2)
2206 ).
2208 % check if a list of constraints is a subset of another list of constraints
2209 % (multiset-subset), meanwhile computing a variable renaming to convert
2210 % one into the other.
2211 head_subset(H,Head,Renaming) :-
2212 head_subset(H,Head,Renaming,[],_).
2214 % empty list is a subset of everything
2215 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
2216 Renaming = Cumul,
2217 Headleft = Head.
2219 % first constraint has to be in the list, the rest has to be a subset
2220 % of the list with one occurrence of the first constraint removed
2221 % (has to be multiset-subset)
2222 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
2223 head_subset(A,Head,R1,Cumul,Headleft1),
2224 head_subset(B,Headleft1,R2,R1,Headleft2),
2225 Renaming = R2,
2226 Headleft = Headleft2.
2228 % check if A is in the list, remove it from Headleft
2229 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
2230 ( head_subset(A,X,R1,Cumul,HL1),
2231 Renaming = R1,
2232 Headleft = Y
2233 ;
2234 head_subset(A,Y,R2,Cumul,HL2),
2235 Renaming = R2,
2236 Headleft = [X|HL2]
2237 ).
2239 % A is X if there's a variable renaming to make them identical
2240 head_subset(A,X,Renaming,Cumul,Headleft) :-
2241 variable_replacement(A,X,Cumul,Renaming),
2242 Headleft = [].
2244 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
2245 extract_variables(Heads,VH1),
2246 make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
2247 insert_variables(H1_,Heads,UniqueVarsHeads).
2249 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
2250 extract_variables(Heads,VH1),
2251 make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
2252 insert_variables(H1_,Heads,UniqueVarsHeads).
2254 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
2255 extract_variables(Heads,VH1),
2256 extract_variables(UniqueVarsHeads,UV),
2257 make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
2260 extract_variables([],[]).
2261 extract_variables([X|R],V) :-
2262 X =.. [_|Args],
2263 extract_variables(R,V2),
2264 append(Args,V2,V).
2266 insert_variables([],[],[]) :- !.
2267 insert_variables(Vars,[C|R],[C2|R2]) :-
2268 C =.. [F | Args],
2269 length(Args,N),
2270 take_first_N(Vars,N,Args2,RestVars),
2271 C2 =.. [F | Args2],
2272 insert_variables(RestVars,R,R2).
2274 take_first_N(Vars,0,[],Vars) :- !.
2275 take_first_N([X|R],N,[X|R2],RestVars) :-
2276 N1 is N-1,
2277 take_first_N(R,N1,R2,RestVars).
2279 make_matchings_explicit([],[],_,MC,MC,[]).
2280 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
2281 ( var(X) ->
2282 ( memberchk_eq(X,C) ->
2283 list2disj(MC,MC_disj),
2284 M = [(MC_disj ; NewVar == X)|M2], % or only = ??
2285 C2 = C
2286 ;
2287 M = M2,
2288 NewVar = X,
2289 C2 = [X|C]
2290 ),
2291 MC2 = MC
2292 ;
2293 functor(X,F,A),
2294 X =.. [F|Args],
2295 make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
2296 X_ =.. [F|NewArgs],
2297 (ArgM == [] ->
2298 M = [functor(NewVar,F,A) |M2]
2299 ;
2300 list2conj(ArgM,ArgM_conj),
2301 list2disj(MC,MC_disj),
2302 ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
2303 M = [ functor(NewVar,F,A) , ArgM_|M2]
2304 ),
2305 MC2 = [ NewVar \= X_ |MC_],
2306 term_variables(Args,ArgVars),
2307 append(C,ArgVars,C2)
2308 ),
2309 make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
2312 make_matchings_explicit_not_negated([],[],_,[]).
2313 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
2314 M = [NewVar = X|M2],
2315 C2 = C,
2316 make_matchings_explicit_not_negated(R,R2,C2,M2).
2319 add_guard_to_head([],G,[]).
2320 add_guard_to_head([H|RH],G,[GH|RGH]) :-
2321 (var(H) ->
2322 find_guard_info_for_var(H,G,GH)
2323 ;
2324 functor(H,F,A),
2325 H =.. [F|HArgs],
2326 add_guard_to_head(HArgs,G,NewHArgs),
2327 GH =.. [F|NewHArgs]
2328 ),
2329 add_guard_to_head(RH,G,RGH).
2331 find_guard_info_for_var(H,(G1,G2),GH) :- !,
2332 find_guard_info_for_var(H,G1,GH1),
2333 find_guard_info_for_var(GH1,G2,GH).
2335 find_guard_info_for_var(H,G,GH) :-
2336 (G = (H1 = A), H == H1 ->
2337 GH = A
2338 ;
2339 (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
2340 length(GHArg,HA),
2341 GH =.. [HF|GHArg]
2342 ;
2343 GH = H
2344 )
2345 ).
2347 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2348 % ALWAYS FAILING HEADS
2349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2351 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=>
2352 chr_pp_flag(check_impossible_rules,on),
2353 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2354 append(M,GuardList,Info),
2355 guard_entailment:entails_guard(Info,fail) |
2356 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
2357 set_all_passive(RuleNb).
2359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2360 % HEAD SIMPLIFICATION
2361 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2363 % now we check the head matchings (guard may have been simplified meanwhile)
2364 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=>
2365 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2366 simplify_heads(M,GuardList,G,B,NewM,NewB),
2367 NewM \== [],
2368 extract_variables(Head1,VH1),
2369 extract_variables(Head2,VH2),
2370 extract_variables(H,VH),
2371 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
2372 insert_variables(H1,Head1,NewH1),
2373 insert_variables(H2,Head2,NewH2),
2374 append(NewB,NewB_,NewBody),
2375 list2conj(NewBody,BodyMatchings),
2376 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
2377 (Head1 \== NewH1 ; Head2 \== NewH2 )
2378 |
2379 % ( prolog_flag(verbose,V), V == yes ->
2380 % format(' * Head simplification in ~@\n',[format_rule(Rule)]),
2381 % format(' was: ~w \\ ~w \n',[Head2,Head1]),
2382 % format(' now: ~w \\ ~w \n',[NewH2,NewH1]),
2383 % format(' extra body: ~w \n',[BodyMatchings])
2384 % ;
2385 % true
2386 % ),
2387 rule(RuleNb,NewRule).
2391 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2392 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
2393 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2395 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
2396 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
2397 ( NH == M ->
2398 H2_ = M,
2399 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
2400 ;
2401 (M = functor(X,F,A), NH == X ->
2402 length(A_args,A),
2403 (var(H2) ->
2404 NewB1 = [],
2405 H2_ =.. [F|A_args]
2406 ;
2407 H2 =.. [F|OrigArgs],
2408 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2409 H2_ =.. [F|A_args_]
2410 ),
2411 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
2412 append(NewB1,NewB2,NewB)
2413 ;
2414 H2_ = H2,
2415 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
2416 )
2417 ).
2419 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
2420 ( NH == M ->
2421 H1_ = M,
2422 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
2423 ;
2424 (M = functor(X,F,A), NH == X ->
2425 length(A_args,A),
2426 (var(H1) ->
2427 NewB1 = [],
2428 H1_ =.. [F|A_args]
2429 ;
2430 H1 =.. [F|OrigArgs],
2431 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2432 H1_ =.. [F|A_args_]
2433 ),
2434 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
2435 append(NewB1,NewB2,NewB)
2436 ;
2437 H1_ = H1,
2438 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
2439 )
2440 ).
2442 use_same_args([],[],[],_,_,[]).
2443 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2444 var(OA),!,
2445 Out = OA,
2446 use_same_args(ROA,RNA,ROut,G,Body,NewB).
2447 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2448 nonvar(OA),!,
2449 ( vars_occur_in(OA,Body) ->
2450 NewB = [NA = OA|NextB]
2451 ;
2452 NewB = NextB
2453 ),
2454 Out = NA,
2455 use_same_args(ROA,RNA,ROut,G,Body,NextB).
2458 simplify_heads([],_GuardList,_G,_Body,[],[]).
2459 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
2460 M = (A = B),
2461 ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
2462 guard_entailment:entails_guard(GuardList,(A=B)) ->
2463 ( vars_occur_in(B,G-RM-GuardList) ->
2464 NewB = NextB,
2465 NewM = NextM
2466 ;
2467 ( vars_occur_in(B,Body) ->
2468 NewB = [A = B|NextB]
2469 ;
2470 NewB = NextB
2471 ),
2472 NewM = [A|NextM]
2473 )
2474 ;
2475 ( nonvar(B), functor(B,BFu,BAr),
2476 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
2477 NewB = NextB,
2478 ( vars_occur_in(B,G-RM-GuardList) ->
2479 NewM = NextM
2480 ;
2481 NewM = [functor(A,BFu,BAr)|NextM]
2482 )
2483 ;
2484 NewM = NextM,
2485 NewB = NextB
2486 )
2487 ),
2488 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
2490 vars_occur_in(B,G) :-
2491 term_variables(B,BVars),
2492 term_variables(G,GVars),
2493 intersect_eq(BVars,GVars,L),
2494 L \== [].
2497 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2498 % ALWAYS FAILING GUARDS
2499 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2501 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID) ==> passive(RuleNb,ID).
2502 set_all_passive(_) <=> true.
2504 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==>
2505 chr_pp_flag(check_impossible_rules,on),
2506 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
2507 conj2list(G,GL),
2508 guard_entailment:entails_guard(GL,fail) |
2509 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
2510 set_all_passive(RuleNb).
2514 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2515 % OCCURRENCE SUBSUMPTION
2516 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2518 :- chr_constraint
2519 first_occ_in_rule/4,
2520 next_occ_in_rule/6,
2521 multiple_occ_constraints_checked/1.
2523 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
2524 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
2525 :- chr_option(mode,multiple_occ_constraints_checked(+)).
2529 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2530 occurrence(C,O,RuleNb,ID), occurrence(C,O2,RuleNb,ID2), rule(RuleNb,Rule)
2531 \ multiple_occ_constraints_checked(Done) <=>
2532 O < O2,
2533 chr_pp_flag(occurrence_subsumption,on),
2534 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
2535 H1 \== [],
2536 \+ memberchk_eq(C,Done) |
2537 first_occ_in_rule(RuleNb,C,O,ID),
2538 multiple_occ_constraints_checked([C|Done]).
2541 occurrence(C,O,RuleNb,ID) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 |
2542 first_occ_in_rule(RuleNb,C,O,ID).
2544 first_occ_in_rule(RuleNb,C,O,ID_o1) <=>
2545 C = F/A,
2546 functor(FreshHead,F,A),
2547 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
2549 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2)
2550 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
2551 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
2554 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2555 occurrence(C,O2,RuleNb,ID_o2), rule(RuleNb,Rule) \
2556 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
2557 O2 is O+1,
2558 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
2559 |
2560 append(H1,H2,Heads),
2561 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
2562 ( ExtraCond == [chr_pp_void_info] ->
2563 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
2564 ;
2565 append(ExtraCond,Cond,NewCond),
2566 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
2567 copy_term(GuardList,FGuardList),
2568 variable_replacement(GuardList,FGuardList,GLRepl),
2569 copy_with_variable_replacement(GuardList,GuardList2,Repl),
2570 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
2571 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
2572 append(NewCond,GuardList2,BigCond),
2573 append(BigCond,GuardList3,BigCond2),
2574 copy_with_variable_replacement(M,M2,Repl),
2575 copy_with_variable_replacement(M,M3,Repl2),
2576 append(M3,BigCond2,BigCond3),
2577 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
2578 list2conj(CheckCond,OccSubsum),
2579 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
2580 term_variables(NewCond2-FH2,InfoVars),
2581 flatten_stuff(Info2,Info3),
2582 flatten_stuff(OccSubsum2,OccSubsum3),
2583 ( OccSubsum \= chr_pp_void_info,
2584 unify_stuff(InfoVars,Info3,OccSubsum3), !,
2585 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
2586 % ( prolog_flag(verbose,V), V == yes ->
2587 % format(' * Occurrence subsumption detected in ~@\n',[format_rule(Rule)]),
2588 % format(' passive: constraint ~w, occurrence number ~w (id ~w)\n',[C,O2,ID_o2]),
2589 % ;
2590 % true
2591 % ),
2592 passive(RuleNb,ID_o2)
2593 ;
2594 true
2595 )
2596 ; true
2597 ),!,
2598 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
2599 ).
2602 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
2603 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2604 multiple_occ_constraints_checked(Done) <=> true.
2606 flatten_stuff([A|B],C) :- !,
2607 flatten_stuff(A,C1),
2608 flatten_stuff(B,C2),
2609 append(C1,C2,C).
2610 flatten_stuff((A;B),C) :- !,
2611 flatten_stuff(A,C1),
2612 flatten_stuff(B,C2),
2613 append(C1,C2,C).
2614 flatten_stuff((A,B),C) :- !,
2615 flatten_stuff(A,C1),
2616 flatten_stuff(B,C2),
2617 append(C1,C2,C).
2619 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
2620 flatten_stuff(X,[]).
2622 unify_stuff(AllInfo,[],[]).
2624 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
2625 H \== I,
2626 term_variables(H,HVars),
2627 term_variables(I,IVars),
2628 intersect_eq(HVars,IVars,SharedVars),
2629 check_safe_unif(H,I,SharedVars),
2630 variable_replacement(H,I,Repl),
2631 check_replacement(Repl),
2632 term_variables(Repl,ReplVars),
2633 list_difference_eq(ReplVars,HVars,LDiff),
2634 intersect_eq(AllInfo,LDiff,LDiff2),
2635 LDiff2 == [],
2636 H = I,
2637 unify_stuff(AllInfo,RInfo,ROS),!.
2639 unify_stuff(AllInfo,X,[Y|ROS]) :-
2640 unify_stuff(AllInfo,X,ROS).
2642 unify_stuff(AllInfo,[Y|RInfo],X) :-
2643 unify_stuff(AllInfo,RInfo,X).
2645 check_safe_unif(H,I,SV) :- var(H), !, var(I),
2646 ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
2647 H == I
2648 ;
2649 true
2650 ).
2652 check_safe_unif([],[],SV) :- !.
2653 check_safe_unif([H|Hs],[I|Is],SV) :- !,
2654 check_safe_unif(H,I,SV),!,
2655 check_safe_unif(Hs,Is,SV).
2657 check_safe_unif(H,I,SV) :-
2658 nonvar(H),!,nonvar(I),
2659 H =.. [F|HA],
2660 I =.. [F|IA],
2661 check_safe_unif(HA,IA,SV).
2663 check_safe_unif2(H,I) :- var(H), !.
2665 check_safe_unif2([],[]) :- !.
2666 check_safe_unif2([H|Hs],[I|Is]) :- !,
2667 check_safe_unif2(H,I),!,
2668 check_safe_unif2(Hs,Is).
2670 check_safe_unif2(H,I) :-
2671 nonvar(H),!,nonvar(I),
2672 H =.. [F|HA],
2673 I =.. [F|IA],
2674 check_safe_unif2(HA,IA).
2677 check_replacement(Repl) :-
2678 check_replacement(Repl,FirstVars),
2679 sort(FirstVars,Sorted),
2680 length(Sorted,L),!,
2681 length(FirstVars,L).
2683 check_replacement([],[]).
2684 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
2687 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
2688 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
2689 append(ID2,ID1,IDs),
2690 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
2691 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
2692 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
2693 copy_with_variable_replacement(G,FG,Repl),
2694 extract_explicit_matchings(FG,FG2),
2695 negate_b(FG2,NotFG),
2696 copy_with_variable_replacement(MPCond,FMPCond,Repl),
2697 ( check_safe_unif2(FH,FH2), FH=FH2 ->
2698 FailCond = [(NotFG;FMPCond)]
2699 ;
2700 % in this case, not much can be done
2701 % e.g. c(f(...)), c(g(...)) <=> ...
2702 FailCond = [chr_pp_void_info]
2703 ).
2707 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
2708 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
2709 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
2710 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
2711 Cond = (chr_pp_not_in_store(H);Cond1),
2712 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
2715 extract_explicit_matchings(A=B) :-
2716 var(A), var(B), !, A=B.
2717 extract_explicit_matchings(A==B) :-
2718 var(A), var(B), !, A=B.
2720 extract_explicit_matchings((A,B),D) :- !,
2721 ( extract_explicit_matchings(A) ->
2722 extract_explicit_matchings(B,D)
2723 ;
2724 D = (A,E),
2725 extract_explicit_matchings(B,E)
2726 ).
2727 extract_explicit_matchings(A,D) :- !,
2728 ( extract_explicit_matchings(A) ->
2729 D = true
2730 ;
2731 D = A
2732 ).
2737 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2738 % TYPE INFORMATION
2739 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2741 :- chr_constraint
2742 type_definition/2,
2743 constraint_type/2,
2744 get_type_definition/2,
2745 get_constraint_type/2,
2746 add_type_information/3.
2749 :- chr_option(mode,type_definition(?,?)).
2750 :- chr_option(mode,constraint_type(+,+)).
2751 :- chr_option(mode,add_type_information(+,+,?)).
2752 :- chr_option(type_declaration,add_type_information(list,list,any)).
2754 type_definition(T,D) \ get_type_definition(T2,Def) <=>
2755 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A) |
2756 copy_term((T,D),(T1,D1)),T1=T2,Def = D1.
2757 get_type_definition(_,_) <=> fail.
2758 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
2759 get_constraint_type(_,_) <=> fail.
2761 add_type_information([],[],T) <=> T=true.
2763 constraint_mode(F/A,Modes)
2764 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
2765 functor(Head,F,A) |
2766 Head =.. [_|Args],
2767 RealHead =.. [_|RealArgs],
2768 add_mode_info(Modes,Args,ModeInfo),
2769 TypeInfo = (ModeInfo, TI),
2770 (get_constraint_type(F/A,Types) ->
2771 types2condition(Types,Args,RealArgs,Modes,TI2),
2772 list2conj(TI2,ConjTI),
2773 TI = (ConjTI,RTI),
2774 add_type_information(R,RRH,RTI)
2775 ;
2776 add_type_information(R,RRH,TI)
2777 ).
2780 add_type_information([Head|R],_,TypeInfo) <=>
2781 functor(Head,F,A),
2782 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
2785 add_mode_info([],[],true).
2786 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
2787 MI = (ground(A), ModeInfo),
2788 add_mode_info(Modes,Args,ModeInfo).
2789 add_mode_info([M|Modes],[A|Args],MI) :-
2790 add_mode_info(Modes,Args,MI).
2793 types2condition([],[],[],[],[]).
2794 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
2795 (get_type_definition(Type,Def) ->
2796 type2condition(Def,Arg,RealArg,TC),
2797 (Mode \== (+) ->
2798 TC_ = [(\+ ground(Arg))|TC]
2799 ;
2800 TC_ = TC
2801 ),
2802 list2disj(TC_,DisjTC),
2803 TI = [DisjTC|RTI],
2804 types2condition(Types,Args,RAs,Modes,RTI)
2805 ;
2806 ( builtin_type(Type,Arg,C) ->
2807 TI = [C|RTI],
2808 types2condition(Types,Args,RAs,Modes,RTI)
2809 ;
2810 chr_error(internal,'Undefined type ~w.\n',[Type])
2811 )
2812 ).
2814 type2condition([],Arg,_,[]).
2815 type2condition([Def|Defs],Arg,RealArg,TC) :-
2816 ( builtin_type(Def,Arg,C) ->
2817 true
2818 ;
2819 real_type(Def,Arg,RealArg,C)
2820 ),
2821 item2list(C,LC),
2822 type2condition(Defs,Arg,RealArg,RTC),
2823 append(LC,RTC,TC).
2825 item2list([],[]) :- !.
2826 item2list([X|Y],[X|Y]) :- !.
2827 item2list(N,L) :- L = [N].
2829 builtin_type(X,Arg,true) :- var(X),!.
2830 builtin_type(any,Arg,true).
2831 builtin_type(int,Arg,integer(Arg)).
2832 builtin_type(number,Arg,number(Arg)).
2833 builtin_type(float,Arg,float(Arg)).
2834 builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
2836 real_type(Def,Arg,RealArg,C) :-
2837 ( nonvar(Def) ->
2838 functor(Def,F,A),
2839 ( A == 0 ->
2840 C = (Arg = F)
2841 ;
2842 Def =.. [_|TArgs],
2843 length(AA,A),
2844 Def2 =.. [F|AA],
2845 ( var(RealArg) ->
2846 C = functor(Arg,F,A)
2847 ;
2848 ( functor(RealArg,F,A) ->
2849 RealArg =.. [_|RAArgs],
2850 nested_types(TArgs,AA,RAArgs,ACond),
2851 C = (functor(Arg,F,A),Arg=Def2,ACond)
2852 ;
2853 C = functor(Arg,F,A)
2854 )
2855 )
2856 )
2857 ;
2858 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
2859 ).
2860 nested_types([],[],[],true).
2861 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
2862 (get_type_definition(T,Def) ->
2863 type2condition(Def,A,RealA,TC),
2864 list2disj(TC,DisjTC),
2865 C = (DisjTC, RC),
2866 nested_types(RT,RA,RRA,RC)
2867 ;
2868 ( builtin_type(T,A,Cond) ->
2869 C = (Cond, RC),
2870 nested_types(RT,RA,RRA,RC)
2871 ;
2872 chr_error(internal,'Undefined type ~w inside type definition.\n',[T])
2873 )
2874 ).
2877 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2879 :- chr_constraint
2880 stored/3, % constraint,occurrence,(yes/no/maybe)
2881 stored_completing/3,
2882 stored_complete/3,
2883 is_stored/1,
2884 is_finally_stored/1,
2885 check_all_passive/2.
2887 :- chr_option(mode,stored(+,+,+)).
2888 :- chr_option(type_declaration,stored(any,int,storedinfo)).
2889 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
2890 :- chr_option(mode,stored_complete(+,+,+)).
2891 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
2892 :- chr_option(mode,guard_list(+,+,+,+)).
2893 :- chr_option(mode,check_all_passive(+,+)).
2895 % change yes in maybe when yes becomes passive
2896 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID) \
2897 stored(C,O,yes), stored_complete(C,RO,Yesses)
2898 <=> O < RO | NYesses is Yesses - 1,
2899 stored(C,O,maybe), stored_complete(C,RO,NYesses).
2900 % change yes in maybe when not observed
2901 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
2902 <=> O < RO |
2903 NYesses is Yesses - 1,
2904 stored(C,O,maybe), stored_complete(C,RO,NYesses).
2906 occurrence(_,_,RuleNb,ID), occurrence(C2,_,RuleNb,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
2907 ==> RO =< MO2 | % C2 is never stored
2908 passive(RuleNb,ID).
2913 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2915 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
2916 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
2917 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
2919 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
2920 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
2921 check_all_passive(RuleNb,IDs2).
2923 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
2924 check_all_passive(RuleNb,IDs).
2926 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
2927 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
2929 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2931 % collect the storage information
2932 stored(C,O,yes) \ stored_completing(C,O,Yesses)
2933 <=> NO is O + 1, NYesses is Yesses + 1,
2934 stored_completing(C,NO,NYesses).
2935 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
2936 <=> NO is O + 1,
2937 stored_completing(C,NO,Yesses).
2939 stored(C,O,no) \ stored_completing(C,O,Yesses)
2940 <=> stored_complete(C,O,Yesses).
2941 stored_completing(C,O,Yesses)
2942 <=> stored_complete(C,O,Yesses).
2944 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id) ==>
2945 O2 > O | passive(RuleNb,Id).
2947 % decide whether a constraint is stored
2948 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
2949 <=> RO =< MO | fail.
2950 is_stored(C) <=> true.
2952 % decide whether a constraint is suspends after occurrences
2953 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
2954 <=> RO =< MO | fail.
2955 is_finally_stored(C) <=> true.
2957 storage_analysis(Constraints) :-
2958 ( chr_pp_flag(storage_analysis,on) ->
2959 check_constraint_storages(Constraints)
2960 ;
2961 true
2962 ).
2964 check_constraint_storages([]).
2965 check_constraint_storages([C|Cs]) :-
2966 check_constraint_storage(C),
2967 check_constraint_storages(Cs).
2969 check_constraint_storage(C) :-
2970 get_max_occurrence(C,MO),
2971 check_occurrences_storage(C,1,MO).
2973 check_occurrences_storage(C,O,MO) :-
2974 ( O > MO ->
2975 stored_completing(C,1,0)
2976 ;
2977 check_occurrence_storage(C,O),
2978 NO is O + 1,
2979 check_occurrences_storage(C,NO,MO)
2980 ).
2982 check_occurrence_storage(C,O) :-
2983 get_occurrence(C,O,RuleNb,ID),
2984 ( is_passive(RuleNb,ID) ->
2985 stored(C,O,maybe)
2986 ;
2987 get_rule(RuleNb,PragmaRule),
2988 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
2989 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
2990 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
2991 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
2992 check_storage_head2(Head2,O,Heads1,Body)
2993 )
2994 ).
2996 check_storage_head1(Head,O,H1,H2,G) :-
2997 functor(Head,F,A),
2998 C = F/A,
2999 ( H1 == [Head],
3000 H2 == [],
3001 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
3002 Head =.. [_|L],
3003 no_matching(L,[]) ->
3004 stored(C,O,no)
3005 ;
3006 stored(C,O,maybe)
3007 ).
3009 no_matching([],_).
3010 no_matching([X|Xs],Prev) :-
3011 var(X),
3012 \+ memberchk_eq(X,Prev),
3013 no_matching(Xs,[X|Prev]).
3015 check_storage_head2(Head,O,H1,B) :-
3016 functor(Head,F,A),
3017 C = F/A,
3018 ( ( (H1 \== [], B == true ) ;
3019 \+ is_observed(F/A,O) ) ->
3020 stored(C,O,maybe)
3021 ;
3022 stored(C,O,yes)
3023 ).
3025 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3027 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3028 %% ____ _ ____ _ _ _ _
3029 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
3030 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
3031 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
3032 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
3033 %% |_|
3035 constraints_code(Constraints,Clauses) :-
3036 (chr_pp_flag(reduced_indexing,on),
3037 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
3038 none_suspended_on_variables
3039 ;
3040 true
3041 ),
3042 constraints_code1(Constraints,L,[]),
3043 clean_clauses(L,Clauses).
3045 %===============================================================================
3046 :- chr_constraint constraints_code1/3.
3047 :- chr_option(mode,constraints_code1(+,+,+)).
3048 %-------------------------------------------------------------------------------
3049 constraints_code1([],L,T) <=> L = T.
3050 constraints_code1([C|RCs],L,T)
3051 <=>
3052 constraint_code(C,L,T1),
3053 constraints_code1(RCs,T1,T).
3054 %===============================================================================
3055 :- chr_constraint constraint_code/3.
3056 :- chr_option(mode,constraint_code(+,+,+)).
3057 %-------------------------------------------------------------------------------
3058 %% Generate code for a single CHR constraint
3059 constraint_code(Constraint, L, T)
3060 <=> true
3061 | ( (chr_pp_flag(debugable,on) ;
3062 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
3063 ( may_trigger(Constraint) ;
3064 get_allocation_occurrence(Constraint,AO),
3065 get_max_occurrence(Constraint,MO), MO >= AO ) )
3066 ->
3067 constraint_prelude(Constraint,Clause),
3068 L = [Clause | L1]
3069 ;
3070 L = L1
3071 ),
3072 Id = [0],
3073 occurrences_code(Constraint,1,Id,NId,L1,L2),
3074 gen_cond_attach_clause(Constraint,NId,L2,T).
3076 %===============================================================================
3077 %% Generate prelude predicate for a constraint.
3078 %% f(...) :- f/a_0(...,Susp).
3079 constraint_prelude(F/A, Clause) :-
3080 vars_susp(A,Vars,Susp,VarsSusp),
3081 Head =.. [ F | Vars],
3082 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
3083 build_head(F,A,[0],VarsSusp,Delegate),
3084 FTerm =.. [F|Vars],
3085 ( chr_pp_flag(debugable,on) ->
3086 use_auxiliary_predicate(insert_constraint_internal),
3087 generate_insert_constraint_call(F/A,Susp,InsertCall),
3088 make_name('attach_',F/A,AttachF),
3089 AttachCall =.. [AttachF,Vars2,Susp],
3090 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
3091 Clause =
3092 ( Head :-
3093 insert_constraint_internal(Stored,Vars2,Susp,Continuation,FTerm,Vars),
3094 InsertCall,
3095 AttachCall,
3096 Inactive,
3097 (
3098 'chr debug_event'(call(Susp)),
3099 Delegate
3100 ;
3101 'chr debug_event'(fail(Susp)), !,
3102 fail
3103 ),
3104 (
3105 'chr debug_event'(exit(Susp))
3106 ;
3107 'chr debug_event'(redo(Susp)),
3108 fail
3109 )
3110 )
3111 ; get_allocation_occurrence(F/A,0) ->
3112 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
3113 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
3114 Clause = ( Head :- Goal, Inactive, Delegate )
3115 ;
3116 Clause = ( Head :- Delegate )
3117 ).
3119 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
3120 ( may_trigger(F/A) ->
3121 get_target_module(Mod),
3122 build_head(F,A,[0],VarsSusp,Delegate),
3123 Goal = Mod:Delegate
3124 ;
3125 Goal = true
3126 ).
3128 %===============================================================================
3129 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
3130 %-------------------------------------------------------------------------------
3131 has_active_occurrence(C) <=> has_active_occurrence(C,1).
3133 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
3134 O > MO | fail.
3135 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID) \
3136 has_active_occurrence(C,O) <=>
3137 NO is O + 1,
3138 has_active_occurrence(C,NO).
3139 has_active_occurrence(C,O) <=> true.
3140 %===============================================================================
3142 gen_cond_attach_clause(F/A,Id,L,T) :-
3143 ( is_finally_stored(F/A) ->
3144 get_allocation_occurrence(F/A,AllocationOccurrence),
3145 get_max_occurrence(F/A,MaxOccurrence),
3146 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
3147 ( only_ground_indexed_arguments(F/A) ->
3148 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
3149 ;
3150 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
3151 )
3152 ; vars_susp(A,Args,Susp,AllArgs),
3153 gen_uncond_attach_goal(F/A,Susp,Body,_)
3154 ),
3155 ( chr_pp_flag(debugable,on) ->
3156 Constraint =.. [F|Args],
3157 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
3158 ;
3159 DebugEvent = true
3160 ),
3161 build_head(F,A,Id,AllArgs,Head),
3162 Clause = ( Head :- DebugEvent,Body ),
3163 L = [Clause | T]
3164 ;
3165 L = T
3166 ).
3168 :- chr_constraint
3169 use_auxiliary_predicate/1,
3170 is_used_auxiliary_predicate/1.
3172 :- chr_option(mode,use_auxiliary_predicate(+)).
3174 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
3176 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
3178 is_used_auxiliary_predicate(P) <=> fail.
3180 % only called for constraints with
3181 % at least one
3182 % non-ground indexed argument
3183 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
3184 vars_susp(A,Args,Susp,AllArgs),
3185 make_suspension_continuation_goal(F/A,AllArgs,Closure),
3186 make_name('attach_',F/A,AttachF),
3187 Attach =.. [AttachF,Vars,Susp],
3188 FTerm =.. [F|Args],
3189 generate_insert_constraint_call(F/A,Susp,InsertCall),
3190 use_auxiliary_predicate(insert_constraint_internal),
3191 use_auxiliary_predicate(activate_constraint),
3192 ( may_trigger(F/A) ->
3193 Goal =
3194 (
3195 ( var(Susp) ->
3196 insert_constraint_internal(Stored,Vars,Susp,Closure,FTerm,Args)
3197 ;
3198 activate_constraint(Stored,Vars,Susp,_)
3199 ),
3200 ( Stored == yes ->
3201 InsertCall,
3202 Attach
3203 ;
3204 true
3205 )
3206 )
3207 ;
3208 Goal =
3209 (
3210 insert_constraint_internal(Stored,Vars,Susp,Closure,FTerm,Args),
3211 InsertCall,
3212 Attach
3213 )
3214 ).
3216 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
3217 vars_susp(A,Args,Susp,AllArgs),
3218 make_suspension_continuation_goal(F/A,AllArgs,Cont),
3219 ( \+ only_ground_indexed_arguments(F/A) ->
3220 make_name('attach_',F/A,AttachF),
3221 Attach =.. [AttachF,Vars,Susp]
3222 ;
3223 Attach = true
3224 ),
3225 FTerm =.. [F|Args],
3226 generate_insert_constraint_call(F/A,Susp,InsertCall),
3227 use_auxiliary_predicate(insert_constraint_internal),
3228 ( are_none_suspended_on_variables ->
3229 Goal =
3230 (
3231 insert_constraint_internal(Susp,FTerm,Args),
3232 InsertCall
3233 )
3234 ;
3235 Goal =
3236 (
3237 insert_constraint_internal(_,Vars,Susp,Cont,FTerm,Args),
3238 InsertCall,
3239 Attach
3240 )
3241 ).
3243 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
3244 ( \+ only_ground_indexed_arguments(FA) ->
3245 make_name('attach_',FA,AttachF),
3246 Attach =.. [AttachF,Vars,Susp]
3247 ;
3248 Attach = true
3249 ),
3250 generate_insert_constraint_call(FA,Susp,InsertCall),
3251 ( chr_pp_flag(late_allocation,on) ->
3252 use_auxiliary_predicate(activate_constraint),
3253 AttachGoal =
3254 (
3255 activate_constraint(Stored,Vars, Susp, Generation),
3256 ( Stored == yes ->
3257 InsertCall,
3258 Attach
3259 ;
3260 true
3261 )
3262 )
3263 ;
3264 use_auxiliary_predicate(activate_constraint),
3265 AttachGoal =
3266 (
3267 activate_constraint(Stored,Vars, Susp, Generation)
3268 )
3269 ).
3271 %-------------------------------------------------------------------------------
3272 :- chr_constraint occurrences_code/6.
3273 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
3274 %-------------------------------------------------------------------------------
3275 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
3276 <=> O > MO
3277 | NId = Id, L = T.
3278 occurrences_code(C,O,Id,NId,L,T)
3279 <=>
3280 occurrence_code(C,O,Id,Id1,L,L1),
3281 NO is O + 1,
3282 occurrences_code(C,NO,Id1,NId,L1,T).
3283 %-------------------------------------------------------------------------------
3284 :- chr_constraint occurrence_code/6.
3285 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
3286 %-------------------------------------------------------------------------------
3287 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
3288 <=> NId = Id, L = T.
3289 occurrence(C,O,RuleNb,ID), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
3290 <=> true |
3291 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
3292 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
3293 NId = Id,
3294 head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
3295 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
3296 head2_code(Head2,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
3297 inc_id(Id,NId),
3298 ( unconditional_occurrence(C,O) ->
3299 L1 = T
3300 ;
3301 gen_alloc_inc_clause(C,O,Id,L1,T)
3302 )
3303 ).
3305 occurrence_code(C,O,_,_,_,_)
3306 <=>
3307 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
3308 %-------------------------------------------------------------------------------
3310 %% Generate code based on one removed head of a CHR rule
3311 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3312 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3313 Rule = rule(_,Head2,_,_),
3314 ( Head2 == [] ->
3315 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3316 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
3317 ;
3318 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
3319 ).
3321 %% Generate code based on one persistent head of a CHR rule
3322 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3323 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3324 Rule = rule(Head1,_,_,_),
3325 ( Head1 == [] ->
3326 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3327 propagation_code(Head,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
3328 ;
3329 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
3330 ).
3332 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
3333 vars_susp(A,Vars,Susp,VarsSusp),
3334 build_head(F,A,Id,VarsSusp,Head),
3335 inc_id(Id,IncId),
3336 build_head(F,A,IncId,VarsSusp,CallHead),
3337 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConditionalAlloc),
3338 Clause =
3339 (
3340 Head :-
3341 ConditionalAlloc,
3342 CallHead
3343 ),
3344 L = [Clause|T].
3346 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
3347 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
3348 ConstraintAllocationGoal =
3349 ( var(Susp) ->
3350 UncondConstraintAllocationGoal
3351 ;
3352 true
3353 ).
3354 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
3355 ( may_trigger(F/A) ->
3356 build_head(F,A,[0],VarsSusp,Term),
3357 get_target_module(Mod),
3358 Cont = Mod : Term
3359 ;
3360 Cont = true
3361 ),
3362 FTerm =.. [F|Vars],
3363 use_auxiliary_predicate(allocate_constraint),
3364 ConstraintAllocationGoal = allocate_constraint(Cont, Susp, FTerm, Vars).
3366 gen_occ_allocation(FA,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal) :-
3367 get_allocation_occurrence(FA,AO),
3368 ( chr_pp_flag(debugable,off), O == AO ->
3369 ( may_trigger(FA) ->
3370 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3371 ;
3372 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3373 )
3374 ;
3375 ConstraintAllocationGoal = true
3376 ).
3377 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3380 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3382 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
3383 ( chr_pp_flag(guard_via_reschedule,on) ->
3384 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
3385 ;
3386 append(Retrievals,GuardList,GoalList),
3387 list2conj(GoalList,Goal)
3388 ).
3390 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
3391 initialize_unit_dictionary(Prelude,Dict),
3392 build_units(Retrievals,GuardList,Dict,Units),
3393 dependency_reorder(Units,NUnits),
3394 units2goal(NUnits,Goal).
3396 units2goal([],true).
3397 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
3398 units2goal(Units,Goals).
3400 dependency_reorder(Units,NUnits) :-
3401 dependency_reorder(Units,[],NUnits).
3403 dependency_reorder([],Acc,Result) :-
3404 reverse(Acc,Result).
3406 dependency_reorder([Unit|Units],Acc,Result) :-
3407 Unit = unit(_GID,_Goal,Type,GIDs),
3408 ( Type == fixed ->
3409 NAcc = [Unit|Acc]
3410 ;
3411 dependency_insert(Acc,Unit,GIDs,NAcc)
3412 ),
3413 dependency_reorder(Units,NAcc,Result).
3415 dependency_insert([],Unit,_,[Unit]).
3416 dependency_insert([X|Xs],Unit,GIDs,L) :-
3417 X = unit(GID,_,_,_),
3418 ( memberchk(GID,GIDs) ->
3419 L = [Unit,X|Xs]
3420 ;
3421 L = [X | T],
3422 dependency_insert(Xs,Unit,GIDs,T)
3423 ).
3425 build_units(Retrievals,Guard,InitialDict,Units) :-
3426 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
3427 build_guard_units(Guard,N,Dict,Tail).
3429 build_retrieval_units([],N,N,Dict,Dict,L,L).
3430 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
3431 term_variables(U,Vs),
3432 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3433 L = [unit(N,U,movable,GIDs)|L1],
3434 N1 is N + 1,
3435 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
3437 build_retrieval_units2([],N,N,Dict,Dict,L,L).
3438 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
3439 term_variables(U,Vs),
3440 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3441 L = [unit(N,U,fixed,GIDs)|L1],
3442 N1 is N + 1,
3443 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
3445 initialize_unit_dictionary(Term,Dict) :-
3446 term_variables(Term,Vars),
3447 pair_all_with(Vars,0,Dict).
3449 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
3450 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3451 ( lookup_eq(Dict,V,GID) ->
3452 ( (GID == This ; memberchk(GID,GIDs) ) ->
3453 GIDs1 = GIDs
3454 ;
3455 GIDs1 = [GID|GIDs]
3456 ),
3457 Dict1 = Dict
3458 ;
3459 Dict1 = [V - This|Dict],
3460 GIDs1 = GIDs
3461 ),
3462 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3464 build_guard_units(Guard,N,Dict,Units) :-
3465 ( Guard = [Goal] ->
3466 Units = [unit(N,Goal,fixed,[])]
3467 ; Guard = [Goal|Goals] ->
3468 term_variables(Goal,Vs),
3469 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
3470 Units = [unit(N,Goal,movable,GIDs)|RUnits],
3471 N1 is N + 1,
3472 build_guard_units(Goals,N1,NDict,RUnits)
3473 ).
3475 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
3476 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3477 ( lookup_eq(Dict,V,GID) ->
3478 ( (GID == This ; memberchk(GID,GIDs) ) ->
3479 GIDs1 = GIDs
3480 ;
3481 GIDs1 = [GID|GIDs]
3482 ),
3483 Dict1 = [V - This|Dict]
3484 ;
3485 Dict1 = [V - This|Dict],
3486 GIDs1 = GIDs
3487 ),
3488 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3490 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3492 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3493 %% ____ _ ____ _ _
3494 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
3495 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
3496 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
3497 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
3498 %%
3499 %% _ _ _ ___ __
3500 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
3501 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
3502 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
3503 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
3504 %% |_|
3505 :- chr_constraint
3506 functional_dependency/4,
3507 get_functional_dependency/4.
3509 :- chr_option(mode,functional_dependency(+,+,?,?)).
3511 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_) \ functional_dependency(C,RuleNb,Pattern,Key)
3512 <=>
3513 RuleNb > 1, AO > O
3514 |
3515 functional_dependency(C,1,Pattern,Key).
3517 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
3518 <=>
3519 RuleNb2 >= RuleNb1
3520 |
3521 QPattern = Pattern, QKey = Key.
3522 get_functional_dependency(_,_,_,_)
3523 <=>
3524 fail.
3526 functional_dependency_analysis(Rules) :-
3527 ( chr_pp_flag(functional_dependency_analysis,on) ->
3528 functional_dependency_analysis_main(Rules)
3529 ;
3530 true
3531 ).
3533 functional_dependency_analysis_main([]).
3534 functional_dependency_analysis_main([PRule|PRules]) :-
3535 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
3536 functional_dependency(C,RuleNb,Pattern,Key)
3537 ;
3538 true
3539 ),
3540 functional_dependency_analysis_main(PRules).
3542 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
3543 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
3544 Rule = rule(H1,H2,Guard,_),
3545 ( H1 = [C1],
3546 H2 = [C2] ->
3547 true
3548 ; H1 = [C1,C2],
3549 H2 == [] ->
3550 true
3551 ),
3552 check_unique_constraints(C1,C2,Guard,RuleNb,List),
3553 term_variables(C1,Vs),
3554 \+ (
3555 member(V1,Vs),
3556 lookup_eq(List,V1,V2),
3557 memberchk_eq(V2,Vs)
3558 ),
3559 select_pragma_unique_variables(Vs,List,Key1),
3560 copy_term_nat(C1-Key1,Pattern-Key),
3561 functor(C1,F,A).
3563 select_pragma_unique_variables([],_,[]).
3564 select_pragma_unique_variables([V|Vs],List,L) :-
3565 ( lookup_eq(List,V,_) ->
3566 L = T
3567 ;
3568 L = [V|T]
3569 ),
3570 select_pragma_unique_variables(Vs,List,T).
3572 % depends on functional dependency analysis
3573 % and shape of rule: C1 \ C2 <=> true.
3574 set_semantics_rules(Rules) :-
3575 ( chr_pp_flag(set_semantics_rule,on) ->
3576 set_semantics_rules_main(Rules)
3577 ;
3578 true
3579 ).
3581 set_semantics_rules_main([]).
3582 set_semantics_rules_main([R|Rs]) :-
3583 set_semantics_rule_main(R),
3584 set_semantics_rules_main(Rs).
3586 set_semantics_rule_main(PragmaRule) :-
3587 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
3588 ( Rule = rule([C1],[C2],true,_),
3589 IDs = ids([ID1],[ID2]),
3590 \+ is_passive(RuleNb,ID1),
3591 functor(C1,F,A),
3592 get_functional_dependency(F/A,RuleNb,Pattern,Key),
3593 copy_term_nat(Pattern-Key,C1-Key1),
3594 copy_term_nat(Pattern-Key,C2-Key2),
3595 Key1 == Key2 ->
3596 passive(RuleNb,ID2)
3597 ;
3598 true
3599 ).
3601 check_unique_constraints(C1,C2,G,RuleNb,List) :-
3602 \+ any_passive_head(RuleNb),
3603 variable_replacement(C1-C2,C2-C1,List),
3604 copy_with_variable_replacement(G,OtherG,List),
3605 negate_b(G,NotG),
3606 once(entails_b(NotG,OtherG)).
3608 % checks for rules of the shape ...,C1,C2... (<|=)==> ...
3609 % where C1 and C2 are symmteric constraints
3610 symmetry_analysis(Rules) :-
3611 ( chr_pp_flag(check_unnecessary_active,off) ->
3612 true
3613 ;
3614 symmetry_analysis_main(Rules)
3615 ).
3617 symmetry_analysis_main([]).
3618 symmetry_analysis_main([R|Rs]) :-
3619 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
3620 Rule = rule(H1,H2,_,_),
3621 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
3622 ; H2 == [] ), H1 \== [] ->
3623 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
3624 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
3625 ;
3626 true
3627 ),
3628 symmetry_analysis_main(Rs).
3630 symmetry_analysis_heads([],[],_,_,_,_).
3631 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
3632 ( \+ is_passive(RuleNb,ID),
3633 member2(PreHs,PreIDs,PreH-PreID),
3634 \+ is_passive(RuleNb,PreID),
3635 variable_replacement(PreH,H,List),
3636 copy_with_variable_replacement(Rule,Rule2,List),
3637 identical_rules(Rule,Rule2) ->
3638 passive(RuleNb,ID)
3639 ;
3640 true
3641 ),
3642 symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
3644 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3646 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3647 %% ____ _ _ _ __ _ _ _
3648 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
3649 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
3650 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
3651 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
3652 %% |_|
3654 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
3655 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
3656 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
3657 build_head(F,A,Id,HeadVars,ClauseHead),
3658 get_constraint_mode(F/A,Mode),
3659 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
3661 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
3663 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3664 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
3666 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
3667 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
3669 ( chr_pp_flag(debugable,on) ->
3670 Rule = rule(_,_,Guard,Body),
3671 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
3672 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
3673 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody)),
3674 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
3675 ;
3676 Cut = ActualCut
3677 ),
3678 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
3679 Clause = ( ClauseHead :-
3680 FirstMatching,
3681 RescheduledTest,
3682 Cut,
3683 SuspsDetachments,
3684 SuspDetachment,
3685 BodyCopy
3686 ),
3687 L = [Clause | T].
3689 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
3690 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
3692 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
3693 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
3694 list2conj(GoalList,Goal).
3696 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
3697 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
3698 ( var(Arg) ->
3699 ( lookup_eq(VarDict,Arg,OtherVar) ->
3700 ( Mode = (+) ->
3701 ( memberchk_eq(Arg,GroundVars) ->
3702 GoalList = [Var = OtherVar | RestGoalList],
3703 GroundVars1 = GroundVars
3704 ;
3705 GoalList = [Var == OtherVar | RestGoalList],
3706 GroundVars1 = [Arg|GroundVars]
3707 )
3708 ;
3709 GoalList = [Var == OtherVar | RestGoalList],
3710 GroundVars1 = GroundVars
3711 ),
3712 VarDict1 = VarDict
3713 ; VarDict1 = [Arg-Var | VarDict],
3714 GoalList = RestGoalList,
3715 ( Mode = (+) ->
3716 GroundVars1 = [Arg|GroundVars]
3717 ;
3718 GroundVars1 = GroundVars
3719 )
3720 ),
3721 Pairs = Rest,
3722 RestModes = Modes
3723 ; atomic(Arg) ->
3724 ( Mode = (+) ->
3725 GoalList = [ Var = Arg | RestGoalList]
3726 ;
3727 GoalList = [ Var == Arg | RestGoalList]
3728 ),
3729 VarDict = VarDict1,
3730 GroundVars1 = GroundVars,
3731 Pairs = Rest,
3732 RestModes = Modes
3733 ; Mode == (+), is_ground(GroundVars,Arg) ->
3734 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
3735 GoalList = [ Var = ArgCopy | RestGoalList],
3736 VarDict = VarDict1,
3737 GroundVars1 = GroundVars,
3738 Pairs = Rest,
3739 RestModes = Modes
3740 ; Arg =.. [_|Args],
3741 functor(Arg,Fct,N),
3742 functor(Term,Fct,N),
3743 Term =.. [_|Vars],
3744 ( Mode = (+) ->
3745 GoalList = [ Var = Term | RestGoalList ]
3746 ;
3747 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
3748 ),
3749 pairup(Args,Vars,NewPairs),
3750 append(NewPairs,Rest,Pairs),
3751 replicate(N,Mode,NewModes),
3752 append(NewModes,Modes,RestModes),
3753 VarDict1 = VarDict,
3754 GroundVars1 = GroundVars
3755 ),
3756 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
3758 is_ground(GroundVars,Term) :-
3759 ( ground(Term) ->
3760 true
3761 ; compound(Term) ->
3762 Term =.. [_|Args],
3763 maplist(is_ground(GroundVars),Args)
3764 ;
3765 memberchk_eq(Term,GroundVars)
3766 ).
3768 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
3769 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
3771 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
3772 ( Heads = [_|_] ->
3773 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
3774 ;
3775 GoalList = [],
3776 Susps = [],
3777 VarDict = NVarDict,
3778 GroundVars = NGroundVars
3779 ).
3781 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,AttrDict,GroundVars,GroundVars) :-
3782 instantiate_pattern_goals(AttrDict).
3783 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,[Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict,GroundVars,NGroundVars) :-
3784 functor(H,F,A),
3785 head_info(H,A,Vars,_,_,Pairs),
3786 get_store_type(F/A,StoreType),
3787 ( StoreType == default ->
3788 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
3789 get_max_constraint_index(N),
3790 ( N == 1 ->
3791 VarSusps = Attr
3792 ;
3793 get_constraint_index(F/A,Pos),
3794 make_attr(N,_Mask,SuspsList,Attr),
3795 nth(Pos,SuspsList,VarSusps)
3796 ),
3797 create_get_mutable_ref(active,State,GetMutable),
3798 get_constraint_mode(F/A,Mode),
3799 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
3800 ExistentialLookup = (
3801 ViaGoal,
3802 'chr sbag_member'(Susp,VarSusps),
3803 Susp = Suspension,
3804 GetMutable
3805 )
3806 ;
3807 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,State,ExistentialLookup,Susp,Pairs,NPairs),
3808 get_constraint_mode(F/A,Mode),
3809 filter_mode(NPairs,Pairs,Mode,NMode),
3810 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
3811 NewAttrDict = AttrDict
3812 ),
3813 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
3814 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
3815 Goal =
3816 (
3817 ExistentialLookup,
3818 DiffSuspGoals,
3819 MatchingGoal
3820 ),
3821 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict,GroundVars1,NGroundVars).
3823 filter_mode([],_,_,[]).
3824 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
3825 ( Var == V ->
3826 Modes = [M|MT],
3827 filter_mode(Rest,R,Ms,MT)
3828 ;
3829 filter_mode([Arg-Var|Rest],R,Ms,Modes)
3830 ).
3832 instantiate_pattern_goals([]).
3833 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
3834 get_max_constraint_index(N),
3835 ( N == 1 ->
3836 Goal = true
3837 ;
3838 make_attr(N,Mask,_,Attr),
3839 or_list(Bits,Pattern), !,
3840 Goal = (Mask /\ Pattern =:= Pattern)
3841 ),
3842 instantiate_pattern_goals(Rest).
3845 check_unique_keys([],_).
3846 check_unique_keys([V|Vs],Dict) :-
3847 lookup_eq(Dict,V,_),
3848 check_unique_keys(Vs,Dict).
3850 % Generates tests to ensure the found constraint differs from previously found constraints
3851 % TODO: detect more cases where constraints need be different
3852 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
3853 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
3854 list2conj(DiffSuspGoalList,DiffSuspGoals).
3855 % ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
3856 % list2conj(DiffSuspGoalList,DiffSuspGoals)
3857 % ;
3858 % DiffSuspGoals = true
3859 % ).
3861 different_from_other_susps_(_,[],_,_,[]) :- !.
3862 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
3863 ( functor(Head,F,A), functor(PreHead,F,A),
3864 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
3865 \+ \+ PreHeadCopy = HeadCopy ->
3867 List = [Susp \== PreSusp | Tail]
3868 ;
3869 List = Tail
3870 ),
3871 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
3873 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
3874 functor(Head,F,A),
3875 get_constraint_index(F/A,Pos),
3876 common_variables(Head,PrevHeads,CommonVars),
3877 translate(CommonVars,VarDict,Vars),
3878 or_pattern(Pos,Bit),
3879 ( permutation(Vars,PermutedVars),
3880 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
3881 member(Bit,Positions), !,
3882 NewAttrDict = AttrDict,
3883 Goal = true
3884 ;
3885 Goal = (Goal1, PatternGoal),
3886 gen_get_mod_constraints(Vars,Goal1,Attr),
3887 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
3888 ).
3890 common_variables(T,Ts,Vs) :-
3891 term_variables(T,V1),
3892 term_variables(Ts,V2),
3893 intersect_eq(V1,V2,Vs).
3895 gen_get_mod_constraints(L,Goal,Susps) :-
3896 get_target_module(Mod),
3897 ( L == [] ->
3898 Goal =
3899 ( 'chr default_store'(Global),
3900 get_attr(Global,Mod,TSusps),
3901 TSusps = Susps
3902 )
3903 ;
3904 ( L = [A] ->
3905 VIA = 'chr via_1'(A,V)
3906 ; ( L = [A,B] ->
3907 VIA = 'chr via_2'(A,B,V)
3908 ; VIA = 'chr via'(L,V)
3909 )
3910 ),
3911 Goal =
3912 ( VIA,
3913 get_attr(V,Mod,TSusps),
3914 TSusps = Susps
3915 )
3916 ).
3918 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
3919 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3920 list2conj(GuardCopyList,GuardCopy).
3922 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
3923 Rule = rule(_,_,Guard,Body),
3924 conj2list(Guard,GuardList),
3925 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
3926 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
3928 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
3929 term_variables(RestGuardList,GuardVars),
3930 term_variables(RestGuardListCopyCore,GuardCopyVars),
3931 ( chr_pp_flag(guard_locks,on),
3932 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
3933 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
3934 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
3935 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
3936 ),
3937 LocksUnlocks) ->
3938 once(pairup(Locks,Unlocks,LocksUnlocks))
3939 ;
3940 Locks = [],
3941 Unlocks = []
3942 ),
3943 list2conj(Locks,LockPhase),
3944 list2conj(Unlocks,UnlockPhase),
3945 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
3946 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
3947 my_term_copy(Body,VarDict2,BodyCopy).
3950 split_off_simple_guard([],_,[],[]).
3951 split_off_simple_guard([G|Gs],VarDict,S,C) :-
3952 ( simple_guard(G,VarDict) ->
3953 S = [G|Ss],
3954 split_off_simple_guard(Gs,VarDict,Ss,C)
3955 ;
3956 S = [],
3957 C = [G|Gs]
3958 ).
3960 % simple guard: cheap and benign (does not bind variables)
3961 simple_guard(G,VarDict) :-
3962 binds_b(G,Vars),
3963 \+ (( member(V,Vars),
3964 lookup_eq(VarDict,V,_)
3965 )).
3967 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
3968 ( is_stored(FA) ->
3969 ( (Id == [0];
3970 (get_allocation_occurrence(FA,AO),
3971 get_max_occurrence(FA,MO),
3972 MO < AO )),
3973 only_ground_indexed_arguments(FA), chr_pp_flag(late_allocation,on) ->
3974 SuspDetachment = true
3975 ;
3976 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
3977 ( chr_pp_flag(late_allocation,on) ->
3978 SuspDetachment =
3979 ( var(Susp) ->
3980 true
3981 ; UnCondSuspDetachment
3982 )
3983 ;
3984 SuspDetachment = UnCondSuspDetachment
3985 )
3986 )
3987 ;
3988 SuspDetachment = true
3989 ).
3991 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
3992 ( is_stored(FA) ->
3993 ( \+ only_ground_indexed_arguments(FA) ->
3994 make_name('detach_',FA,Fct),
3995 Detach =.. [Fct,Vars,Susp]
3996 ;
3997 Detach = true
3998 ),
3999 ( chr_pp_flag(debugable,on) ->
4000 DebugEvent = 'chr debug_event'(remove(Susp))
4001 ;
4002 DebugEvent = true
4003 ),
4004 generate_delete_constraint_call(FA,Susp,DeleteCall),
4005 use_auxiliary_predicate(remove_constraint_internal),
4006 ( are_none_suspended_on_variables ->
4007 SuspDetachment =
4008 (
4009 DebugEvent,
4010 remove_constraint_internal(Susp),
4011 DeleteCall,
4012 Detach
4013 )
4014 ;
4015 SuspDetachment =
4016 (
4017 DebugEvent,
4018 remove_constraint_internal(Susp, Vars, Delete),
4019 ( Delete == yes ->
4020 DeleteCall,
4021 Detach
4022 ;
4023 true
4024 )
4025 )
4026 )
4027 ;
4028 SuspDetachment = true
4029 ).
4031 gen_uncond_susps_detachments([],[],true).
4032 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
4033 functor(Term,F,A),
4034 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
4035 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
4037 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4039 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4040 %% ____ _ _ _ _
4041 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
4042 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
4043 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
4044 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
4045 %% |_| |___/
4047 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
4048 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
4049 Rule = rule(_Heads,Heads2,Guard,Body),
4051 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
4052 get_constraint_mode(F/A,Mode),
4053 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
4055 build_head(F,A,Id,HeadVars,ClauseHead),
4057 append(RestHeads,Heads2,Heads),
4058 append(OtherIDs,Heads2IDs,IDs),
4059 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
4060 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
4061 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
4063 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
4064 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
4066 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
4067 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
4069 ( chr_pp_flag(debugable,on) ->
4070 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4071 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
4072 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
4073 instrument_goal((!),DebugTry,DebugApply,Cut)
4074 ;
4075 Cut = (!)
4076 ),
4078 Clause = ( ClauseHead :-
4079 FirstMatching,
4080 RescheduledTest,
4081 Cut,
4082 SuspsDetachments,
4083 SuspDetachment,
4084 BodyCopy
4085 ),
4086 L = [Clause | T].
4088 split_by_ids([],[],_,[],[]).
4089 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
4090 ( memberchk_eq(I,I1s) ->
4091 S1s = [S | R1s],
4092 S2s = R2s
4093 ;
4094 S1s = R1s,
4095 S2s = [S | R2s]
4096 ),
4097 split_by_ids(Is,Ss,I1s,R1s,R2s).
4099 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4102 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4103 %% ____ _ _ _ ____
4104 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
4105 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
4106 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
4107 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
4108 %% |_| |___/
4110 %% Genereate prelude + worker predicate
4111 %% prelude calls worker
4112 %% worker iterates over one type of removed constraints
4113 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
4114 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
4115 Rule = rule(Heads1,_,Guard,Body),
4116 append(Heads1,RestHeads2,Heads),
4117 append(IDs1,RestIDs,IDs),
4118 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
4119 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
4120 extend_id(Id,Id1),
4121 ( memberchk_eq(NID,IDs2) ->
4122 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
4123 ;
4124 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
4125 ),
4126 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
4127 simpagation_head2_new_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
4129 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
4130 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
4131 Heads = [Head|RHeads],
4132 inc_id(Id,Id1),
4133 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
4134 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
4135 ( memberchk_eq(ID,IDs2) ->
4136 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
4137 ;
4138 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
4139 ).
4141 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4142 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
4143 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4144 build_head(F,A,Id1,VarsSusp,ClauseHead),
4145 get_constraint_mode(F/A,Mode),
4146 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
4148 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
4150 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal),
4152 extend_id(Id1,DelegateId),
4153 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
4154 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
4155 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
4157 PreludeClause =
4158 ( ClauseHead :-
4159 FirstMatching,
4160 ModConstraintsGoal,
4161 !,
4162 ConstraintAllocationGoal,
4163 Delegate
4164 ),
4165 L = [PreludeClause|T].
4167 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
4168 Term =.. [_|Args],
4169 delegate_variables(Term,Terms,VarDict,Args,Vars).
4171 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
4172 term_variables(PrevTerms,PrevVars),
4173 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
4175 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
4176 term_variables(Term,V1),
4177 term_variables(Terms,V2),
4178 intersect_eq(V1,V2,V3),
4179 list_difference_eq(V3,PrevVars,V4),
4180 translate(V4,VarDict,Vars).
4183 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4184 simpagation_head2_new_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
4186 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
4187 Rule = rule(_,_,Guard,Body),
4188 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,PreSusps),
4190 gen_var(OtherSusp),
4191 gen_var(OtherSusps),
4193 functor(CurrentHead,OtherF,OtherA),
4194 gen_vars(OtherA,OtherVars),
4195 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
4196 get_constraint_mode(OtherF/OtherA,Mode),
4197 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
4199 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4200 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
4201 create_get_mutable_ref(active,State,GetMutable),
4202 CurrentSuspTest = (
4203 OtherSusp = OtherSuspension,
4204 GetMutable,
4205 DiffSuspGoals,
4206 FirstMatching
4207 ),
4209 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4210 build_head(F,A,Id,ClauseVars,ClauseHead),
4212 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
4213 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
4214 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
4216 gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
4218 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4219 build_head(F,A,Id,RecursiveVars,RecursiveCall),
4220 RecursiveVars2 = [[]|PreVarsAndSusps],
4221 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
4223 guard_body_copies2(Rule,VarDict2,GuardCopyList,BodyCopy),
4224 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,CurrentSuspTest),RescheduledTest),
4225 ( BodyCopy \== true, is_observed(F/A,O) ->
4226 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4227 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
4228 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
4229 ; Attachment = true,
4230 ConditionalRecursiveCall = RecursiveCall,
4231 ConditionalRecursiveCall2 = RecursiveCall2
4232 ),
4234 ( chr_pp_flag(debugable,on) ->
4235 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4236 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
4237 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
4238 ;
4239 DebugTry = true,
4240 DebugApply = true
4241 ),
4243 ( member(unique(ID1,UniqueKeys), Pragmas),
4244 check_unique_keys(UniqueKeys,VarDict) ->
4245 Clause =
4246 ( ClauseHead :-
4247 ( CurrentSuspTest ->
4248 ( RescheduledTest,
4249 DebugTry ->
4250 DebugApply,
4251 Susps1Detachments,
4252 Attachment,
4253 BodyCopy,
4254 ConditionalRecursiveCall2
4255 ;
4256 RecursiveCall2
4257 )
4258 ;
4259 RecursiveCall
4260 )
4261 )
4262 ;
4263 Clause =
4264 ( ClauseHead :-
4265 ( CurrentSuspTest,
4266 RescheduledTest,
4267 DebugTry ->
4268 DebugApply,
4269 Susps1Detachments,
4270 Attachment,
4271 BodyCopy,
4272 ConditionalRecursiveCall
4273 ;
4274 RecursiveCall
4275 )
4276 )
4277 ),
4278 L = [Clause | T].
4280 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
4281 length(Args,N),
4282 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
4283 create_get_mutable_ref(active,State,GetState),
4284 create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
4285 ConditionalCall =
4286 ( Susp = Suspension,
4287 GetState,
4288 GetGeneration ->
4289 'chr update_mutable'(inactive,State),
4290 Call
4291 ; true
4292 ).
4294 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4297 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4298 %% ____ _ _
4299 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
4300 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
4301 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
4302 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
4303 %% |_| |___/
4305 propagation_code(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4306 ( RestHeads == [] ->
4307 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
4308 ;
4309 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
4310 ).
4311 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4312 %% Single headed propagation
4313 %% everything in a single clause
4314 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
4315 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4316 build_head(F,A,Id,VarsSusp,ClauseHead),
4318 inc_id(Id,NextId),
4319 build_head(F,A,NextId,VarsSusp,NextHead),
4321 get_constraint_mode(F/A,Mode),
4322 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict),
4323 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4324 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,Allocation),
4326 % - recursive call -
4327 RecursiveCall = NextHead,
4328 ( BodyCopy \== true, is_observed(F/A,O) ->
4329 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4330 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4331 ; Attachment = true,
4332 ConditionalRecursiveCall = RecursiveCall
4333 ),
4335 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
4336 ActualCut = true
4337 ;
4338 ActualCut = !
4339 ),
4341 ( chr_pp_flag(debugable,on) ->
4342 Rule = rule(_,_,Guard,Body),
4343 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4344 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
4345 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
4346 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4347 ;
4348 Cut = ActualCut
4349 ),
4351 ( may_trigger(F/A) ->
4352 NovelProduction = 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
4353 ExtendHistory = 'chr extend_history'(Susp,RuleNb)
4354 ;
4355 NovelProduction = true,
4356 ExtendHistory = true
4357 ),
4359 Clause = (
4360 ClauseHead :-
4361 HeadMatching,
4362 Allocation,
4363 NovelProduction,
4364 GuardCopy,
4365 Cut,
4366 ExtendHistory,
4367 Attachment,
4368 BodyCopy,
4369 ConditionalRecursiveCall
4370 ),
4371 ProgramList = [Clause | ProgramTail].
4373 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4374 %% multi headed propagation
4375 %% prelude + predicates to accumulate the necessary combinations of suspended
4376 %% constraints + predicate to execute the body
4377 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4378 RestHeads = [First|Rest],
4379 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
4380 extend_id(Id,ExtendedId),
4381 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
4383 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4384 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
4385 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4386 build_head(F,A,Id,VarsSusp,PreludeHead),
4387 get_constraint_mode(F/A,Mode),
4388 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
4389 Rule = rule(_,_,Guard,Body),
4390 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
4392 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
4394 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,CondAllocation),
4396 extend_id(Id,NestedId),
4397 append([Susps|VarsSusp],ExtraVars,NestedVars),
4398 build_head(F,A,NestedId,NestedVars,NestedHead),
4399 NestedCall = NestedHead,
4401 Prelude = (
4402 PreludeHead :-
4403 FirstMatching,
4404 FirstSuspGoal,
4405 !,
4406 CondAllocation,
4407 NestedCall
4408 ),
4409 L = [Prelude|T].
4411 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4412 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4413 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
4414 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
4416 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4417 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
4418 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
4419 inc_id(Id,IncId),
4420 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
4422 check_fd_lookup_condition(_,_,_,_) :- fail.
4423 %check_fd_lookup_condition(F,A,_,_) :-
4424 % get_store_type(F/A,global_singleton), !.
4425 %check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
4426 % get_functional_dependency(F/A,1,P,K),
4427 % copy_term(P-K,CurrentHead-Key),
4428 % term_variables(PreHeads,PreVars),
4429 % intersect_eq(Key,PreVars,Key).
4431 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
4432 Rule = rule(_,_,Guard,Body),
4433 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
4434 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
4435 init(AllSusps,RestSusps),
4436 last(AllSusps,Susp),
4437 gen_var(OtherSusp),
4438 gen_var(OtherSusps),
4439 functor(CurrentHead,OtherF,OtherA),
4440 gen_vars(OtherA,OtherVars),
4441 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4442 create_get_mutable_ref(active,State,GetMutable),
4443 CurrentSuspTest = (
4444 OtherSusp = Suspension,
4445 GetMutable
4446 ),
4447 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4448 build_head(F,A,Id,ClauseVars,ClauseHead),
4449 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
4450 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
4451 RecursiveVars = PreVarsAndSusps1
4452 ;
4453 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4454 PrevId = Id
4455 ),
4456 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
4457 RecursiveCall = RecursiveHead,
4458 CurrentHead =.. [_|OtherArgs],
4459 pairup(OtherArgs,OtherVars,OtherPairs),
4460 get_constraint_mode(OtherF/OtherA,Mode),
4461 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
4463 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
4464 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4466 ( BodyCopy \== true, is_observed(F/A,O) ->
4467 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
4468 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4469 ; Attach = true,
4470 ConditionalRecursiveCall = RecursiveCall
4471 ),
4473 ( is_least_occurrence(RuleNb) ->
4474 NovelProduction = true,
4475 ExtendHistory = true
4476 ;
4477 get_occurrence(F/A,O,_,ID),
4478 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
4479 Tuple =.. [t,RuleNb|HistorySusps],
4480 bagof('chr novel_production'(X,Y),( lists:member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
4481 list2conj(NovelProductionsList,NovelProductions),
4482 NovelProduction = ( TupleVar = Tuple, NovelProductions),
4483 ExtendHistory = 'chr extend_history'(Susp,TupleVar)
4484 ),
4487 ( chr_pp_flag(debugable,on) ->
4488 Rule = rule(_,_,Guard,Body),
4489 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4490 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
4491 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
4492 ;
4493 DebugTry = true,
4494 DebugApply = true
4495 ),
4497 Clause = (
4498 ClauseHead :-
4499 ( CurrentSuspTest,
4500 DiffSuspGoals,
4501 Matching,
4502 NovelProduction,
4503 GuardCopy,
4504 DebugTry ->
4505 DebugApply,
4506 ExtendHistory,
4507 Attach,
4508 BodyCopy,
4509 ConditionalRecursiveCall
4510 ; RecursiveCall
4511 )
4512 ),
4513 L = [Clause|T].
4515 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
4516 reverse(ReversedRestSusps,RestSusps),
4517 pairup([ID|RestIDs],[Susp|RestSusps],IDSusps),
4518 sort(IDSusps,SortedIDSusps),
4519 pairup(_,HistorySusps,SortedIDSusps).
4521 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
4522 !,
4523 functor(Head,F,A),
4524 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
4525 get_constraint_mode(F/A,Mode),
4526 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
4527 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4528 append(VarsSusp,ExtraVars,HeadVars).
4529 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
4530 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
4531 functor(Head,F,A),
4532 gen_var(Susps),
4533 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4534 get_constraint_mode(F/A,Mode),
4535 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4536 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4537 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
4539 % returns
4540 % VarDict for the copies of variables in the original heads
4541 % VarsSuspsList list of lists of arguments for the successive heads
4542 % FirstVarsSusp top level arguments
4543 % SuspList list of all suspensions
4544 % Iterators list of all iterators
4545 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
4546 !,
4547 functor(Head,F,A),
4548 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), % make variables for argument positions
4549 get_constraint_mode(F/A,Mode),
4550 head_arg_matches(HeadPairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
4551 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
4552 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
4553 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
4554 % gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,[SuspList],Iterators),
4555 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators), % needed almost an hour to find this nasty typo/bug
4556 functor(Head,F,A),
4557 gen_var(Susps),
4558 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4559 get_constraint_mode(F/A,Mode),
4560 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4561 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
4562 append(HeadVars,[Susp,Susps],Vars).
4564 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
4565 !,
4566 functor(Head,F,A),
4567 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
4568 get_constraint_mode(F/A,Mode),
4569 head_arg_matches(Pairs,Mode,[],_,VarDict),
4570 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4571 append(VarsSusp,ExtraVars,HeadVars).
4572 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
4573 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
4574 functor(Head,F,A),
4575 gen_var(Susps),
4576 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
4577 get_constraint_mode(F/A,Mode),
4578 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
4579 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4580 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
4582 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4584 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4585 %% ____ _ _ _ _
4586 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
4587 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
4588 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
4589 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
4590 %%
4591 %% ____ _ _ _
4592 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
4593 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
4594 %% | _ < __/ |_| | | | __/\ V / (_| | |
4595 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
4596 %%
4597 %% ____ _ _
4598 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
4599 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
4600 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
4601 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
4602 %% |___/
4604 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4605 ( chr_pp_flag(reorder_heads,on) ->
4606 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
4607 ;
4608 NRestHeads = RestHeads,
4609 NRestIDs = RestIDs
4610 ).
4612 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4613 term_variables(Head,Vars),
4614 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
4615 copy_term_nat(InitialData,InitialDataCopy),
4616 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
4617 InitialDataCopy = InitialData,
4618 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
4619 reverse(RNRestHeads,NRestHeads),
4620 reverse(RNRestIDs,NRestIDs).
4622 final_data(Entry) :-
4623 Entry = entry(_,_,_,_,[],_).
4625 expand_data(Entry,NEntry,Cost) :-
4626 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
4627 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
4628 term_variables([Head1|Vars],Vars1),
4629 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
4630 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
4632 % Assigns score to head based on known variables and heads to lookup
4633 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4634 functor(Head,F,A),
4635 get_store_type(F/A,StoreType),
4636 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
4638 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4639 term_variables(Head,HeadVars),
4640 term_variables(RestHeads,RestVars),
4641 order_score_vars(HeadVars,KnownVars,RestVars,Score).
4642 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4643 order_score_indexes(Indexes,Head,KnownVars,0,Score).
4644 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4645 term_variables(Head,HeadVars),
4646 term_variables(RestHeads,RestVars),
4647 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
4648 Score is Score_ * 2.
4649 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
4650 Score = 1. % guaranteed O(1)
4652 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4653 find_with_var_identity(
4654 S,
4655 t(Head,KnownVars,RestHeads),
4656 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
4657 Scores
4658 ),
4659 min_list(Scores,Score).
4662 order_score_indexes([],_,_,Score,NScore) :-
4663 Score > 0, NScore = 100.
4664 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
4665 multi_hash_key_args(I,Head,Args),
4666 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
4667 Score1 is Score + 1
4668 ;
4669 Score1 = Score
4670 ),
4671 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
4673 order_score_vars(Vars,KnownVars,RestVars,Score) :-
4674 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
4675 ( K-R-O == 0-0-0 ->
4676 Score = 0
4677 ; K > 0 ->
4678 Score is max(10 - K,0)
4679 ; R > 0 ->
4680 Score is max(10 - R,1) * 10
4681 ;
4682 Score is max(10-O,1) * 100
4683 ).
4684 order_score_count_vars([],_,_,0-0-0).
4685 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
4686 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
4687 ( memberchk_eq(V,KnownVars) ->
4688 NK is K + 1,
4689 NR = R, NO = O
4690 ; memberchk_eq(V,RestVars) ->
4691 NR is R + 1,
4692 NK = K, NO = O
4693 ;
4694 NO is O + 1,
4695 NK = K, NR = R
4696 ).
4698 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4699 %% ___ _ _ _
4700 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
4701 %% | || '_ \| | | '_ \| | '_ \ / _` |
4702 %% | || | | | | | | | | | | | | (_| |
4703 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
4704 %% |___/
4706 %% SWI begin
4707 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
4708 %% SWI end
4710 %% SICStus begin
4711 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
4712 %% SICStus end
4714 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4716 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4717 %% _ _ _ _ _ _ _
4718 %% | | | | |_(_) (_) |_ _ _
4719 %% | | | | __| | | | __| | | |
4720 %% | |_| | |_| | | | |_| |_| |
4721 %% \___/ \__|_|_|_|\__|\__, |
4722 %% |___/
4724 gen_var(_).
4725 gen_vars(N,Xs) :-
4726 length(Xs,N).
4728 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
4729 vars_susp(A,Vars,Susp,VarsSusp),
4730 Head =.. [_|Args],
4731 pairup(Args,Vars,HeadPairs).
4733 inc_id([N|Ns],[O|Ns]) :-
4734 O is N + 1.
4735 dec_id([N|Ns],[M|Ns]) :-
4736 M is N - 1.
4738 extend_id(Id,[0|Id]).
4740 next_id([_,N|Ns],[O|Ns]) :-
4741 O is N + 1.
4743 build_head(F,A,Id,Args,Head) :-
4744 buildName(F,A,Id,Name),
4745 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
4746 ( may_trigger(F/A) ;
4747 get_allocation_occurrence(F/A,AO),
4748 get_max_occurrence(F/A,MO),
4749 MO >= AO ) ) ->
4750 Head =.. [Name|Args]
4751 ;
4752 init(Args,ArgsWOSusp), % XXX not entirely correct!
4753 Head =.. [Name|ArgsWOSusp]
4754 ).
4756 buildName(Fct,Aty,List,Result) :-
4757 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
4758 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
4759 MO >= AO ) ; List \= [0])) ) ) ->
4760 atom_concat(Fct, (/) ,FctSlash),
4761 atomic_concat(FctSlash,Aty,FctSlashAty),
4762 buildName_(List,FctSlashAty,Result)
4763 ;
4764 Result = Fct
4765 ).
4767 buildName_([],Name,Name).
4768 buildName_([N|Ns],Name,Result) :-
4769 buildName_(Ns,Name,Name1),
4770 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
4771 atomic_concat(NameDash,N,Result).
4773 vars_susp(A,Vars,Susp,VarsSusp) :-
4774 length(Vars,A),
4775 append(Vars,[Susp],VarsSusp).
4777 make_attr(N,Mask,SuspsList,Attr) :-
4778 length(SuspsList,N),
4779 Attr =.. [v,Mask|SuspsList].
4781 or_pattern(Pos,Pat) :-
4782 Pow is Pos - 1,
4783 Pat is 1 << Pow. % was 2 ** X
4785 and_pattern(Pos,Pat) :-
4786 X is Pos - 1,
4787 Y is 1 << X, % was 2 ** X
4788 Pat is (-1)*(Y + 1).
4790 make_name(Prefix,F/A,Name) :-
4791 atom_concat_list([Prefix,F,(/),A],Name).
4793 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4794 % Storetype dependent lookup
4795 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
4796 functor(Head,F,A),
4797 get_store_type(F/A,StoreType),
4798 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
4800 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
4801 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
4802 instantiate_pattern_goals(AttrDict),
4803 get_max_constraint_index(N),
4804 ( N == 1 ->
4805 AllSusps = Attr
4806 ;
4807 functor(Head,F,A),
4808 get_constraint_index(F/A,Pos),
4809 make_attr(N,_,SuspsList,Attr),
4810 nth(Pos,SuspsList,AllSusps)
4811 ).
4812 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
4813 once((
4814 member(Index,Indexes),
4815 multi_hash_key_args(Index,Head,KeyArgs),
4816 translate(KeyArgs,VarDict,KeyArgCopies)
4817 )),
4818 ( KeyArgCopies = [KeyCopy] ->
4819 true
4820 ;
4821 KeyCopy =.. [k|KeyArgCopies]
4822 ),
4823 functor(Head,F,A),
4824 multi_hash_via_lookup_name(F/A,Index,ViaName),
4825 Goal =.. [ViaName,KeyCopy,AllSusps],
4826 update_store_type(F/A,multi_hash([Index])).
4827 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
4828 functor(Head,F,A),
4829 global_ground_store_name(F/A,StoreName),
4830 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
4831 update_store_type(F/A,global_ground).
4832 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
4833 functor(Head,F,A),
4834 global_singleton_store_name(F/A,StoreName),
4835 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4836 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
4837 update_store_type(F/A,global_singleton).
4838 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
4839 once((
4840 member(ST,StoreTypes),
4841 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
4842 )).
4844 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :- !,
4845 functor(Head,F,A),
4846 global_singleton_store_name(F/A,StoreName),
4847 make_get_store_goal(StoreName,Susp,GetStoreGoal),
4848 Goal = (
4849 GetStoreGoal, % nb_getval(StoreName,Susp),
4850 Susp \== [],
4851 Susp = SuspTerm
4852 ),
4853 update_store_type(F/A,global_singleton).
4854 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
4855 once((
4856 member(ST,StoreTypes),
4857 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs)
4858 )).
4859 existential_lookup(multi_hash(Indexes),Head,_PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
4860 once((
4861 member(Index,Indexes),
4862 multi_hash_key_args(Index,Head,KeyArgs),
4863 translate(KeyArgs,VarDict,KeyArgCopies)
4864 )),
4865 ( KeyArgCopies = [KeyCopy] ->
4866 true
4867 ;
4868 KeyCopy =.. [k|KeyArgCopies]
4869 ),
4870 functor(Head,F,A),
4871 multi_hash_via_lookup_name(F/A,Index,ViaName),
4872 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
4873 create_get_mutable_ref(active,State,GetMutable),
4874 Goal = (
4875 LookupGoal,
4876 'chr sbag_member'(Susp,AllSusps),
4877 Susp = SuspTerm,
4878 GetMutable
4879 ),
4880 hash_index_filter(Pairs,Index,NPairs),
4881 update_store_type(F/A,multi_hash([Index])).
4882 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :-
4883 lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),
4884 create_get_mutable_ref(active,State,GetMutable),
4885 Goal = (
4886 UGoal,
4887 'chr sbag_member'(Susp,Susps),
4888 Susp = SuspTerm,
4889 GetMutable
4890 ).
4892 hash_index_filter(Pairs,Index,NPairs) :-
4893 ( integer(Index) ->
4894 NIndex = [Index]
4895 ;
4896 NIndex = Index
4897 ),
4898 hash_index_filter(Pairs,NIndex,1,NPairs).
4900 hash_index_filter([],_,_,[]).
4901 hash_index_filter([P|Ps],Index,N,NPairs) :-
4902 ( Index = [I|Is] ->
4903 NN is N + 1,
4904 ( I > N ->
4905 NPairs = [P|NPs],
4906 hash_index_filter(Ps,[I|Is],NN,NPs)
4907 ; I == N ->
4908 NPairs = NPs,
4909 hash_index_filter(Ps,Is,NN,NPs)
4910 )
4911 ;
4912 NPairs = [P|Ps]
4913 ).
4915 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4916 assume_constraint_stores([]).
4917 assume_constraint_stores([C|Cs]) :-
4918 ( only_ground_indexed_arguments(C),
4919 is_stored(C),
4920 get_store_type(C,default) ->
4921 get_indexed_arguments(C,IndexedArgs),
4922 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
4923 predsort(longer_list,UnsortedIndexes,Indexes),
4924 ( get_functional_dependency(C,1,Pattern,Key),
4925 all_distinct_var_args(Pattern), Key == [] ->
4926 assumed_store_type(C,global_singleton)
4927 ;
4928 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
4929 )
4930 ;
4931 true
4932 ),
4933 assume_constraint_stores(Cs).
4935 longer_list(R,L1,L2) :-
4936 length(L1,N1),
4937 length(L2,N2),
4938 compare(Rt,N2,N1),
4939 ( Rt == (=) ->
4940 compare(R,L1,L2)
4941 ;
4942 R = Rt
4943 ).
4945 all_distinct_var_args(Term) :-
4946 Term =.. [_|Args],
4947 copy_term_nat(Args,NArgs),
4948 all_distinct_var_args_(NArgs).
4950 all_distinct_var_args_([]).
4951 all_distinct_var_args_([X|Xs]) :-
4952 var(X),
4953 X = t,
4954 all_distinct_var_args_(Xs).
4956 get_indexed_arguments(C,IndexedArgs) :-
4957 C = F/A,
4958 get_indexed_arguments(1,A,C,IndexedArgs).
4960 get_indexed_arguments(I,N,C,L) :-
4961 ( I > N ->
4962 L = []
4963 ; ( is_indexed_argument(C,I) ->
4964 L = [I|T]
4965 ;
4966 L = T
4967 ),
4968 J is I + 1,
4969 get_indexed_arguments(J,N,C,T)
4970 ).
4972 validate_store_type_assumptions([]).
4973 validate_store_type_assumptions([C|Cs]) :-
4974 validate_store_type_assumption(C),
4975 validate_store_type_assumptions(Cs).
4977 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4978 % new code generation
4979 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
4980 Rule = rule(H1,_,Guard,Body),
4981 ( H1 == [],
4982 functor(CurrentHead,CF,CA),
4983 check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
4984 L = T
4985 ;
4986 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
4987 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
4988 flatten(VarsAndSuspsList,VarsAndSusps),
4989 Vars = [ [] | VarsAndSusps],
4990 build_head(F,A,Id,Vars,Head),
4991 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
4992 Clause = ( Head :- PredecessorCall),
4993 L = [Clause | T]
4994 ).
4996 % skips back intelligently over global_singleton lookups
4997 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
4998 ( Id = [0|_] ->
4999 next_id(Id,PrevId),
5000 PrevVarsAndSusps = BaseCallArgs
5001 ;
5002 VarsAndSuspsList = [_|AllButFirstList],
5003 dec_id(Id,PrevId1),
5004 ( PrevHeads = [PrevHead|PrevHeads1],
5005 functor(PrevHead,F,A),
5006 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
5007 PrevIterators = [_|PrevIterators1],
5008 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
5009 ;
5010 PrevId = PrevId1,
5011 flatten(AllButFirstList,AllButFirst),
5012 PrevIterators = [PrevIterator|_],
5013 PrevVarsAndSusps = [PrevIterator|AllButFirst]
5014 )
5015 ).
5017 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
5018 Rule = rule(_,_,Guard,Body),
5019 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
5020 init(AllSusps,PreSusps),
5021 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
5022 gen_var(OtherSusps),
5023 functor(CurrentHead,OtherF,OtherA),
5024 gen_vars(OtherA,OtherVars),
5025 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
5026 get_constraint_mode(OtherF/OtherA,Mode),
5027 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
5029 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
5031 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
5032 create_get_mutable_ref(active,State,GetMutable),
5033 CurrentSuspTest = (
5034 OtherSusp = OtherSuspension,
5035 GetMutable,
5036 DiffSuspGoals,
5037 FirstMatching
5038 ),
5039 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
5040 inc_id(Id,NestedId),
5041 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5042 build_head(F,A,Id,ClauseVars,ClauseHead),
5043 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
5044 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
5045 build_head(F,A,NestedId,NestedVars,NestedHead),
5047 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
5048 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
5049 RecursiveVars = PreVarsAndSusps1
5050 ;
5051 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5052 PrevId = Id
5053 ),
5054 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
5056 Clause = (
5057 ClauseHead :-
5058 ( CurrentSuspTest,
5059 NextSuspGoal
5060 ->
5061 NestedHead
5062 ; RecursiveHead
5063 )
5064 ),
5065 L = [Clause|T].
5067 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5070 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5071 % Observation Analysis
5072 %
5073 % CLASSIFICATION
5074 % Enabled
5075 %
5076 % Analysis based on Abstract Interpretation paper.
5077 %
5078 % TODO:
5079 % stronger analysis domain [research]
5081 :- chr_constraint
5082 initial_call_pattern/1,
5083 call_pattern/1,
5084 final_answer_pattern/2,
5085 abstract_constraints/1,
5086 depends_on/2,
5087 depends_on_ap/4,
5088 depends_on_goal/2,
5089 ai_observed/2,
5090 ai_not_observed/2,
5091 ai_is_observed/2,
5092 depends_on_as/3.
5094 :- chr_option(mode,initial_call_pattern(+)).
5095 :- chr_option(mode,call_pattern(+)).
5096 :- chr_option(mode,final_answer_pattern(+,+)).
5097 :- chr_option(mode,abstract_constraints(+)).
5098 :- chr_option(mode,depends_on(+,+)).
5099 :- chr_option(mode,depends_on_as(+,+,+)).
5100 :- chr_option(mode,depends_on_ap(+,+,+,+)).
5101 :- chr_option(mode,depends_on_goal(+,+)).
5102 :- chr_option(mode,ai_observed(+,+)).
5103 :- chr_option(mode,ai_is_observed(+,+)).
5104 :- chr_option(mode,ai_not_observed(+,+)).
5106 ai_observed(C,O) \ ai_not_observed(C,O) <=> true.
5107 ai_not_observed(C,O) \ ai_not_observed(C,O) <=> true.
5108 ai_observed(C,O) \ ai_observed(C,O) <=> true.
5110 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
5111 ai_is_observed(_,_) <=> true.
5113 ai_observation_analysis(ACs) :-
5114 ( chr_pp_flag(ai_observation_analysis,on) ->
5115 list_to_ord_set(ACs,ACSet),
5116 abstract_constraints(ACs),
5117 ai_observation_schedule_initial_calls(ACs)
5118 ;
5119 true
5120 ).
5122 ai_observation_schedule_initial_calls([]).
5123 ai_observation_schedule_initial_calls([AC|ACs]) :-
5124 ai_observation_schedule_initial_call(AC),
5125 ai_observation_schedule_initial_calls(ACs).
5127 ai_observation_schedule_initial_call(AC) :-
5128 ai_observation_top(AC,CallPattern),
5129 initial_call_pattern(CallPattern).
5131 ai_observation_schedule_new_calls([],AP).
5132 ai_observation_schedule_new_calls([AC|ACs],AP) :-
5133 AP = odom(_,Set),
5134 initial_call_pattern(odom(AC,Set)),
5135 ai_observation_schedule_new_calls(ACs,AP).
5137 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
5138 <=>
5139 ai_observation_leq(AP2,AP1)
5140 |
5141 true.
5143 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
5145 initial_call_pattern(CP) ==> call_pattern(CP).
5147 initial_call_pattern(CP), final_answer_pattern(CP,AP),
5148 abstract_constraints(ACs) ==>
5149 ai_observation_schedule_new_calls(ACs,AP).
5151 call_pattern(CP) \ call_pattern(CP) <=> true.
5153 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
5154 final_answer_pattern(CP1,AP).
5156 % AbstractGoala
5157 call_pattern(odom([],Set)) ==>
5158 final_answer_pattern(odom([],Set),odom([],Set)).
5160 % AbstractGoalb
5161 call_pattern(odom([G|Gs],Set)) ==>
5162 CP1 = odom(G,Set),
5163 depends_on_goal(odom([G|Gs],Set),CP1),
5164 call_pattern(CP1).
5166 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_)
5167 <=> true.
5168 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
5169 ==>
5170 CP1 = odom([_|Gs],_),
5171 AP2 = odom([],Set),
5172 CCP = odom(Gs,Set),
5173 call_pattern(CCP),
5174 depends_on(CP1,CCP).
5176 % AbstractSolve
5177 call_pattern(odom(builtin,Set)) ==>
5178 % writeln(' - AbstractSolve'),
5179 ord_empty(EmptySet),
5180 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
5182 % AbstractDrop
5183 call_pattern(odom(occ(C,O),Set)), max_occurrence(C,MO) ==>
5184 O > MO |
5185 % writeln(' - AbstractDrop'),
5186 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)).
5188 % AbstractActivate
5189 call_pattern(odom(AC,Set)), abstract_constraints(ACs)
5190 ==>
5191 memberchk_eq(AC,ACs)
5192 |
5193 % writeln(' - AbstractActivate'),
5194 CP = odom(occ(AC,1),Set),
5195 call_pattern(CP),
5196 depends_on(odom(AC,Set),CP).
5198 % AbstractSimplify
5199 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
5200 Rule = pragma(rule(H1,H2,G,Body),ids(IDs1,_),_,_,_),
5201 memberchk_eq(ID,IDs1) |
5202 % writeln(' - AbstractSimplify'),
5203 % SIMPLIFICATION
5204 select2(ID,_,IDs1,H1,_,RestH1),
5205 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
5206 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
5207 ai_observation_abstract_constraints(H2,ACs,AH2),
5208 ai_observation_observe_list(odom([],Set1),AH2,odom([],Set2)),
5209 ai_observation_abstract_goal(Body,ACs,AG),
5210 call_pattern(odom(AG,Set2)),
5211 % DEFAULT
5212 NO is O + 1,
5213 DCP = odom(occ(C,NO),Set),
5214 call_pattern(DCP),
5215 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP).
5217 depends_on_as(CP,CPS,CPD),
5218 final_answer_pattern(CPS,APS),
5219 final_answer_pattern(CPD,APD) ==>
5220 ai_observation_lub(APS,APD,AP),
5221 final_answer_pattern(CP,AP).
5223 % AbstractPropagate
5224 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
5225 Rule = pragma(rule(H1,H2,G,Body),ids(_,IDs2),_,_,_),
5226 memberchk_eq(ID,IDs2)
5227 |
5228 % writeln(' - AbstractPropagate'),
5229 % observe partners
5230 select2(ID,_,IDs2,H2,_,RestH2),
5231 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
5232 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
5233 ai_observation_abstract_constraints(H1,ACs,AH1),
5234 ai_observation_observe_list(odom([],Set1),AH1,odom([],Set2)),
5235 ord_add_element(Set2,C,Set3),
5236 ai_observation_abstract_goal(Body,ACs,AG),
5237 call_pattern(odom(AG,Set3)),
5238 ( ord_memberchk(C,Set2) ->
5239 Delete = no
5240 ;
5241 Delete = yes
5242 ),
5243 % DEFAULT
5244 NO is O + 1,
5245 DCP = odom(occ(C,NO),Set),
5246 call_pattern(DCP),
5247 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete).
5250 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
5251 true |
5252 final_answer_pattern(CP,APD).
5253 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
5254 final_answer_pattern(CPD,APD) ==>
5255 true |
5256 CP = odom(occ(C,O),_),
5257 ( ai_observation_is_observed(APP,C) ->
5258 ai_observed(C,O)
5259 ;
5260 ai_not_observed(C,O)
5261 ),
5262 ( Delete == yes ->
5263 APP = odom([],Set0),
5264 ord_del_element(Set0,C,Set),
5265 NAPP = odom([],Set)
5266 ;
5267 NAPP = APP
5268 ),
5269 ai_observation_lub(NAPP,APD,AP),
5270 final_answer_pattern(CP,AP).
5272 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
5273 ord_intersect(S1,S2,S3).
5275 ai_observation_top(AG,odom(AG,EmptyS)) :-
5276 ord_empty(EmptyS).
5278 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
5279 ord_subset(S2,S1).
5281 ai_observation_observe_list(odom(AG,S),ACs,odom(AG,NS)) :-
5282 list_to_ord_set(ACs,ACSet),
5283 ord_subtract(S,ACSet,NS).
5285 ai_observation_abstract_constraint(C,ACs,AC) :-
5286 functor(C,F,A),
5287 AC = F / A,
5288 member(AC,ACs).
5290 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
5291 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
5293 ai_observation_abstract_goal(G,ACs,AG) :-
5294 ai_observation_abstract_goal(G,ACs,AG,[]).
5296 ai_observation_abstract_goal((G1,G2),ACs,List,Tail) :- !, % conjunction
5297 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5298 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5299 ai_observation_abstract_goal((G1;G2),ACs,List,Tail) :- !, % disjunction
5300 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5301 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5302 ai_observation_abstract_goal((G1->G2),ACs,List,Tail) :- !, % if-then
5303 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5304 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5305 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail) :-
5306 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
5307 ai_observation_abstract_goal(true,_,Tail,Tail) :- !.
5308 ai_observation_abstract_goal(writeln(_),_,Tail,Tail) :- !.
5309 ai_observation_abstract_goal(G,_,[AG|Tail],Tail) :-
5310 AG = builtin. % default case if goal is not recognized
5312 ai_observation_is_observed(odom(_,ACSet),AC) :-
5313 \+ ord_memberchk(AC,ACSet).
5315 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5316 unconditional_occurrence(C,O) :-
5317 get_occurrence(C,O,RuleNb,ID),
5318 get_rule(RuleNb,PRule),
5319 PRule = pragma(ORule,_,_,_,_),
5320 copy_term_nat(ORule,Rule),
5321 Rule = rule(H1,H2,Guard,_),
5322 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
5323 once((
5324 H1 = [Head], H2 == []
5325 ;
5326 H2 = [Head], H1 == [], \+ may_trigger(C)
5327 )),
5328 functor(Head,F,A),
5329 Head =.. [_|Args],
5330 unconditional_occurrence_args(Args).
5332 unconditional_occurrence_args([]).
5333 unconditional_occurrence_args([X|Xs]) :-
5334 var(X),
5335 X = x,
5336 unconditional_occurrence_args(Xs).
5338 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5339 % Generate rules that implement chr_show_store/1 functionality.
5340 %
5341 % CLASSIFICATION
5342 % Experimental
5343 % Unused
5344 %
5345 % Generates additional rules:
5346 %
5347 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
5348 % ...
5349 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
5350 % $show <=> true.
5352 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
5353 ( chr_pp_flag(show,on) ->
5354 Constraints = ['$show'/0|Constraints0],
5355 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
5356 inc_rule_count(RuleNb),
5357 Rule = pragma(
5358 rule(['$show'],[],true,true),
5359 ids([0],[]),
5360 [],
5361 no,
5362 RuleNb
5363 )
5364 ;
5365 Constraints = Constraints0,
5366 Rules = Rules0
5367 ).
5369 generate_show_rules([],Rules,Rules).
5370 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
5371 functor(C,F,A),
5372 inc_rule_count(RuleNb),
5373 Rule = pragma(
5374 rule([],['$show',C],true,writeln(C)),
5375 ids([],[0,1]),
5376 [passive(1)],
5377 no,
5378 RuleNb
5379 ),
5380 generate_show_rules(Rest,Tail,Rules).