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