| blob | c0d1c15b129929b80f4e2b88aec89358a9a3d701 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.ac.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.ac.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 %% * fine-tune automatic selection of constraint stores
54 %%
55 %% To Do
56 %%
57 %% * further specialize runtime predicates for special cases where
58 %% - none of the constraints contain any indexing variables, ...
59 %% - just one constraint requires some runtime predicate
60 %% * analysis for attachment delaying (see primes for case)
61 %% * internal constraints declaration + analyses?
62 %% * Do not store in global variable store if not necessary
63 %% NOTE: affects show_store/1
64 %% * multi-level store: variable - ground
65 %% * Do not maintain/check unnecessary propagation history
66 %% for rules that cannot be applied more than once
67 %% e.g. due to groundness
68 %% * Strengthen attachment analysis:
69 %% reason about bodies of rules only containing constraints
70 %%
71 %% * SICStus compatibility
72 %% - rules/1 declaration
73 %% - options
74 %% - pragmas
75 %% - tell guard
76 %% * instantiation declarations
77 %% POTENTIAL GAIN:
78 %% GROUND
79 %% - cheaper matching code?
80 %% VARIABLE (never bound)
81 %%
82 %% * make difference between cheap guards for reordering
83 %% and non-binding guards for lock removal
84 %% * unqiue -> once/[] transformation for propagation
85 %% * cheap guards interleaved with head retrieval + faster
86 %% via-retrieval + non-empty checking for propagation rules
87 %% redo for simpagation_head2 prelude
88 %% * intelligent backtracking for simplification/simpagation rule
89 %% generator_1(X),'_$savecp'(CP_1),
90 %% ...
91 %% if( (
92 %% generator_n(Y),
93 %% test(X,Y)
94 %% ),
95 %% true,
96 %% ('_$cutto'(CP_1), fail)
97 %% ),
98 %% ...
99 %%
100 %% or recently developped cascading-supported approach
101 %%
102 %% * intelligent backtracking for propagation rule
103 %% use additional boolean argument for each possible smart backtracking
104 %% when boolean at end of list true -> no smart backtracking
105 %% false -> smart backtracking
106 %% only works for rules with at least 3 constraints in the head
107 %%
108 %% * mutually exclusive rules
109 %% * (set semantics + functional dependency) declaration + resolution
110 %%
111 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
112 :- module(chr_translate,
113 [ chr_translate/2 % +Decls, -TranslatedDecls
114 ]).
115 :- use_module(library(lists)).
116 :- use_module(hprolog).
117 :- use_module(library(assoc)).
118 :- use_module(pairlist).
119 :- use_module(library(ordsets)).
120 :- use_module(a_star).
121 :- use_module(clean_code).
122 :- use_module(builtins).
123 :- use_module(find).
124 :- include(chr_op2).
126 option(debug,off).
127 option(optimize,full).
129 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
130 :- constraints
132 constraint/2, % constraint(F/A,ConstraintIndex)
133 get_constraint/2,
135 constraint_count/1, % constraint_count(MaxConstraintIndex)
136 get_constraint_count/1,
138 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
139 get_constraint_index/2,
141 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
142 get_max_constraint_index/1,
144 target_module/1, % target_module(Module)
145 get_target_module/1,
147 attached/2, % attached(F/A,yes/no/maybe)
148 is_attached/1,
150 indexed_argument/2, % argument instantiation may enable applicability of rule
151 is_indexed_argument/2,
153 constraint_mode/2,
154 get_constraint_mode/2,
156 may_trigger/1,
158 has_nonground_indexed_argument/3,
160 store_type/2,
161 get_store_type/2,
162 update_store_type/2,
163 actual_store_types/2,
164 assumed_store_type/2,
165 validate_store_type_assumption/1,
167 rule_count/1,
168 inc_rule_count/1,
169 get_rule_count/1,
171 passive/2,
172 is_passive/2,
173 any_passive_head/1,
175 pragma_unique/3,
176 get_pragma_unique/3,
178 occurrence/4,
179 get_occurrence/4,
181 max_occurrence/2,
182 get_max_occurrence/2,
184 allocation_occurrence/2,
185 get_allocation_occurrence/2,
186 rule/2,
187 get_rule/2
188 .
190 option(mode,constraint(+,+)).
191 option(mode,constraint_count(+)).
192 option(mode,constraint_index(+,+)).
193 option(mode,max_constraint_index(+)).
194 option(mode,target_module(+)).
195 option(mode,attached(+,+)).
196 option(mode,indexed_argument(+,+)).
197 option(mode,constraint_mode(+,+)).
198 option(mode,may_trigger(+)).
199 option(mode,store_type(+,+)).
200 option(mode,actual_store_types(+,+)).
201 option(mode,assumed_store_type(+,+)).
202 option(mode,rule_count(+)).
203 option(mode,passive(+,+)).
204 option(mode,pragma_unique(+,+,?)).
205 option(mode,occurrence(+,+,+,+)).
206 option(mode,max_occurrence(+,+)).
207 option(mode,allocation_occurrence(+,+)).
208 option(mode,rule(+,+)).
210 constraint(FA,Index) \ get_constraint(Query,Index)
211 <=> Query = FA.
212 get_constraint(_,_)
213 <=> fail.
215 constraint_count(Index) \ get_constraint_count(Query)
216 <=> Query = Index.
217 get_constraint_count(Query)
218 <=> Query = 0.
220 target_module(Mod) \ get_target_module(Query)
221 <=> Query = Mod .
222 get_target_module(Query)
223 <=> Query = user.
225 constraint_index(C,Index) \ get_constraint_index(C,Query)
226 <=> Query = Index.
227 get_constraint_index(_,_)
228 <=> fail.
230 max_constraint_index(Index) \ get_max_constraint_index(Query)
231 <=> Query = Index.
232 get_max_constraint_index(Query)
233 <=> Query = 0.
235 attached(Constr,yes) \ attached(Constr,_) <=> true.
236 attached(Constr,no) \ attached(Constr,_) <=> true.
237 attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
239 attached(Constr,Type) \ is_attached(Constr)
240 <=> Type \== no.
241 is_attached(_) <=> true.
243 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
244 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
245 is_indexed_argument(_,_) <=> fail.
247 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Query)
248 <=> Query = Mode.
249 get_constraint_mode(FA,Query)
250 <=> FA = _/A, length(Query,A), set_elems(Query,?).
252 may_trigger(FA) <=>
253 is_attached(FA),
254 get_constraint_mode(FA,Mode),
255 has_nonground_indexed_argument(FA,1,Mode).
257 has_nonground_indexed_argument(FA,I,[Mode|Modes])
258 <=>
259 true
260 |
261 ( is_indexed_argument(FA,I),
262 Mode \== (+) ->
263 true
264 ;
265 J is I + 1,
266 has_nonground_indexed_argument(FA,J,Modes)
267 ).
268 has_nonground_indexed_argument(_,_,_)
269 <=> fail.
271 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
272 store_type(FA,Store) \ get_store_type(FA,Query)
273 <=> Query = Store.
274 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
275 <=> Query = Store.
276 get_store_type(_,Query)
277 <=> Query = default.
279 actual_store_types(C,STs) \ update_store_type(C,ST)
280 <=> member(ST,STs) | true.
281 update_store_type(C,ST), actual_store_types(C,STs)
282 <=>
283 actual_store_types(C,[ST|STs]).
284 update_store_type(C,ST)
285 <=>
286 actual_store_types(C,[ST]).
288 % refine store type assumption
289 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
290 <=>
291 store_type(C,multi_store(STs)).
292 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
293 <=>
294 store_type(C,multi_store(STs)).
295 validate_store_type_assumption(_)
296 <=> true.
298 rule_count(C), inc_rule_count(NC)
299 <=> NC is C + 1, rule_count(NC).
300 inc_rule_count(NC)
301 <=> NC = 1, rule_count(NC).
303 rule_count(C) \ get_rule_count(Q)
304 <=> Q = C.
305 get_rule_count(Q)
306 <=> Q = 0.
308 passive(RuleNb,ID) \ is_passive(RuleNb,ID)
309 <=> true.
310 is_passive(_,_)
311 <=> fail.
312 passive(RuleNb,_) \ any_passive_head(RuleNb)
313 <=> true.
314 any_passive_head(_)
315 <=> fail.
317 pragma_unique(RuleNb,ID,Vars) \ get_pragma_unique(RuleNb,ID,Query)
318 <=> Query = Vars.
319 get_pragma_unique(_,_,_)
320 <=> true.
322 occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
323 <=> Rule = QRule, ID = QID.
324 get_occurrence(_,_,_,_)
325 <=> fail.
327 occurrence(C,ON,_,_) ==> max_occurrence(C,ON).
328 max_occurrence(C,N) \ max_occurrence(C,M)
329 <=> N >= M | true.
330 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
331 <=> Q = MON.
332 get_max_occurrence(_,Q)
333 <=> Q = 0.
335 % need not store constraint that is removed
336 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
337 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs)
338 | NO is O + 1, allocation_occurrence(C,NO).
339 % need not store constraint when body is true
340 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
341 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
342 | NO is O + 1, allocation_occurrence(C,NO).
343 % cannot store constraint at passive occurrence
344 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
345 <=> NO is O + 1, allocation_occurrence(C,NO).
346 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
347 <=> Q = O.
348 get_allocation_occurrence(_,_)
349 <=> fail.
351 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
352 <=> Q = Rule.
353 get_rule(_,_)
354 <=> fail.
357 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
360 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
361 %%
362 %% Translation
364 chr_translate(Declarations,NewDeclarations) :-
365 init_chr_pp_flags,
366 partition_clauses(Declarations,Constraints,Rules,OtherClauses),
367 ( Constraints == [] ->
368 insert_declarations(OtherClauses, NewDeclarations)
369 ;
370 % start analysis
371 add_rules(Rules),
372 check_rules(Rules,Constraints),
373 add_occurrences(Rules),
374 late_allocation(Constraints),
375 unique_analyse_optimise(Rules,NRules),
376 check_attachments(Constraints),
377 assume_constraint_stores(Constraints),
378 set_constraint_indices(Constraints,1),
379 % end analysis
380 constraints_code(Constraints,NRules,ConstraintClauses),
381 validate_store_type_assumptions(Constraints),
382 store_management_preds(Constraints,StoreClauses), % depends on actual code used
383 insert_declarations(OtherClauses, Clauses0),
384 chr_module_declaration(CHRModuleDeclaration),
385 append_lists([Clauses0,
386 StoreClauses,
387 ConstraintClauses,
388 CHRModuleDeclaration
389 ],
390 NewDeclarations)
391 ).
393 store_management_preds(Constraints,Clauses) :-
394 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
395 generate_indexed_variables_clauses(Constraints,IndexedClauses),
396 generate_attach_increment(AttachIncrementClauses),
397 generate_attr_unify_hook(AttrUnifyHookClauses),
398 generate_extra_clauses(Constraints,ExtraClauses),
399 generate_insert_delete_constraints(Constraints,DeleteClauses),
400 generate_store_code(Constraints,StoreClauses),
401 append_lists([AttachAConstraintClauses
402 ,IndexedClauses
403 ,AttachIncrementClauses
404 ,AttrUnifyHookClauses
405 ,ExtraClauses
406 ,DeleteClauses
407 ,StoreClauses]
408 ,Clauses).
410 insert_declarations(Clauses0, Clauses) :-
411 ( Clauses0 = [:- module(M,E)|FileBody]
412 -> Clauses = [ :- module(M,E),
413 :- use_module('chr_runtime'),
414 :- use_module('chr_hashtable_store'),
415 :- style_check(-singleton),
416 :- style_check(-discontiguous)
417 | FileBody
418 ]
419 ; Clauses = [ :- use_module('chr_runtime'),
420 :- use_module('chr_hashtable_store'),
421 :- style_check(-singleton),
422 :- style_check(-discontiguous)
423 | Clauses0
424 ]
425 ).
428 chr_module_declaration(CHRModuleDeclaration) :-
429 get_target_module(Mod),
430 ( Mod \== chr_translate ->
431 CHRModuleDeclaration = [
432 (:- multifile chr:'$chr_module'/1),
433 chr:'$chr_module'(Mod)
434 ]
435 ;
436 CHRModuleDeclaration = []
437 ).
440 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
441 %%
442 %% Partitioning of clauses into constraint declarations, chr rules and other
443 %% clauses
445 partition_clauses([],[],[],[]).
446 partition_clauses([C|Cs],Ds,Rs,OCs) :-
447 ( parse_rule(C,R) ->
448 Ds = RDs,
449 Rs = [R | RRs],
450 OCs = ROCs
451 ; is_declaration(C,D) ->
452 append(D,RDs,Ds),
453 Rs = RRs,
454 OCs = ROCs
455 ; is_module_declaration(C,Mod) ->
456 target_module(Mod),
457 Ds = RDs,
458 Rs = RRs,
459 OCs = [C|ROCs]
460 ; C = (handler _) ->
461 format('CHR compiler WARNING: ~w.\n',[C]),
462 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
463 Ds = RDs,
464 Rs = RRs,
465 OCs = ROCs
466 ; C = (rules _) ->
467 format('CHR compiler WARNING: ~w.\n',[C]),
468 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
469 Ds = RDs,
470 Rs = RRs,
471 OCs = ROCs
472 ; C = option(OptionName,OptionValue) ->
473 handle_option(OptionName,OptionValue),
474 Ds = RDs,
475 Rs = RRs,
476 OCs = ROCs
477 ; Ds = RDs,
478 Rs = RRs,
479 OCs = [C|ROCs]
480 ),
481 partition_clauses(Cs,RDs,RRs,ROCs).
483 is_declaration(D, Constraints) :- %% constraint declaration
484 ( D = (:- Decl) ->
485 true
486 ;
487 D = Decl
488 ),
489 Decl =.. [constraints,Cs],
490 conj2list(Cs,Constraints).
492 %% Data Declaration
493 %%
494 %% pragma_rule
495 %% -> pragma(
496 %% rule,
497 %% ids,
498 %% list(pragma),
499 %% yesno(string), :: maybe rule nane
500 %% int :: rule number
501 %% )
502 %%
503 %% ids -> ids(
504 %% list(int),
505 %% list(int)
506 %% )
507 %%
508 %% rule -> rule(
509 %% list(constraint), :: constraints to be removed
510 %% list(constraint), :: surviving constraints
511 %% goal, :: guard
512 %% goal :: body
513 %% )
515 parse_rule(RI,R) :- %% name @ rule
516 RI = (Name @ RI2), !,
517 rule(RI2,yes(Name),R).
518 parse_rule(RI,R) :-
519 rule(RI,no,R).
521 rule(RI,Name,R) :-
522 RI = (RI2 pragma P), !, %% pragmas
523 is_rule(RI2,R1,IDs),
524 conj2list(P,Ps),
525 inc_rule_count(RuleCount),
526 R = pragma(R1,IDs,Ps,Name,RuleCount).
527 rule(RI,Name,R) :-
528 is_rule(RI,R1,IDs),
529 inc_rule_count(RuleCount),
530 R = pragma(R1,IDs,[],Name,RuleCount).
532 is_rule(RI,R,IDs) :- %% propagation rule
533 RI = (H ==> B), !,
534 conj2list(H,Head2i),
535 get_ids(Head2i,IDs2,Head2),
536 IDs = ids([],IDs2),
537 ( B = (G | RB) ->
538 R = rule([],Head2,G,RB)
539 ;
540 R = rule([],Head2,true,B)
541 ).
542 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
543 RI = (H <=> B), !,
544 ( B = (G | RB) ->
545 Guard = G,
546 Body = RB
547 ; Guard = true,
548 Body = B
549 ),
550 ( H = (H1 \ H2) ->
551 conj2list(H1,Head2i),
552 conj2list(H2,Head1i),
553 get_ids(Head2i,IDs2,Head2,0,N),
554 get_ids(Head1i,IDs1,Head1,N,_),
555 IDs = ids(IDs1,IDs2)
556 ; conj2list(H,Head1i),
557 Head2 = [],
558 get_ids(Head1i,IDs1,Head1),
559 IDs = ids(IDs1,[])
560 ),
561 R = rule(Head1,Head2,Guard,Body).
563 get_ids(Cs,IDs,NCs) :-
564 get_ids(Cs,IDs,NCs,0,_).
566 get_ids([],[],[],N,N).
567 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
568 ( C = (NC # N) ->
569 true
570 ;
571 NC = C
572 ),
573 M is N + 1,
574 get_ids(Cs,IDs,NCs, M,NN).
576 is_module_declaration((:- module(Mod)),Mod).
577 is_module_declaration((:- module(Mod,_)),Mod).
579 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
581 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
582 % Add rules
583 add_rules([]).
584 add_rules([Rule|Rules]) :-
585 Rule = pragma(_,_,_,_,RuleNb),
586 rule(RuleNb,Rule),
587 add_rules(Rules).
589 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
591 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
592 %% Some input verification:
593 %% - all constraints in heads are declared constraints
594 %% - all passive pragmas refer to actual head constraints
596 check_rules([],_).
597 check_rules([PragmaRule|Rest],Decls) :-
598 check_rule(PragmaRule,Decls),
599 check_rules(Rest,Decls).
601 check_rule(PragmaRule,Decls) :-
602 check_rule_indexing(PragmaRule),
603 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
604 Rule = rule(H1,H2,_,_),
605 append(H1,H2,HeadConstraints),
606 check_head_constraints(HeadConstraints,Decls,PragmaRule),
607 check_pragmas(Pragmas,PragmaRule).
609 check_head_constraints([],_,_).
610 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
611 functor(Constr,F,A),
612 ( member(F/A,Decls) ->
613 check_head_constraints(Rest,Decls,PragmaRule)
614 ;
615 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
616 [F/A,format_rule(PragmaRule)]),
617 format(' `--> Constraint should be one of ~w.\n',[Decls]),
618 fail
619 ).
621 check_pragmas([],_).
622 check_pragmas([Pragma|Pragmas],PragmaRule) :-
623 check_pragma(Pragma,PragmaRule),
624 check_pragmas(Pragmas,PragmaRule).
626 check_pragma(Pragma,PragmaRule) :-
627 var(Pragma), !,
628 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
629 [Pragma,format_rule(PragmaRule)]),
630 format(' `--> Pragma should not be a variable!\n',[]),
631 fail.
632 check_pragma(passive(ID), PragmaRule) :-
633 !,
634 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
635 ( memberchk_eq(ID,IDs1) ->
636 true
637 ; memberchk_eq(ID,IDs2) ->
638 true
639 ;
640 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
641 [ID,format_rule(PragmaRule)]),
642 fail
643 ),
644 passive(RuleNb,ID).
646 check_pragma(Pragma, PragmaRule) :-
647 Pragma = unique(ID,Vars),
648 !,
649 PragmaRule = pragma(_,_,_,_,RuleNb),
650 pragma_unique(RuleNb,ID,Vars),
651 format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
652 format(' `--> Only use this pragma if you know what you are doing.\n',[]).
654 check_pragma(Pragma, PragmaRule) :-
655 Pragma = already_in_heads,
656 !,
657 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
658 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
660 check_pragma(Pragma, PragmaRule) :-
661 Pragma = already_in_head(_),
662 !,
663 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
664 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
666 check_pragma(Pragma,PragmaRule) :-
667 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
668 format(' `--> Pragma should be one of passive/1!\n',[]),
669 fail.
671 format_rule(PragmaRule) :-
672 PragmaRule = pragma(_,_,_,MaybeName,N),
673 ( MaybeName = yes(Name) ->
674 write('rule '), write(Name)
675 ;
676 write('rule number '), write(N)
677 ).
679 check_rule_indexing(PragmaRule) :-
680 PragmaRule = pragma(Rule,_,_,_,_),
681 Rule = rule(H1,H2,G,_),
682 term_variables(H1-H2,HeadVars),
683 remove_anti_monotonic_guards(G,HeadVars,NG),
684 check_indexing(H1,NG-H2),
685 check_indexing(H2,NG-H1).
687 remove_anti_monotonic_guards(G,Vars,NG) :-
688 conj2list(G,GL),
689 remove_anti_monotonic_guard_list(GL,Vars,NGL),
690 list2conj(NGL,NG).
692 remove_anti_monotonic_guard_list([],_,[]).
693 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
694 ( G = var(X),
695 memberchk_eq(X,Vars) ->
696 NGs = RGs
697 ;
698 NGs = [G|RGs]
699 ),
700 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
702 check_indexing([],_).
703 check_indexing([Head|Heads],Other) :-
704 functor(Head,F,A),
705 Head =.. [_|Args],
706 term_variables(Heads-Other,OtherVars),
707 check_indexing(Args,1,F/A,OtherVars),
708 check_indexing(Heads,[Head|Other]).
710 check_indexing([],_,_,_).
711 check_indexing([Arg|Args],I,FA,OtherVars) :-
712 ( is_indexed_argument(FA,I) ->
713 true
714 ; nonvar(Arg) ->
715 indexed_argument(FA,I)
716 ; % var(Arg) ->
717 term_variables(Args,ArgsVars),
718 append(ArgsVars,OtherVars,RestVars),
719 ( memberchk_eq(Arg,RestVars) ->
720 indexed_argument(FA,I)
721 ;
722 true
723 )
724 ),
725 J is I + 1,
726 term_variables(Arg,NVars),
727 append(NVars,OtherVars,NOtherVars),
728 check_indexing(Args,J,FA,NOtherVars).
730 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
732 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
733 % Occurrences
735 add_occurrences([]).
736 add_occurrences([Rule|Rules]) :-
737 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
738 add_occurrences(H1,IDs1,Nb),
739 add_occurrences(H2,IDs2,Nb),
740 add_occurrences(Rules).
742 add_occurrences([],[],_).
743 add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
744 functor(H,F,A),
745 FA = F/A,
746 get_max_occurrence(FA,MO),
747 O is MO + 1,
748 occurrence(FA,O,RuleNb,ID),
749 add_occurrences(Hs,IDs,RuleNb).
751 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
753 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
754 % Late allocation
756 late_allocation([]).
757 late_allocation([C|Cs]) :-
758 allocation_occurrence(C,1),
759 late_allocation(Cs).
760 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
762 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
763 % Global Options
764 %
766 handle_option(Var,Value) :-
767 var(Var), !,
768 format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
769 format(' `--> First argument should be an atom, not a variable.\n',[]),
770 fail.
772 handle_option(Name,Value) :-
773 var(Value), !,
774 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
775 format(' `--> Second argument should be a nonvariable.\n',[]),
776 fail.
778 handle_option(Name,Value) :-
779 option_definition(Name,Value,Flags),
780 !,
781 set_chr_pp_flags(Flags).
783 handle_option(Name,Value) :-
784 \+ option_definition(Name,_,_), !,
785 % setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
786 format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
787 format(' `--> Invalid option name \n',[]). %~w: should be one of ~w.\n',[Name,Ns]).
789 handle_option(Name,Value) :-
790 findall(V,option_definition(Name,V,_),Vs),
791 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
792 format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
793 fail.
795 option_definition(optimize,experimental,Flags) :-
796 Flags = [ unique_analyse_optimise - on,
797 check_unnecessary_active - full,
798 reorder_heads - on,
799 set_semantics_rule - on,
800 check_attachments - on,
801 guard_via_reschedule - on
802 ].
803 option_definition(optimize,full,Flags) :-
804 Flags = [ unique_analyse_optimise - on,
805 check_unnecessary_active - full,
806 reorder_heads - on,
807 set_semantics_rule - on,
808 check_attachments - on,
809 guard_via_reschedule - on
810 ].
812 option_definition(optimize,sicstus,Flags) :-
813 Flags = [ unique_analyse_optimise - off,
814 check_unnecessary_active - simplification,
815 reorder_heads - off,
816 set_semantics_rule - off,
817 check_attachments - off,
818 guard_via_reschedule - off
819 ].
821 option_definition(optimize,off,Flags) :-
822 Flags = [ unique_analyse_optimise - off,
823 check_unnecessary_active - off,
824 reorder_heads - off,
825 set_semantics_rule - off,
826 check_attachments - off,
827 guard_via_reschedule - off
828 ].
830 option_definition(check_guard_bindings,on,Flags) :-
831 Flags = [ guard_locks - on ].
833 option_definition(check_guard_bindings,off,Flags) :-
834 Flags = [ guard_locks - off ].
836 option_definition(reduced_indexing,on,Flags) :-
837 Flags = [ reduced_indexing - on ].
839 option_definition(reduced_indexing,off,Flags) :-
840 Flags = [ reduced_indexing - off ].
842 option_definition(mode,ModeDecl,[]) :-
843 (nonvar(ModeDecl) ->
844 functor(ModeDecl,F,A),
845 ModeDecl =.. [_|ArgModes],
846 constraint_mode(F/A,ArgModes)
847 ;
848 true
849 ).
850 option_definition(store,FA-Store,[]) :-
851 store_type(FA,Store).
853 option_definition(debug,on,Flags) :-
854 Flags = [ debugable - on ].
855 option_definition(debug,off,Flags) :-
856 Flags = [ debugable - off ].
858 init_chr_pp_flags :-
859 chr_pp_flag_definition(Name,[DefaultValue|_]),
860 set_chr_pp_flag(Name,DefaultValue),
861 fail.
862 init_chr_pp_flags.
864 set_chr_pp_flags([]).
865 set_chr_pp_flags([Name-Value|Flags]) :-
866 set_chr_pp_flag(Name,Value),
867 set_chr_pp_flags(Flags).
869 set_chr_pp_flag(Name,Value) :-
870 atom_concat('$chr_pp_',Name,GlobalVar),
871 nb_setval(GlobalVar,Value).
873 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
874 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
875 chr_pp_flag_definition(reorder_heads,[on,off]).
876 chr_pp_flag_definition(set_semantics_rule,[on,off]).
877 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
878 chr_pp_flag_definition(guard_locks,[on,off]).
879 chr_pp_flag_definition(check_attachments,[on,off]).
880 chr_pp_flag_definition(debugable,[off,on]).
881 chr_pp_flag_definition(reduced_indexing,[on,off]).
883 chr_pp_flag(Name,Value) :-
884 atom_concat('$chr_pp_',Name,GlobalVar),
885 nb_getval(GlobalVar,V),
886 ( V == [] ->
887 chr_pp_flag_definition(Name,[Value|_])
888 ;
889 V = Value
890 ).
891 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
893 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
894 %%
895 %% Generated predicates
896 %% attach_$CONSTRAINT
897 %% attach_increment
898 %% detach_$CONSTRAINT
899 %% attr_unify_hook
901 %% attach_$CONSTRAINT
902 generate_attach_detach_a_constraint_all([],[]).
903 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
904 ( may_trigger(Constraint) ->
905 generate_attach_a_constraint(Constraint,Clauses1),
906 generate_detach_a_constraint(Constraint,Clauses2)
907 ;
908 Clauses1 = [],
909 Clauses2 = []
910 ),
911 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
912 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
914 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
915 generate_attach_a_constraint_empty_list(Constraint,Clause1),
916 get_max_constraint_index(N),
917 ( N == 1 ->
918 generate_attach_a_constraint_1_1(Constraint,Clause2)
919 ;
920 generate_attach_a_constraint_t_p(Constraint,Clause2)
921 ).
923 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
924 make_name('attach_',FA,Fct),
925 Head =.. [Fct | Args],
926 Clause = ( Head :- Body).
928 generate_attach_a_constraint_empty_list(FA,Clause) :-
929 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
931 generate_attach_a_constraint_1_1(FA,Clause) :-
932 Args = [[Var|Vars],Susp],
933 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
934 generate_attach_body_1(FA,Var,Susp,AttachBody),
935 make_name('attach_',FA,Fct),
936 RecursiveCall =.. [Fct,Vars,Susp],
937 Body =
938 (
939 AttachBody,
940 RecursiveCall
941 ).
943 generate_attach_body_1(FA,Var,Susp,Body) :-
944 get_target_module(Mod),
945 Body =
946 ( get_attr(Var, Mod, Susps) ->
947 NewSusps=[Susp|Susps],
948 put_attr(Var, Mod, NewSusps)
949 ;
950 put_attr(Var, Mod, [Susp])
951 ).
953 generate_attach_a_constraint_t_p(FA,Clause) :-
954 Args = [[Var|Vars],Susp],
955 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
956 make_name('attach_',FA,Fct),
957 RecursiveCall =.. [Fct,Vars,Susp],
958 generate_attach_body_n(FA,Var,Susp,AttachBody),
959 Body =
960 (
961 AttachBody,
962 RecursiveCall
963 ).
965 generate_attach_body_n(F/A,Var,Susp,Body) :-
966 get_constraint_index(F/A,Position),
967 or_pattern(Position,Pattern),
968 get_max_constraint_index(Total),
969 make_attr(Total,Mask,SuspsList,Attr),
970 nth(Position,SuspsList,Susps),
971 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
972 make_attr(Total,Mask,SuspsList1,NewAttr1),
973 substitute(Susps,SuspsList,[Susp],SuspsList2),
974 make_attr(Total,NewMask,SuspsList2,NewAttr2),
975 copy_term(SuspsList,SuspsList3),
976 nth(Position,SuspsList3,[Susp]),
977 delete(SuspsList3,[Susp],RestSuspsList),
978 set_elems(RestSuspsList,[]),
979 make_attr(Total,Pattern,SuspsList3,NewAttr3),
980 get_target_module(Mod),
981 Body =
982 ( get_attr(Var,Mod,TAttr) ->
983 TAttr = Attr,
984 ( Mask /\ Pattern =:= Pattern ->
985 put_attr(Var, Mod, NewAttr1)
986 ;
987 NewMask is Mask \/ Pattern,
988 put_attr(Var, Mod, NewAttr2)
989 )
990 ;
991 put_attr(Var,Mod,NewAttr3)
992 ).
994 %% detach_$CONSTRAINT
995 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
996 generate_detach_a_constraint_empty_list(Constraint,Clause1),
997 get_max_constraint_index(N),
998 ( N == 1 ->
999 generate_detach_a_constraint_1_1(Constraint,Clause2)
1000 ;
1001 generate_detach_a_constraint_t_p(Constraint,Clause2)
1002 ).
1004 generate_detach_a_constraint_empty_list(FA,Clause) :-
1005 make_name('detach_',FA,Fct),
1006 Args = [[],_],
1007 Head =.. [Fct | Args],
1008 Clause = ( Head :- true).
1010 generate_detach_a_constraint_1_1(FA,Clause) :-
1011 make_name('detach_',FA,Fct),
1012 Args = [[Var|Vars],Susp],
1013 Head =.. [Fct | Args],
1014 RecursiveCall =.. [Fct,Vars,Susp],
1015 generate_detach_body_1(FA,Var,Susp,DetachBody),
1016 Body =
1017 (
1018 DetachBody,
1019 RecursiveCall
1020 ),
1021 Clause = (Head :- Body).
1023 generate_detach_body_1(FA,Var,Susp,Body) :-
1024 get_target_module(Mod),
1025 Body =
1026 ( get_attr(Var,Mod,Susps) ->
1027 'chr sbag_del_element'(Susps,Susp,NewSusps),
1028 ( NewSusps == [] ->
1029 del_attr(Var,Mod)
1030 ;
1031 put_attr(Var,Mod,NewSusps)
1032 )
1033 ;
1034 true
1035 ).
1037 generate_detach_a_constraint_t_p(FA,Clause) :-
1038 make_name('detach_',FA,Fct),
1039 Args = [[Var|Vars],Susp],
1040 Head =.. [Fct | Args],
1041 RecursiveCall =.. [Fct,Vars,Susp],
1042 generate_detach_body_n(FA,Var,Susp,DetachBody),
1043 Body =
1044 (
1045 DetachBody,
1046 RecursiveCall
1047 ),
1048 Clause = (Head :- Body).
1050 generate_detach_body_n(F/A,Var,Susp,Body) :-
1051 get_constraint_index(F/A,Position),
1052 or_pattern(Position,Pattern),
1053 and_pattern(Position,DelPattern),
1054 get_max_constraint_index(Total),
1055 make_attr(Total,Mask,SuspsList,Attr),
1056 nth(Position,SuspsList,Susps),
1057 substitute(Susps,SuspsList,[],SuspsList1),
1058 make_attr(Total,NewMask,SuspsList1,Attr1),
1059 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1060 make_attr(Total,Mask,SuspsList2,Attr2),
1061 get_target_module(Mod),
1062 Body =
1063 ( get_attr(Var,Mod,TAttr) ->
1064 TAttr = Attr,
1065 ( Mask /\ Pattern =:= Pattern ->
1066 'chr sbag_del_element'(Susps,Susp,NewSusps),
1067 ( NewSusps == [] ->
1068 NewMask is Mask /\ DelPattern,
1069 ( NewMask == 0 ->
1070 del_attr(Var,Mod)
1071 ;
1072 put_attr(Var,Mod,Attr1)
1073 )
1074 ;
1075 put_attr(Var,Mod,Attr2)
1076 )
1077 ;
1078 true
1079 )
1080 ;
1081 true
1082 ).
1084 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1085 generate_indexed_variables_clauses(Constraints,Clauses) :-
1086 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1087 generate_indexed_variables_clauses_(Constraints,Clauses)
1088 ;
1089 Clauses = []
1090 ).
1092 generate_indexed_variables_clauses_([],[]).
1093 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1094 ( ( is_attached(C) ; chr_pp_flag(debugable,on)) ->
1095 Clauses = [Clause|RestClauses],
1096 generate_indexed_variables_clause(C,Clause)
1097 ;
1098 Clauses = RestClauses
1099 ),
1100 generate_indexed_variables_clauses_(Cs,RestClauses).
1102 generate_indexed_variables_clause(F/A,Clause) :-
1103 functor(Term,F,A),
1104 get_constraint_mode(F/A,ArgModes),
1105 Term =.. [_|Args],
1106 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1107 ( MaybeBody == empty ->
1109 Body = (Vars = [])
1110 ; N == 0 ->
1111 Body = term_variables(Susp,Vars)
1112 ;
1113 MaybeBody = Body
1114 ),
1115 Clause =
1116 ( '$indexed_variables'(Susp,Vars) :-
1117 Susp = Term,
1118 Body
1119 ).
1121 create_indexed_variables_body([],[],_,_,_,empty,0).
1122 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1123 J is I + 1,
1124 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1125 ( Mode \== (+),
1126 is_indexed_argument(FA,I) ->
1127 ( RBody == empty ->
1128 Body = term_variables(V,Vars)
1129 ;
1130 Body = (term_variables(V,Vars,Tail),RBody)
1131 ),
1132 N = M
1133 ;
1134 Vars = Tail,
1135 Body = RBody,
1136 N is M + 1
1137 ).
1139 generate_extra_clauses(Constraints,[A,B,C,D,E]) :-
1140 ( chr_pp_flag(reduced_indexing,on) ->
1141 global_indexed_variables_clause(Constraints,D)
1142 ;
1143 D =
1144 ( chr_indexed_variables(Susp,Vars) :-
1145 'chr chr_indexed_variables'(Susp,Vars)
1146 )
1147 ),
1148 generate_remove_clause(A),
1149 generate_activate_clause(B),
1150 generate_allocate_clause(C),
1151 generate_insert_constraint_internal(E).
1153 generate_remove_clause(RemoveClause) :-
1154 RemoveClause =
1155 (
1156 remove_constraint_internal(Susp, Agenda, Delete) :-
1157 arg( 2, Susp, Mref),
1158 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1159 'chr update_mutable'( removed, Mref), % mark in any case
1160 ( compound(State) -> % passive/1
1161 Agenda = [],
1162 Delete = no
1163 ; State==removed ->
1164 Agenda = [],
1165 Delete = no
1166 %; State==triggered ->
1167 % Agenda = []
1168 ;
1169 Delete = yes,
1170 chr_indexed_variables(Susp,Agenda)
1171 )
1172 ).
1174 generate_activate_clause(ActivateClause) :-
1175 ActivateClause =
1176 (
1177 activate_constraint(Store, Vars, Susp, Generation) :-
1178 arg( 2, Susp, Mref),
1179 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1180 'chr update_mutable'( active, Mref),
1181 ( nonvar(Generation) -> % aih
1182 true
1183 ;
1184 arg( 4, Susp, Gref),
1185 Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
1186 Generation is Gen+1,
1187 'chr update_mutable'( Generation, Gref)
1188 ),
1189 ( compound(State) -> % passive/1
1190 term_variables( State, Vars),
1191 'chr none_locked'( Vars),
1192 Store = yes
1193 ; State == removed -> % the price for eager removal ...
1194 chr_indexed_variables(Susp,Vars),
1195 Store = yes
1196 ;
1197 Vars = [],
1198 Store = no
1199 )
1200 ).
1202 generate_allocate_clause(AllocateClause) :-
1203 AllocateClause =
1204 (
1205 allocate_constraint( Closure, Self, F, Args) :-
1206 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1207 Gref = mutable(0),
1208 'chr empty_history'(History),
1209 Href = mutable(History),
1210 chr_indexed_variables(Self,Vars),
1211 Mref = mutable(passive(Vars)),
1212 'chr gen_id'( Id)
1213 ).
1215 generate_insert_constraint_internal(Clause) :-
1216 Clause =
1217 (
1218 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1219 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1220 chr_indexed_variables(Self,Vars),
1221 'chr none_locked'(Vars),
1222 Mref = mutable(active),
1223 Gref = mutable(0),
1224 Href = mutable(History),
1225 'chr empty_history'(History),
1226 'chr gen_id'(Id)
1227 ).
1229 global_indexed_variables_clause(Constraints,Clause) :-
1230 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1231 Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
1232 ;
1233 Body = true,
1234 Vars = []
1235 ),
1236 Clause = ( chr_indexed_variables(Susp,Vars) :- Body ).
1238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1239 generate_attach_increment(Clauses) :-
1240 get_max_constraint_index(N),
1241 ( N > 0 ->
1242 Clauses = [Clause1,Clause2],
1243 generate_attach_increment_empty(Clause1),
1244 ( N == 1 ->
1245 generate_attach_increment_one(Clause2)
1246 ;
1247 generate_attach_increment_many(N,Clause2)
1248 )
1249 ;
1250 Clauses = []
1251 ).
1253 generate_attach_increment_empty((attach_increment([],_) :- true)).
1255 generate_attach_increment_one(Clause) :-
1256 Head = attach_increment([Var|Vars],Susps),
1257 get_target_module(Mod),
1258 Body =
1259 (
1260 'chr not_locked'(Var),
1261 ( get_attr(Var,Mod,VarSusps) ->
1262 sort(VarSusps,SortedVarSusps),
1263 merge(Susps,SortedVarSusps,MergedSusps),
1264 put_attr(Var,Mod,MergedSusps)
1265 ;
1266 put_attr(Var,Mod,Susps)
1267 ),
1268 attach_increment(Vars,Susps)
1269 ),
1270 Clause = (Head :- Body).
1272 generate_attach_increment_many(N,Clause) :-
1273 make_attr(N,Mask,SuspsList,Attr),
1274 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1275 Head = attach_increment([Var|Vars],Attr),
1276 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1277 list2conj(Gs,SortGoals),
1278 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1279 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1280 get_target_module(Mod),
1281 Body =
1282 (
1283 'chr not_locked'(Var),
1284 ( get_attr(Var,Mod,TOtherAttr) ->
1285 TOtherAttr = OtherAttr,
1286 SortGoals,
1287 MergedMask is Mask \/ OtherMask,
1288 put_attr(Var,Mod,NewAttr)
1289 ;
1290 put_attr(Var,Mod,Attr)
1291 ),
1292 attach_increment(Vars,Attr)
1293 ),
1294 Clause = (Head :- Body).
1296 %% attr_unify_hook
1297 generate_attr_unify_hook([Clause]) :-
1298 get_max_constraint_index(N),
1299 ( N == 0 ->
1300 get_target_module(Mod),
1301 Clause =
1302 ( attr_unify_hook(Attr,Var) :-
1303 write('ERROR: Unexpected triggering of attr_unify_hook/2 in module '),
1304 writeln(Mod)
1305 )
1306 ; N == 1 ->
1307 generate_attr_unify_hook_one(Clause)
1308 ;
1309 generate_attr_unify_hook_many(N,Clause)
1310 ).
1312 generate_attr_unify_hook_one(Clause) :-
1313 Head = attr_unify_hook(Susps,Other),
1314 get_target_module(Mod),
1315 make_run_suspensions(NewSusps,WakeNewSusps),
1316 make_run_suspensions(Susps,WakeSusps),
1317 Body =
1318 (
1319 sort(Susps, SortedSusps),
1320 ( var(Other) ->
1321 ( get_attr(Other,Mod,OtherSusps) ->
1322 true
1323 ;
1324 OtherSusps = []
1325 ),
1326 sort(OtherSusps,SortedOtherSusps),
1327 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1328 put_attr(Other,Mod,NewSusps),
1329 WakeNewSusps
1330 ;
1331 ( compound(Other) ->
1332 term_variables(Other,OtherVars),
1333 attach_increment(OtherVars, SortedSusps)
1334 ;
1335 true
1336 ),
1337 WakeSusps
1338 )
1339 ),
1340 Clause = (Head :- Body).
1342 generate_attr_unify_hook_many(N,Clause) :-
1343 make_attr(N,Mask,SuspsList,Attr),
1344 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1345 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1346 list2conj(SortGoalList,SortGoals),
1347 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1348 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1349 C = (sort(E,F),
1350 'chr merge_attributes'(D,F,G)) ),
1351 SortMergeGoalList),
1352 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1353 list2conj(SortMergeGoalList,SortMergeGoals),
1354 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1355 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1356 Head = attr_unify_hook(Attr,Other),
1357 get_target_module(Mod),
1358 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1359 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1360 Body =
1361 (
1362 SortGoals,
1363 ( var(Other) ->
1364 ( get_attr(Other,Mod,TOtherAttr) ->
1365 TOtherAttr = OtherAttr,
1366 SortMergeGoals,
1367 MergedMask is Mask \/ OtherMask,
1368 put_attr(Other,Mod,MergedAttr),
1369 WakeMergedSusps
1370 ;
1371 put_attr(Other,Mod,SortedAttr),
1372 WakeSortedSusps
1373 )
1374 ;
1375 ( compound(Other) ->
1376 term_variables(Other,OtherVars),
1377 attach_increment(OtherVars,SortedAttr)
1378 ;
1379 true
1380 ),
1381 WakeSortedSusps
1382 )
1383 ),
1384 Clause = (Head :- Body).
1386 make_run_suspensions(Susps,Goal) :-
1387 ( chr_pp_flag(debugable,on) ->
1388 Goal = 'chr run_suspensions_d'(Susps)
1389 ;
1390 Goal = 'chr run_suspensions'(Susps)
1391 ).
1393 make_run_suspensions_loop(SuspsList,Goal) :-
1394 ( chr_pp_flag(debugable,on) ->
1395 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1396 ;
1397 Goal = 'chr run_suspensions_loop'(SuspsList)
1398 ).
1400 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1401 % $insert_in_store_F/A
1402 % $delete_from_store_F/A
1404 generate_insert_delete_constraints([],[]).
1405 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1406 ( is_attached(FA) ->
1407 Clauses = [IClause,DClause|RestClauses],
1408 generate_insert_delete_constraint(FA,IClause,DClause)
1409 ;
1410 Clauses = RestClauses
1411 ),
1412 generate_insert_delete_constraints(Rest,RestClauses).
1414 generate_insert_delete_constraint(FA,IClause,DClause) :-
1415 get_store_type(FA,StoreType),
1416 generate_insert_constraint(StoreType,FA,IClause),
1417 generate_delete_constraint(StoreType,FA,DClause).
1419 generate_insert_constraint(StoreType,C,Clause) :-
1420 make_name('$insert_in_store_',C,ClauseName),
1421 Head =.. [ClauseName,Susp],
1422 generate_insert_constraint_body(StoreType,C,Susp,Body),
1423 Clause = (Head :- Body).
1425 generate_insert_constraint_body(default,C,Susp,Body) :-
1426 get_target_module(Mod),
1427 get_max_constraint_index(Total),
1428 ( Total == 1 ->
1429 generate_attach_body_1(C,Store,Susp,AttachBody)
1430 ;
1431 generate_attach_body_n(C,Store,Susp,AttachBody)
1432 ),
1433 Body =
1434 (
1435 'chr global_term_ref_1'(Store),
1436 AttachBody
1437 ).
1438 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1439 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1440 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1441 global_ground_store_name(C,StoreName),
1442 Body =
1443 (
1444 nb_getval(StoreName,Store),
1445 b_setval(StoreName,[Susp|Store])
1446 ).
1447 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1448 find_with_var_identity(
1449 B,
1450 [Susp],
1451 (
1452 member(ST,StoreTypes),
1453 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1454 ),
1455 Bodies
1456 ),
1457 list2conj(Bodies,Body).
1459 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1460 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1461 multi_hash_store_name(FA,Index,StoreName),
1462 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1463 Body =
1464 (
1465 KeyBody,
1466 nb_getval(StoreName,Store),
1467 insert_ht(Store,Key,Susp)
1468 ),
1469 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1471 generate_delete_constraint(StoreType,FA,Clause) :-
1472 make_name('$delete_from_store_',FA,ClauseName),
1473 Head =.. [ClauseName,Susp],
1474 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1475 Clause = (Head :- Body).
1477 generate_delete_constraint_body(default,C,Susp,Body) :-
1478 get_target_module(Mod),
1479 get_max_constraint_index(Total),
1480 ( Total == 1 ->
1481 generate_detach_body_1(C,Store,Susp,DetachBody),
1482 Body =
1483 (
1484 'chr global_term_ref_1'(Store),
1485 DetachBody
1486 )
1487 ;
1488 generate_detach_body_n(C,Store,Susp,DetachBody),
1489 Body =
1490 (
1491 'chr global_term_ref_1'(Store),
1492 DetachBody
1493 )
1494 ).
1495 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1496 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1497 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1498 global_ground_store_name(C,StoreName),
1499 Body =
1500 (
1501 nb_getval(StoreName,Store),
1502 'chr sbag_del_element'(Store,Susp,NStore),
1503 b_setval(StoreName,NStore)
1504 ).
1505 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1506 find_with_var_identity(
1507 B,
1508 [Susp],
1509 (
1510 member(ST,StoreTypes),
1511 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1512 ),
1513 Bodies
1514 ),
1515 list2conj(Bodies,Body).
1517 generate_multi_hash_delete_constraint_bodies([],_,_,true).
1518 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1519 multi_hash_store_name(FA,Index,StoreName),
1520 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1521 Body =
1522 (
1523 KeyBody,
1524 nb_getval(StoreName,Store),
1525 delete_ht(Store,Key,Susp)
1526 ),
1527 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
1529 generate_delete_constraint_call(FA,Susp,Call) :-
1530 make_name('$delete_from_store_',FA,Functor),
1531 Call =.. [Functor,Susp].
1533 generate_insert_constraint_call(FA,Susp,Call) :-
1534 make_name('$insert_in_store_',FA,Functor),
1535 Call =.. [Functor,Susp].
1537 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1539 generate_store_code(Constraints,[Enumerate|L]) :-
1540 enumerate_stores_code(Constraints,Enumerate),
1541 generate_store_code(Constraints,L,[]).
1543 generate_store_code([],L,L).
1544 generate_store_code([C|Cs],L,T) :-
1545 get_store_type(C,StoreType),
1546 generate_store_code(StoreType,C,L,L1),
1547 generate_store_code(Cs,L1,T).
1549 generate_store_code(default,_,L,L).
1550 generate_store_code(multi_hash(Indexes),C,L,T) :-
1551 multi_hash_store_initialisations(Indexes,C,L,L1),
1552 multi_hash_via_lookups(Indexes,C,L1,T).
1553 generate_store_code(global_ground,C,L,T) :-
1554 global_ground_store_initialisation(C,L,T).
1555 generate_store_code(multi_store(StoreTypes),C,L,T) :-
1556 multi_store_generate_store_code(StoreTypes,C,L,T).
1558 multi_store_generate_store_code([],_,L,L).
1559 multi_store_generate_store_code([ST|STs],C,L,T) :-
1560 generate_store_code(ST,C,L,L1),
1561 multi_store_generate_store_code(STs,C,L1,T).
1563 multi_hash_store_initialisations([],_,L,L).
1564 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
1565 multi_hash_store_name(FA,Index,StoreName),
1566 L = [(:- (new_ht(HT),nb_setval(StoreName,HT)) )|L1],
1567 multi_hash_store_initialisations(Indexes,FA,L1,T).
1569 global_ground_store_initialisation(C,L,T) :-
1570 global_ground_store_name(C,StoreName),
1571 L = [(:- nb_setval(StoreName,[]))|T].
1573 multi_hash_via_lookups([],_,L,L).
1574 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
1575 multi_hash_via_lookup_name(C,Index,PredName),
1576 Head =.. [PredName,Key,SuspsList],
1577 multi_hash_store_name(C,Index,StoreName),
1578 Body =
1579 (
1580 nb_getval(StoreName,HT),
1581 lookup_ht(HT,Key,SuspsList)
1582 ),
1583 L = [(Head :- Body)|L1],
1584 multi_hash_via_lookups(Indexes,C,L1,T).
1586 multi_hash_via_lookup_name(F/A,Index,Name) :-
1587 ( integer(Index) ->
1588 IndexName = Index
1589 ; is_list(Index) ->
1590 atom_concat_list(Index,IndexName)
1591 ),
1592 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
1594 multi_hash_store_name(F/A,Index,Name) :-
1595 get_target_module(Mod),
1596 ( integer(Index) ->
1597 IndexName = Index
1598 ; is_list(Index) ->
1599 atom_concat_list(Index,IndexName)
1600 ),
1601 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
1603 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
1604 ( ( integer(Index) ->
1605 I = Index
1606 ;
1607 Index = [I]
1608 ) ->
1609 SuspIndex is I + 6,
1610 KeyBody = arg(SuspIndex,Susp,Key)
1611 ; is_list(Index) ->
1612 sort(Index,Indexes),
1613 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
1614 pairup(Bodies,Keys,ArgKeyPairs),
1615 Key =.. [k|Keys],
1616 list2conj(Bodies,KeyBody)
1617 ).
1619 multi_hash_key_args(Index,Head,KeyArgs) :-
1620 ( integer(Index) ->
1621 arg(Index,Head,Arg),
1622 KeyArgs = [Arg]
1623 ; is_list(Index) ->
1624 sort(Index,Indexes),
1625 term_variables(Head,Vars),
1626 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
1627 ).
1629 global_ground_store_name(F/A,Name) :-
1630 get_target_module(Mod),
1631 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
1632 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1633 enumerate_stores_code(Constraints,Clause) :-
1634 Head = '$enumerate_suspensions'(Susp),
1635 enumerate_store_bodies(Constraints,Susp,Bodies),
1636 list2disj(Bodies,Body),
1637 Clause = (Head :- Body).
1639 enumerate_store_bodies([],_,[]).
1640 enumerate_store_bodies([C|Cs],Susp,L) :-
1641 ( is_attached(C) ->
1642 get_store_type(C,StoreType),
1643 enumerate_store_body(StoreType,C,Susp,B),
1644 L = [B|T]
1645 ;
1646 L = T
1647 ),
1648 enumerate_store_bodies(Cs,Susp,T).
1650 enumerate_store_body(default,C,Susp,Body) :-
1651 get_constraint_index(C,Index),
1652 get_target_module(Mod),
1653 get_max_constraint_index(MaxIndex),
1654 Body1 =
1655 (
1656 'chr global_term_ref_1'(GlobalStore),
1657 get_attr(GlobalStore,Mod,Attr)
1658 ),
1659 ( MaxIndex > 1 ->
1660 NIndex is Index + 1,
1661 Body2 =
1662 (
1663 arg(NIndex,Attr,List),
1664 'chr sbag_member'(Susp,List)
1665 )
1666 ;
1667 Body2 = 'chr sbag_member'(Susp,Attr)
1668 ),
1669 Body = (Body1,Body2).
1670 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
1671 multi_hash_enumerate_store_body(Index,C,Susp,Body).
1672 enumerate_store_body(global_ground,C,Susp,Body) :-
1673 global_ground_store_name(C,StoreName),
1674 Body =
1675 (
1676 nb_getval(StoreName,List),
1677 'chr sbag_member'(Susp,List)
1678 ).
1679 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
1680 once((
1681 member(ST,STs),
1682 enumerate_store_body(ST,C,Susp,Body)
1683 )).
1685 multi_hash_enumerate_store_body(I,C,Susp,B) :-
1686 multi_hash_store_name(C,I,StoreName),
1687 B =
1688 (
1689 nb_getval(StoreName,HT),
1690 value_ht(HT,Susp)
1691 ).
1692 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1693 check_attachments(Constraints) :-
1694 ( chr_pp_flag(check_attachments,on) ->
1695 check_constraint_attachments(Constraints)
1696 ;
1697 true
1698 ).
1700 check_constraint_attachments([]).
1701 check_constraint_attachments([C|Cs]) :-
1702 check_constraint_attachment(C),
1703 check_constraint_attachments(Cs).
1705 check_constraint_attachment(C) :-
1706 get_max_occurrence(C,MO),
1707 check_occurrences_attachment(C,1,MO).
1709 check_occurrences_attachment(C,O,MO) :-
1710 ( O > MO ->
1711 true
1712 ;
1713 check_occurrence_attachment(C,O),
1714 NO is O + 1,
1715 check_occurrences_attachment(C,NO,MO)
1716 ).
1718 check_occurrence_attachment(C,O) :-
1719 get_occurrence(C,O,RuleNb,ID),
1720 get_rule(RuleNb,PragmaRule),
1721 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
1722 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
1723 check_attachment_head1(Head1,ID,RuleNb,Heads1,Heads2,Guard)
1724 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
1725 check_attachment_head2(Head2,ID,RuleNb,Heads1,Body)
1726 ).
1728 check_attachment_head1(C,ID,RuleNb,H1,H2,G) :-
1729 functor(C,F,A),
1730 ( H1 == [C],
1731 H2 == [],
1732 G == true,
1733 C =.. [_|L],
1734 no_matching(L,[]),
1735 \+ is_passive(RuleNb,ID) ->
1736 attached(F/A,no)
1737 ;
1738 attached(F/A,maybe)
1739 ).
1741 no_matching([],_).
1742 no_matching([X|Xs],Prev) :-
1743 var(X),
1744 \+ memberchk_eq(X,Prev),
1745 no_matching(Xs,[X|Prev]).
1747 check_attachment_head2(C,ID,RuleNb,H1,B) :-
1748 functor(C,F,A),
1749 ( is_passive(RuleNb,ID) ->
1750 attached(F/A,maybe)
1751 ; H1 \== [],
1752 B == true ->
1753 attached(F/A,maybe)
1754 ;
1755 attached(F/A,yes)
1756 ).
1758 all_attached([]).
1759 all_attached([C|Cs]) :-
1760 functor(C,F,A),
1761 is_attached(F/A),
1762 all_attached(Cs).
1764 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1766 set_constraint_indices([],M) :-
1767 N is M - 1,
1768 max_constraint_index(N).
1769 set_constraint_indices([C|Cs],N) :-
1770 ( ( may_trigger(C) ; is_attached(C), get_store_type(C,default)) ->
1771 constraint_index(C,N),
1772 M is N + 1,
1773 set_constraint_indices(Cs,M)
1774 ;
1775 set_constraint_indices(Cs,N)
1776 ).
1778 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1779 %% ____ _ ____ _ _ _ _
1780 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
1781 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
1782 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
1783 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
1784 %% |_|
1786 constraints_code(Constraints,Rules,Clauses) :-
1787 post_constraints(Constraints,1),
1788 constraints_code1(1,Rules,L,[]),
1789 clean_clauses(L,Clauses).
1791 %% Add global data
1792 post_constraints([],MaxIndex1) :-
1793 MaxIndex is MaxIndex1 - 1,
1794 constraint_count(MaxIndex).
1795 post_constraints([F/A|Cs],N) :-
1796 constraint(F/A,N),
1797 M is N + 1,
1798 post_constraints(Cs,M).
1799 constraints_code1(I,Rules,L,T) :-
1800 get_constraint_count(N),
1801 ( I > N ->
1802 T = L
1803 ;
1804 constraint_code(I,Rules,L,T1),
1805 J is I + 1,
1806 constraints_code1(J,Rules,T1,T)
1807 ).
1809 %% Generate code for a single CHR constraint
1810 constraint_code(I, Rules, L, T) :-
1811 get_constraint(Constraint,I),
1812 constraint_prelude(Constraint,Clause),
1813 L = [Clause | L1],
1814 Id1 = [0],
1815 rules_code(Rules,I,Id1,Id2,L1,L2),
1816 gen_cond_attach_clause(Constraint,Id2,L2,T).
1818 %% Generate prelude predicate for a constraint.
1819 %% f(...) :- f/a_0(...,Susp).
1820 constraint_prelude(F/A, Clause) :-
1821 vars_susp(A,Vars,Susp,VarsSusp),
1822 Head =.. [ F | Vars],
1823 build_head(F,A,[0],VarsSusp,Delegate),
1824 get_target_module(Mod),
1825 FTerm =.. [F|Vars],
1826 ( chr_pp_flag(debugable,on) ->
1827 Clause =
1828 ( Head :-
1829 allocate_constraint(Mod : Delegate, Susp, FTerm, Vars),
1830 (
1831 'chr debug_event'(call(Susp)),
1832 Delegate
1833 ;
1834 'chr debug_event'(fail(Susp)), !,
1835 fail
1836 ),
1837 (
1838 'chr debug_event'(exit(Susp))
1839 ;
1840 'chr debug_event'(redo(Susp)),
1841 fail
1842 )
1843 )
1844 ;
1845 Clause = ( Head :- Delegate )
1846 ).
1848 gen_cond_attach_clause(F/A,Id,L,T) :-
1849 ( is_attached(F/A) ->
1850 ( Id == [0] ->
1851 ( may_trigger(F/A) ->
1852 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
1853 ;
1854 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
1855 )
1856 ; vars_susp(A,Args,Susp,AllArgs),
1857 gen_uncond_attach_goal(F/A,Susp,Body,_)
1858 ),
1859 ( chr_pp_flag(debugable,on) ->
1860 Constraint =.. [F|Args],
1861 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
1862 ;
1863 DebugEvent = true
1864 ),
1865 build_head(F,A,Id,AllArgs,Head),
1866 Clause = ( Head :- DebugEvent,Body ),
1867 L = [Clause | T]
1868 ;
1869 L = T
1870 ).
1872 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
1873 vars_susp(A,Args,Susp,AllArgs),
1874 build_head(F,A,[0],AllArgs,Closure),
1875 ( may_trigger(F/A) ->
1876 make_name('attach_',F/A,AttachF),
1877 Attach =.. [AttachF,Vars,Susp]
1878 ;
1879 Attach = true
1880 ),
1881 get_target_module(Mod),
1882 FTerm =.. [F|Args],
1883 generate_insert_constraint_call(F/A,Susp,InsertCall),
1884 Goal =
1885 (
1886 ( var(Susp) ->
1887 insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args)
1888 ;
1889 activate_constraint(Stored,Vars,Susp,_)
1890 ),
1891 ( Stored == yes ->
1892 InsertCall,
1893 Attach
1894 ;
1895 true
1896 )
1897 ).
1899 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
1900 vars_susp(A,Args,Susp,AllArgs),
1901 build_head(F,A,[0],AllArgs,Closure),
1902 ( may_trigger(F/A) ->
1903 make_name('attach_',F/A,AttachF),
1904 Attach =.. [AttachF,Vars,Susp]
1905 ;
1906 Attach = true
1907 ),
1908 get_target_module(Mod),
1909 FTerm =.. [F|Args],
1910 generate_insert_constraint_call(F/A,Susp,InsertCall),
1911 Goal =
1912 (
1913 insert_constraint_internal(_,Vars,Susp,Mod:Closure,FTerm,Args),
1914 InsertCall,
1915 Attach
1916 ).
1918 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
1919 ( may_trigger(FA) ->
1920 make_name('attach_',FA,AttachF),
1921 Attach =.. [AttachF,Vars,Susp]
1922 ;
1923 Attach = true
1924 ),
1925 generate_insert_constraint_call(FA,Susp,InsertCall),
1926 AttachGoal =
1927 (
1928 activate_constraint(Stored,Vars, Susp, Generation),
1929 ( Stored == yes ->
1930 InsertCall,
1931 Attach
1932 ;
1933 true
1934 )
1935 ).
1937 occurrences_code(O,MO,C,Id,NId,L,T) :-
1938 ( O > MO ->
1939 NId = Id,
1940 L = T
1941 ;
1942 occurrence_code(O,C,Id,Id1,L,L1),
1943 NO is O + 1,
1944 occurrences_code(NO,MO,C,Id1,NId,L1,T)
1945 ).
1947 occurrences_code(O,C,Id,NId,L,T) :-
1948 get_occurrence(C,O,RuleNb,ID),
1949 ( is_passive(RuleNb,ID) ->
1950 NId = Id,
1951 L = T
1952 ;
1953 get_rule(RuleNb,PragmaRule),
1954 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
1955 ( select2(IDs1,Heads1,ID,Head1,RIDs1,RHeads1) ->
1956 NId = Id,
1957 head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,Id,L,T)
1958 ; select2(IDs2,Heads2,ID,Head2,RIDs2,RHeads2) ->
1959 length(RHeads2,RestHeadNb),
1960 head2_code(Head2,RHeads2,RIDs2,PragmaRule,RestHeadNb,C,Id,L,L1),
1961 inc_id(Id,NId),
1962 gen_alloc_inc_clause(C,Id,L1,T)
1963 )
1964 ).
1967 %% Generate all the code for a constraint based on all CHR rules
1968 rules_code([],_,Id,Id,L,L).
1969 rules_code([R |Rs],I,Id1,Id3,L,T) :-
1970 rule_code(R,I,Id1,Id2,L,T1),
1971 rules_code(Rs,I,Id2,Id3,T1,T).
1973 %% Generate code for a constraint based on a single CHR rule
1974 rule_code(PragmaRule,I,Id1,Id2,L,T) :-
1975 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name,_RuleNb),
1976 HeadIDs = ids(Head1IDs,Head2IDs),
1977 Rule = rule(Head1,Head2,_,_),
1978 heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
1979 heads2_code(Head2,[],Head2IDs,[],PragmaRule,I,Id1,Id2,L1,T).
1981 %% Generate code based on all the removed heads of a CHR rule
1982 heads1_code([],_,_,_,_,_,_,L,L).
1983 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
1984 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
1985 get_constraint(F/A,I),
1986 ( functor(Head,F,A),
1987 \+ is_passive(RuleNb,HeadID),
1988 \+ check_unnecessary_active(Head,RestHeads,Rule),
1989 all_attached(Heads),
1990 all_attached(RestHeads),
1991 Rule = rule(_,Heads2,_,_),
1992 all_attached(Heads2) ->
1993 append(Heads,RestHeads,OtherHeads),
1994 append(HeadIDs,RestIDs,OtherIDs),
1995 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
1996 ;
1997 L = L1
1998 ),
1999 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
2001 %% Generate code based on one removed head of a CHR rule
2002 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
2003 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2004 Rule = rule(_,Head2,_,_),
2005 ( Head2 == [] ->
2006 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
2007 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
2008 ;
2009 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2010 ).
2012 %% Generate code based on all the persistent heads of a CHR rule
2013 heads2_code([],_,_,_,_,_,Id,Id,L,L).
2014 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id1,Id3,L,T) :-
2015 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
2016 get_constraint(F/A,I),
2017 ( functor(Head,F,A),
2018 \+ is_passive(RuleNb,HeadID),
2019 \+ check_unnecessary_active(Head,RestHeads,Rule),
2020 \+ set_semantics_rule(PragmaRule),
2021 all_attached(Heads),
2022 all_attached(RestHeads),
2023 Rule = rule(Heads1,_,_,_),
2024 all_attached(Heads1) ->
2025 append(Heads,RestHeads,OtherHeads),
2026 append(HeadIDs,RestIDs,OtherIDs),
2027 length(Heads,RestHeadNb),
2028 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,F/A,Id1,L,L0),
2029 inc_id(Id1,Id2),
2030 gen_alloc_inc_clause(F/A,Id1,L0,L1)
2031 ;
2032 L = L1,
2033 Id2 = Id1
2034 ),
2035 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id2,Id3,L1,T).
2037 %% Generate code based on one persistent head of a CHR rule
2038 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,FA,Id,L,T) :-
2039 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2040 Rule = rule(Head1,_,_,_),
2041 ( Head1 == [] ->
2042 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,_),
2043 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
2044 ;
2045 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2046 ).
2048 gen_alloc_inc_clause(F/A,Id,L,T) :-
2049 vars_susp(A,Vars,Susp,VarsSusp),
2050 build_head(F,A,Id,VarsSusp,Head),
2051 inc_id(Id,IncId),
2052 build_head(F,A,IncId,VarsSusp,CallHead),
2053 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,ConditionalAlloc),
2054 Clause =
2055 (
2056 Head :-
2057 ConditionalAlloc,
2058 CallHead
2059 ),
2060 L = [Clause|T].
2062 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2063 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
2064 ConstraintAllocationGoal =
2065 ( var(Susp) ->
2066 UncondConstraintAllocationGoal
2067 ;
2068 true
2069 ).
2070 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
2071 build_head(F,A,[0],VarsSusp,Term),
2072 get_target_module(Mod),
2073 FTerm =.. [F|Vars],
2074 ConstraintAllocationGoal = allocate_constraint(Mod : Term, Susp, FTerm, Vars).
2076 gen_allocation(Id,Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2077 ( Id == [0] ->
2078 ( is_attached(FA) ->
2079 ( may_trigger(FA) ->
2080 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2081 ;
2082 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2083 )
2084 ;
2085 ConstraintAllocationGoal = true
2086 )
2087 ;
2088 ConstraintAllocationGoal = true
2089 ).
2090 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2093 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2095 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
2096 ( chr_pp_flag(guard_via_reschedule,on) ->
2097 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
2098 ;
2099 append(Retrievals,GuardList,GoalList),
2100 list2conj(GoalList,Goal)
2101 ).
2103 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
2104 initialize_unit_dictionary(Prelude,Dict),
2105 build_units(Retrievals,GuardList,Dict,Units),
2106 dependency_reorder(Units,NUnits),
2107 units2goal(NUnits,Goal).
2109 units2goal([],true).
2110 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
2111 units2goal(Units,Goals).
2113 dependency_reorder(Units,NUnits) :-
2114 dependency_reorder(Units,[],NUnits).
2116 dependency_reorder([],Acc,Result) :-
2117 reverse(Acc,Result).
2119 dependency_reorder([Unit|Units],Acc,Result) :-
2120 Unit = unit(_GID,_Goal,Type,GIDs),
2121 ( Type == fixed ->
2122 NAcc = [Unit|Acc]
2123 ;
2124 dependency_insert(Acc,Unit,GIDs,NAcc)
2125 ),
2126 dependency_reorder(Units,NAcc,Result).
2128 dependency_insert([],Unit,_,[Unit]).
2129 dependency_insert([X|Xs],Unit,GIDs,L) :-
2130 X = unit(GID,_,_,_),
2131 ( memberchk(GID,GIDs) ->
2132 L = [Unit,X|Xs]
2133 ;
2134 L = [X | T],
2135 dependency_insert(Xs,Unit,GIDs,T)
2136 ).
2138 build_units(Retrievals,Guard,InitialDict,Units) :-
2139 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
2140 build_guard_units(Guard,N,Dict,Tail).
2142 build_retrieval_units([],N,N,Dict,Dict,L,L).
2143 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
2144 term_variables(U,Vs),
2145 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2146 L = [unit(N,U,movable,GIDs)|L1],
2147 N1 is N + 1,
2148 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
2150 build_retrieval_units2([],N,N,Dict,Dict,L,L).
2151 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
2152 term_variables(U,Vs),
2153 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2154 L = [unit(N,U,fixed,GIDs)|L1],
2155 N1 is N + 1,
2156 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
2158 initialize_unit_dictionary(Term,Dict) :-
2159 term_variables(Term,Vars),
2160 pair_all_with(Vars,0,Dict).
2162 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
2163 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2164 ( lookup_eq(Dict,V,GID) ->
2165 ( (GID == This ; memberchk(GID,GIDs) ) ->
2166 GIDs1 = GIDs
2167 ;
2168 GIDs1 = [GID|GIDs]
2169 ),
2170 Dict1 = Dict
2171 ;
2172 Dict1 = [V - This|Dict],
2173 GIDs1 = GIDs
2174 ),
2175 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2177 build_guard_units(Guard,N,Dict,Units) :-
2178 ( Guard = [Goal] ->
2179 Units = [unit(N,Goal,fixed,[])]
2180 ; Guard = [Goal|Goals] ->
2181 term_variables(Goal,Vs),
2182 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
2183 Units = [unit(N,Goal,movable,GIDs)|RUnits],
2184 N1 is N + 1,
2185 build_guard_units(Goals,N1,NDict,RUnits)
2186 ).
2188 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
2189 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2190 ( lookup_eq(Dict,V,GID) ->
2191 ( (GID == This ; memberchk(GID,GIDs) ) ->
2192 GIDs1 = GIDs
2193 ;
2194 GIDs1 = [GID|GIDs]
2195 ),
2196 Dict1 = [V - This|Dict]
2197 ;
2198 Dict1 = [V - This|Dict],
2199 GIDs1 = GIDs
2200 ),
2201 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2203 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2205 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2206 %% ____ _ ____ _ _
2207 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
2208 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
2209 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
2210 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
2211 %%
2212 %% _ _ _ ___ __
2213 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
2214 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
2215 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
2216 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
2217 %% |_|
2218 unique_analyse_optimise(Rules,NRules) :-
2219 ( chr_pp_flag(unique_analyse_optimise,on) ->
2220 unique_analyse_optimise_main(Rules,1,[],NRules)
2221 ;
2222 NRules = Rules
2223 ).
2225 unique_analyse_optimise_main([],_,_,[]).
2226 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
2227 ( discover_unique_pattern(PRule,N,Pattern) ->
2228 NPatternList = [Pattern|PatternList]
2229 ;
2230 NPatternList = PatternList
2231 ),
2232 PRule = pragma(Rule,Ids,Pragmas,Name,RuleNb),
2233 Rule = rule(H1,H2,_,_),
2234 Ids = ids(Ids1,Ids2),
2235 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
2236 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
2237 globalize_unique_pragmas(MorePragmas1,RuleNb),
2238 globalize_unique_pragmas(MorePragmas2,RuleNb),
2239 append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
2240 NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb),
2241 N1 is N + 1,
2242 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
2244 globalize_unique_pragmas([],_).
2245 globalize_unique_pragmas([unique(ID,Vars)|R],RuleNb) :-
2246 pragma_unique(RuleNb,ID,Vars),
2247 globalize_unique_pragmas(R,RuleNb).
2249 apply_unique_patterns_to_constraints([],_,_,[]).
2250 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
2251 ( member(Pattern,Patterns),
2252 apply_unique_pattern(C,Id,Pattern,Pragma) ->
2253 Pragmas = [Pragma | RPragmas]
2254 ;
2255 Pragmas = RPragmas
2256 ),
2257 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
2259 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
2260 Pattern = unique(PatternConstraint,PatternKey),
2261 subsumes(Constraint,PatternConstraint,Unifier),
2262 ( setof( V,
2263 T^Term^Vs^(
2264 member(T,PatternKey),
2265 lookup_eq(Unifier,T,Term),
2266 term_variables(Term,Vs),
2267 member(V,Vs)
2268 ),
2269 Vars) ->
2270 true
2271 ;
2272 Vars = []
2273 ),
2274 Pragma = unique(Id,Vars).
2276 % subsumes(+Term1, +Term2, -Unifier)
2277 %
2278 % If Term1 is a more general term than Term2 (e.g. has a larger
2279 % part instantiated), unify Unifier with a list Var-Value of
2280 % variables from Term2 and their corresponding values in Term1.
2282 subsumes(Term1,Term2,Unifier) :-
2283 empty_assoc(S0),
2284 subsumes_aux(Term1,Term2,S0,S),
2285 assoc_to_list(S,L),
2286 build_unifier(L,Unifier).
2288 subsumes_aux(Term1, Term2, S0, S) :-
2289 ( compound(Term2),
2290 functor(Term2, F, N)
2291 -> compound(Term1), functor(Term1, F, N),
2292 subsumes_aux(N, Term1, Term2, S0, S)
2293 ; Term1 == Term2
2294 -> S = S0
2295 ; var(Term2),
2296 get_assoc(Term1,S0,V)
2297 -> V == Term2, S = S0
2298 ; var(Term2),
2299 put_assoc(Term1, S0, Term2, S)
2300 ).
2302 subsumes_aux(0, _, _, S, S) :- ! .
2303 subsumes_aux(N, T1, T2, S0, S) :-
2304 arg(N, T1, T1x),
2305 arg(N, T2, T2x),
2306 subsumes_aux(T1x, T2x, S0, S1),
2307 M is N-1,
2308 subsumes_aux(M, T1, T2, S1, S).
2310 build_unifier([],[]).
2311 build_unifier([X-V|R],[V - X | T]) :-
2312 build_unifier(R,T).
2314 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
2315 PragmaRule = pragma(Rule,_,_Pragmas,Name,RuleNb),
2316 Rule = rule(H1,H2,Guard,_),
2317 ( H1 = [C1],
2318 H2 = [C2] ->
2319 true
2320 ; H1 = [C1,C2],
2321 H2 == [] ->
2322 true
2323 ),
2324 check_unique_constraints(C1,C2,Guard,RuleNb,List),
2325 term_variables(C1,Vs),
2326 select_pragma_unique_variables(List,Vs,Key),
2327 Pattern0 = unique(C1,Key),
2328 copy_term(Pattern0,Pattern),
2329 ( prolog_flag(verbose,V), V == yes ->
2330 format('Found unique pattern ~w in rule ~d~@\n',
2331 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
2332 ;
2333 true
2334 ).
2336 select_pragma_unique_variables([],_,[]).
2337 select_pragma_unique_variables([X-Y|R],Vs,L) :-
2338 ( X == Y ->
2339 L = [X|T]
2340 ;
2341 once((
2342 \+ memberchk_eq(X,Vs)
2343 ;
2344 \+ memberchk_eq(Y,Vs)
2345 )),
2346 L = T
2347 ),
2348 select_pragma_unique_variables(R,Vs,T).
2350 check_unique_constraints(C1,C2,G,RuleNb,List) :-
2351 \+ any_passive_head(RuleNb),
2352 variable_replacement(C1-C2,C2-C1,List),
2353 copy_with_variable_replacement(G,OtherG,List),
2354 negate_b(G,NotG),
2355 once(entails_b(NotG,OtherG)).
2357 check_unnecessary_active(Constraint,Previous,Rule) :-
2358 ( chr_pp_flag(check_unnecessary_active,full) ->
2359 check_unnecessary_active_main(Constraint,Previous,Rule)
2360 ; chr_pp_flag(check_unnecessary_active,simplification),
2361 Rule = rule(_,[],_,_) ->
2362 check_unnecessary_active_main(Constraint,Previous,Rule)
2363 ;
2364 fail
2365 ).
2367 check_unnecessary_active_main(Constraint,Previous,Rule) :-
2368 member(Other,Previous),
2369 variable_replacement(Other,Constraint,List),
2370 copy_with_variable_replacement(Rule,Rule2,List),
2371 identical_rules(Rule,Rule2), ! .
2373 set_semantics_rule(PragmaRule) :-
2374 ( chr_pp_flag(set_semantics_rule,on) ->
2375 set_semantics_rule_main(PragmaRule)
2376 ;
2377 fail
2378 ).
2380 set_semantics_rule_main(PragmaRule) :-
2381 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
2382 Rule = rule([C1],[C2],true,_),
2383 IDs = ids([ID1],[ID2]),
2384 once(member(unique(ID1,L1),Pragmas)),
2385 once(member(unique(ID2,L2),Pragmas)),
2386 L1 == L2,
2387 \+ is_passive(RuleNb,ID1).
2388 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2391 %% ____ _ _____ _ _
2392 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
2393 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
2394 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
2395 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
2396 %% |_|
2397 % have to check for no duplicates in value list
2399 % check wether two rules are identical
2401 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
2402 G1 == G2,
2403 identical_bodies(B1,B2),
2404 permutation(H11,P1),
2405 P1 == H12,
2406 permutation(H21,P2),
2407 P2 == H22.
2409 identical_bodies(B1,B2) :-
2410 ( B1 = (X1 = Y1),
2411 B2 = (X2 = Y2) ->
2412 ( X1 == X2,
2413 Y1 == Y2
2414 ; X1 == Y2,
2415 X2 == Y1
2416 ),
2417 !
2418 ; B1 == B2
2419 ).
2421 % replace variables in list
2423 copy_with_variable_replacement(X,Y,L) :-
2424 ( var(X) ->
2425 ( lookup_eq(L,X,Y) ->
2426 true
2427 ; X = Y
2428 )
2429 ; functor(X,F,A),
2430 functor(Y,F,A),
2431 X =.. [_|XArgs],
2432 Y =.. [_|YArgs],
2433 copy_with_variable_replacement_l(XArgs,YArgs,L)
2434 ).
2436 copy_with_variable_replacement_l([],[],_).
2437 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
2438 copy_with_variable_replacement(X,Y,L),
2439 copy_with_variable_replacement_l(Xs,Ys,L).
2441 %% build variable replacement list
2443 variable_replacement(X,Y,L) :-
2444 variable_replacement(X,Y,[],L).
2446 variable_replacement(X,Y,L1,L2) :-
2447 ( var(X) ->
2448 var(Y),
2449 ( lookup_eq(L1,X,Z) ->
2450 Z == Y,
2451 L2 = L1
2452 ; L2 = [X-Y|L1]
2453 )
2454 ; X =.. [F|XArgs],
2455 nonvar(Y),
2456 Y =.. [F|YArgs],
2457 variable_replacement_l(XArgs,YArgs,L1,L2)
2458 ).
2460 variable_replacement_l([],[],L,L).
2461 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
2462 variable_replacement(X,Y,L1,L2),
2463 variable_replacement_l(Xs,Ys,L2,L3).
2464 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2466 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2467 %% ____ _ _ _ __ _ _ _
2468 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
2469 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
2470 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
2471 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
2472 %% |_|
2474 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
2475 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
2476 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2477 build_head(F,A,Id,HeadVars,ClauseHead),
2478 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2480 ( RestHeads == [] ->
2481 Susps = [],
2482 VarDict = VarDict1,
2483 GetRestHeads = []
2484 ;
2485 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
2486 ),
2488 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2489 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2491 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
2492 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2494 ( chr_pp_flag(debugable,on) ->
2495 Rule = rule(_,_,Guard,Body),
2496 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2497 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
2498 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
2499 ;
2500 DebugTry = true,
2501 DebugApply = true
2502 ),
2504 Clause = ( ClauseHead :-
2505 FirstMatching,
2506 RescheduledTest,
2507 DebugTry,
2508 !,
2509 DebugApply,
2510 SuspsDetachments,
2511 SuspDetachment,
2512 BodyCopy
2513 ),
2514 L = [Clause | T].
2516 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
2517 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
2518 list2conj(GoalList,Goal).
2520 head_arg_matches_([],VarDict,[],VarDict).
2521 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
2522 ( var(Arg) ->
2523 ( lookup_eq(VarDict,Arg,OtherVar) ->
2524 GoalList = [Var == OtherVar | RestGoalList],
2525 VarDict1 = VarDict
2526 ; VarDict1 = [Arg-Var | VarDict],
2527 GoalList = RestGoalList
2528 ),
2529 Pairs = Rest
2530 ; atomic(Arg) ->
2531 GoalList = [ Var == Arg | RestGoalList],
2532 VarDict = VarDict1,
2533 Pairs = Rest
2534 ; Arg =.. [_|Args],
2535 functor(Arg,Fct,N),
2536 functor(Term,Fct,N),
2537 Term =.. [_|Vars],
2538 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
2539 pairup(Args,Vars,NewPairs),
2540 append(NewPairs,Rest,Pairs),
2541 VarDict1 = VarDict
2542 ),
2543 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
2545 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
2546 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
2548 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
2549 ( Heads = [_|_] ->
2550 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
2551 ;
2552 GoalList = [],
2553 Susps = [],
2554 VarDict = NVarDict
2555 ).
2557 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
2558 instantiate_pattern_goals(AttrDict).
2559 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
2560 functor(H,F,A),
2561 get_store_type(F/A,StoreType),
2562 ( StoreType == default ->
2563 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
2564 get_max_constraint_index(N),
2565 ( N == 1 ->
2566 VarSusps = Attr
2567 ;
2568 get_constraint_index(F/A,Pos),
2569 make_attr(N,_Mask,SuspsList,Attr),
2570 nth(Pos,SuspsList,VarSusps)
2571 )
2572 ;
2573 lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
2574 NewAttrDict = AttrDict
2575 ),
2576 head_info(H,A,Vars,_,_,Pairs),
2577 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
2578 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
2579 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
2580 create_get_mutable(active,State,GetMutable),
2581 Goal1 =
2582 (
2583 'chr sbag_member'(Susp,VarSusps),
2584 Susp = Suspension,
2585 GetMutable,
2586 DiffSuspGoals,
2587 MatchingGoal
2588 ),
2589 ( member(unique(ID,UniqueKeus),Pragmas),
2590 check_unique_keys(UniqueKeus,VarDict) ->
2591 Goal = (Goal1 -> true)
2592 ;
2593 Goal = Goal1
2594 ),
2595 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
2597 instantiate_pattern_goals([]).
2598 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
2599 get_max_constraint_index(N),
2600 ( N == 1 ->
2601 Goal = true
2602 ;
2603 make_attr(N,Mask,_,Attr),
2604 or_list(Bits,Pattern), !,
2605 Goal = (Mask /\ Pattern =:= Pattern)
2606 ),
2607 instantiate_pattern_goals(Rest).
2610 check_unique_keys([],_).
2611 check_unique_keys([V|Vs],Dict) :-
2612 lookup_eq(Dict,V,_),
2613 check_unique_keys(Vs,Dict).
2615 % Generates tests to ensure the found constraint differs from previously found constraints
2616 % TODO: detect more cases where constraints need be different
2617 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
2618 ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
2619 list2conj(DiffSuspGoalList,DiffSuspGoals)
2620 ;
2621 DiffSuspGoals = true
2622 ).
2624 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
2625 functor(Head,F,A),
2626 get_constraint_index(F/A,Pos),
2627 common_variables(Head,PrevHeads,CommonVars),
2628 translate(CommonVars,VarDict,Vars),
2629 or_pattern(Pos,Bit),
2630 ( permutation(Vars,PermutedVars),
2631 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
2632 member(Bit,Positions), !,
2633 NewAttrDict = AttrDict,
2634 Goal = true
2635 ;
2636 Goal = (Goal1, PatternGoal),
2637 gen_get_mod_constraints(Vars,Goal1,Attr),
2638 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
2639 ).
2641 common_variables(T,Ts,Vs) :-
2642 term_variables(T,V1),
2643 term_variables(Ts,V2),
2644 intersect_eq(V1,V2,Vs).
2646 gen_get_mod_constraints(L,Goal,Susps) :-
2647 get_target_module(Mod),
2648 ( L == [] ->
2649 Goal =
2650 ( 'chr global_term_ref_1'(Global),
2651 get_attr(Global,Mod,TSusps),
2652 TSusps = Susps
2653 )
2654 ;
2655 ( L = [A] ->
2656 VIA = 'chr via_1'(A,V)
2657 ; ( L = [A,B] ->
2658 VIA = 'chr via_2'(A,B,V)
2659 ; VIA = 'chr via'(L,V)
2660 )
2661 ),
2662 Goal =
2663 ( VIA,
2664 get_attr(V,Mod,TSusps),
2665 TSusps = Susps
2666 )
2667 ).
2669 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
2670 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2671 list2conj(GuardCopyList,GuardCopy).
2673 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
2674 Rule = rule(_,_,Guard,Body),
2675 conj2list(Guard,GuardList),
2676 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
2677 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
2679 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
2680 term_variables(RestGuardList,GuardVars),
2681 term_variables(RestGuardListCopyCore,GuardCopyVars),
2682 ( chr_pp_flag(guard_locks,on),
2683 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
2684 X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
2685 lookup_eq(VarDict,X,Y), % translate X into new variable
2686 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
2687 ),
2688 LocksUnlocks) ->
2689 once(pairup(Locks,Unlocks,LocksUnlocks))
2690 ;
2691 Locks = [],
2692 Unlocks = []
2693 ),
2694 list2conj(Locks,LockPhase),
2695 list2conj(Unlocks,UnlockPhase),
2696 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
2697 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
2698 my_term_copy(Body,VarDict2,BodyCopy).
2701 split_off_simple_guard([],_,[],[]).
2702 split_off_simple_guard([G|Gs],VarDict,S,C) :-
2703 ( simple_guard(G,VarDict) ->
2704 S = [G|Ss],
2705 split_off_simple_guard(Gs,VarDict,Ss,C)
2706 ;
2707 S = [],
2708 C = [G|Gs]
2709 ).
2711 % simple guard: cheap and benign (does not bind variables)
2712 simple_guard(G,VarDict) :-
2713 binds_b(G,Vars),
2714 \+ (( member(V,Vars),
2715 lookup_eq(VarDict,V,_)
2716 )).
2718 my_term_copy(X,Dict,Y) :-
2719 my_term_copy(X,Dict,_,Y).
2721 my_term_copy(X,Dict1,Dict2,Y) :-
2722 ( var(X) ->
2723 ( lookup_eq(Dict1,X,Y) ->
2724 Dict2 = Dict1
2725 ; Dict2 = [X-Y|Dict1]
2726 )
2727 ; functor(X,XF,XA),
2728 functor(Y,XF,XA),
2729 X =.. [_|XArgs],
2730 Y =.. [_|YArgs],
2731 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
2732 ).
2734 my_term_copy_list([],Dict,Dict,[]).
2735 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
2736 my_term_copy(X,Dict1,Dict2,Y),
2737 my_term_copy_list(Xs,Dict2,Dict3,Ys).
2739 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
2740 ( is_attached(FA) ->
2741 ( Id == [0], \+ may_trigger(FA) ->
2742 SuspDetachment = true
2743 ;
2744 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
2745 SuspDetachment =
2746 ( var(Susp) ->
2747 true
2748 ; UnCondSuspDetachment
2749 )
2750 )
2751 ;
2752 SuspDetachment = true
2753 ).
2755 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
2756 ( is_attached(FA) ->
2757 ( may_trigger(FA) ->
2758 make_name('detach_',FA,Fct),
2759 Detach =.. [Fct,Vars,Susp]
2760 ;
2761 Detach = true
2762 ),
2763 ( chr_pp_flag(debugable,on) ->
2764 DebugEvent = 'chr debug_event'(remove(Susp))
2765 ;
2766 DebugEvent = true
2767 ),
2768 generate_delete_constraint_call(FA,Susp,DeleteCall),
2769 SuspDetachment =
2770 (
2771 DebugEvent,
2772 remove_constraint_internal(Susp, Vars, Delete),
2773 ( Delete == yes ->
2774 DeleteCall,
2775 Detach
2776 ;
2777 true
2778 )
2779 )
2780 ;
2781 SuspDetachment = true
2782 ).
2784 gen_uncond_susps_detachments([],[],true).
2785 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
2786 functor(Term,F,A),
2787 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
2788 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
2790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2792 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2793 %% ____ _ _ _ _
2794 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
2795 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
2796 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
2797 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
2798 %% |_| |___/
2800 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
2801 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
2802 Rule = rule(_Heads,Heads2,Guard,Body),
2804 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2805 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2807 build_head(F,A,Id,HeadVars,ClauseHead),
2809 append(RestHeads,Heads2,Heads),
2810 append(OtherIDs,Heads2IDs,IDs),
2811 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
2812 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
2813 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
2815 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2816 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2818 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
2819 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2821 ( chr_pp_flag(debugable,on) ->
2822 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2823 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
2824 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
2825 ;
2826 DebugTry = true,
2827 DebugApply = true
2828 ),
2830 Clause = ( ClauseHead :-
2831 FirstMatching,
2832 RescheduledTest,
2833 DebugTry,
2834 !,
2835 DebugApply,
2836 SuspsDetachments,
2837 SuspDetachment,
2838 BodyCopy
2839 ),
2840 L = [Clause | T].
2842 split_by_ids([],[],_,[],[]).
2843 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
2844 ( memberchk_eq(I,I1s) ->
2845 S1s = [S | R1s],
2846 S2s = R2s
2847 ;
2848 S1s = R1s,
2849 S2s = [S | R2s]
2850 ),
2851 split_by_ids(Is,Ss,I1s,R1s,R2s).
2853 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2856 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2857 %% ____ _ _ _ ____
2858 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
2859 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
2860 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
2861 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
2862 %% |_| |___/
2864 %% Genereate prelude + worker predicate
2865 %% prelude calls worker
2866 %% worker iterates over one type of removed constraints
2867 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
2868 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name,RuleNb),
2869 Rule = rule(Heads1,_,Guard,Body),
2870 reorder_heads(RuleNb,Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
2871 % IDs1 = [ID1|RestIDs1],
2872 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
2873 extend_id(Id,Id2),
2874 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,PragmaRule,FA,Id2,L1,T).
2876 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2877 simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
2878 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2879 build_head(F,A,Id1,VarsSusp,ClauseHead),
2880 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
2882 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
2884 gen_allocation(Id1,Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal),
2886 extend_id(Id1,DelegateId),
2887 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2888 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
2889 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
2891 PreludeClause =
2892 ( ClauseHead :-
2893 FirstMatching,
2894 ModConstraintsGoal,
2895 !,
2896 ConstraintAllocationGoal,
2897 Delegate
2898 ),
2899 L = [PreludeClause|T].
2901 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
2902 Term =.. [_|Args],
2903 delegate_variables(Term,Terms,VarDict,Args,Vars).
2905 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
2906 term_variables(PrevTerms,PrevVars),
2907 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
2909 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
2910 term_variables(Term,V1),
2911 term_variables(Terms,V2),
2912 intersect_eq(V1,V2,V3),
2913 list_difference_eq(V3,PrevVars,V4),
2914 translate(V4,VarDict,Vars).
2917 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2918 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L,T) :-
2919 PragmaRule = pragma(Rule,_,_,_,_),
2920 Rule = rule(_,_,Guard,Body),
2921 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
2922 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L1,T).
2924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2925 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,F/A,Id,L,T) :-
2926 gen_var(OtherSusp),
2927 gen_var(OtherSusps),
2929 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
2930 head_arg_matches(Head2Pairs,[],_,VarDict1),
2932 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
2933 Rule = rule(_,_,Guard,Body),
2934 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
2935 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
2936 build_head(F,A,Id,HeadVars,ClauseHead),
2938 functor(Head1,_OtherF,OtherA),
2939 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
2940 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
2942 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
2943 create_get_mutable(active,OtherState,GetMutable),
2944 IteratorSuspTest =
2945 ( OtherSusp = OtherSuspension,
2946 GetMutable
2947 ),
2949 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
2950 append(RestHeads1,RestHeads2,RestHeads),
2951 append(IDs1,IDs2,IDs),
2952 reorder_heads(RuleNb,Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
2953 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
2954 split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
2955 ; RestSuspsRetrieval = [],
2956 Susps1 = [],
2957 Susps2 = [],
2958 VarDict = VarDict2
2959 ),
2961 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
2963 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
2964 build_head(F,A,Id,RecursiveVars,RecursiveCall),
2965 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
2966 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
2968 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2969 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
2970 ( BodyCopy \== true ->
2971 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2972 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2973 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
2974 ; Attachment = true,
2975 ConditionalRecursiveCall = RecursiveCall,
2976 ConditionalRecursiveCall2 = RecursiveCall2
2977 ),
2979 ( chr_pp_flag(debugable,on) ->
2980 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2981 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
2982 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
2983 ;
2984 DebugTry = true,
2985 DebugApply = true
2986 ),
2988 ( member(unique(ID1,UniqueKeys), Pragmas),
2989 check_unique_keys(UniqueKeys,VarDict1) ->
2990 Clause =
2991 ( ClauseHead :-
2992 ( IteratorSuspTest,
2993 FirstMatching ->
2994 ( RescheduledTest,
2995 DebugTry ->
2996 DebugApply,
2997 Susps1Detachments,
2998 Attachment,
2999 BodyCopy,
3000 ConditionalRecursiveCall2
3001 ;
3002 RecursiveCall2
3003 )
3004 ;
3005 RecursiveCall
3006 )
3007 )
3008 ;
3009 Clause =
3010 ( ClauseHead :-
3011 ( IteratorSuspTest,
3012 FirstMatching,
3013 RescheduledTest,
3014 DebugTry ->
3015 DebugApply,
3016 Susps1Detachments,
3017 Attachment,
3018 BodyCopy,
3019 ConditionalRecursiveCall
3020 ;
3021 RecursiveCall
3022 )
3023 )
3024 ),
3025 L = [Clause | T].
3027 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
3028 length(Args,N),
3029 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
3030 create_get_mutable(active,State,GetState),
3031 create_get_mutable(Generation,NewGeneration,GetGeneration),
3032 ConditionalCall =
3033 ( Susp = Suspension,
3034 GetState,
3035 GetGeneration ->
3036 'chr update_mutable'(inactive,State),
3037 Call
3038 ; true
3039 ).
3041 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3042 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
3043 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
3044 head_arg_matches(Pairs,[],_,VarDict),
3045 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
3046 append([[]|VarsSusp],ExtraVars,HeadVars),
3047 build_head(F,A,Id,HeadVars,ClauseHead),
3048 next_id(Id,ContinuationId),
3049 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
3050 Clause = ( ClauseHead :- ContinuationHead ),
3051 L = [Clause | T].
3053 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3056 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3057 %% ____ _ _
3058 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
3059 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
3060 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
3061 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
3062 %% |_| |___/
3064 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3065 ( RestHeads == [] ->
3066 propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
3067 ;
3068 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
3069 ).
3070 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3071 %% Single headed propagation
3072 %% everything in a single clause
3073 propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
3074 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3075 build_head(F,A,Id,VarsSusp,ClauseHead),
3077 inc_id(Id,NextId),
3078 build_head(F,A,NextId,VarsSusp,NextHead),
3080 NextCall = NextHead,
3082 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
3083 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3084 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,Allocation),
3085 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
3087 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
3089 ( chr_pp_flag(debugable,on) ->
3090 Rule = rule(_,_,Guard,Body),
3091 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3092 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
3093 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
3094 ;
3095 DebugTry = true,
3096 DebugApply = true
3097 ),
3099 Clause = (
3100 ClauseHead :-
3101 HeadMatching,
3102 Allocation,
3103 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
3104 GuardCopy,
3105 DebugTry,
3106 !,
3107 DebugApply,
3108 'chr extend_history'(Susp,RuleNb),
3109 Attachment,
3110 BodyCopy,
3111 ConditionalNextCall
3112 ),
3113 L = [Clause | T].
3115 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3116 %% multi headed propagation
3117 %% prelude + predicates to accumulate the necessary combinations of suspended
3118 %% constraints + predicate to execute the body
3119 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3120 RestHeads = [First|Rest],
3121 propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
3122 extend_id(Id,ExtendedId),
3123 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
3125 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3126 propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
3127 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3128 build_head(F,A,Id,VarsSusp,PreludeHead),
3129 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
3130 Rule = rule(_,_,Guard,Body),
3131 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
3133 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
3135 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,CondAllocation),
3137 extend_id(Id,NestedId),
3138 append([Susps|VarsSusp],ExtraVars,NestedVars),
3139 build_head(F,A,NestedId,NestedVars,NestedHead),
3140 NestedCall = NestedHead,
3142 Prelude = (
3143 PreludeHead :-
3144 FirstMatching,
3145 FirstSuspGoal,
3146 !,
3147 CondAllocation,
3148 NestedCall
3149 ),
3150 L = [Prelude|T].
3152 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3153 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3154 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
3155 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
3157 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3158 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
3159 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
3160 inc_id(Id,IncId),
3161 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
3163 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
3164 Rule = rule(_,_,Guard,Body),
3165 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
3166 gen_var(OtherSusp),
3167 gen_var(OtherSusps),
3168 functor(CurrentHead,_OtherF,OtherA),
3169 gen_vars(OtherA,OtherVars),
3170 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3171 create_get_mutable(active,State,GetMutable),
3172 CurrentSuspTest = (
3173 OtherSusp = Suspension,
3174 GetMutable
3175 ),
3176 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3177 build_head(F,A,Id,ClauseVars,ClauseHead),
3178 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3179 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3180 RecursiveCall = RecursiveHead,
3181 CurrentHead =.. [_|OtherArgs],
3182 pairup(OtherArgs,OtherVars,OtherPairs),
3183 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
3185 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
3187 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3188 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
3189 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
3191 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
3192 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
3193 list2conj(NovelProductionsList,NovelProductions),
3194 Tuple =.. [t,RuleNb|HistorySusps],
3196 ( chr_pp_flag(debugable,on) ->
3197 Rule = rule(_,_,Guard,Body),
3198 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3199 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
3200 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
3201 ;
3202 DebugTry = true,
3203 DebugApply = true
3204 ),
3206 Clause = (
3207 ClauseHead :-
3208 ( CurrentSuspTest,
3209 DiffSuspGoals,
3210 Matching,
3211 TupleVar = Tuple,
3212 NovelProductions,
3213 GuardCopy,
3214 DebugTry ->
3215 DebugApply,
3216 'chr extend_history'(Susp,TupleVar),
3217 Attach,
3218 BodyCopy,
3219 ConditionalRecursiveCall
3220 ; RecursiveCall
3221 )
3222 ),
3223 L = [Clause|T].
3225 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
3226 ( Count == 0 ->
3227 reverse(OtherSusps,ReversedSusps),
3228 append(ReversedSusps,[Susp|Acc],HistorySusps)
3229 ;
3230 OtherSusps = [OtherSusp|RestOtherSusps],
3231 NCount is Count - 1,
3232 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
3233 ).
3235 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
3236 !,
3237 functor(Head,_F,A),
3238 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
3239 head_arg_matches(Pairs,[],_,VarDict),
3240 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3241 append(VarsSusp,ExtraVars,HeadVars).
3242 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
3243 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
3244 functor(Head,_F,A),
3245 gen_var(Susps),
3246 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
3247 head_arg_matches(Pairs,VarDict,_,NVarDict),
3248 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3249 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
3251 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
3252 Rule = rule(_,_,Guard,Body),
3253 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
3255 Vars = [ [] | VarsAndSusps],
3257 build_head(F,A,Id,Vars,Head),
3259 ( Id = [0|_] ->
3260 next_id(Id,PrevId),
3261 PrevVarsAndSusps = AllButFirst
3262 ;
3263 dec_id(Id,PrevId),
3264 PrevVarsAndSusps = [FirstSusp|AllButFirst]
3265 ),
3267 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
3268 PredecessorCall = PrevHead,
3270 Clause = (
3271 Head :-
3272 PredecessorCall
3273 ),
3274 L = [Clause | T].
3276 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
3277 !,
3278 functor(Head,_F,A),
3279 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
3280 head_arg_matches(HeadPairs,[],_,VarDict),
3281 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3282 append(VarsSusp,ExtraVars,HeadVars).
3283 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
3284 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
3285 functor(Head,_F,A),
3286 gen_var(Susps),
3287 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3288 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3289 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3290 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
3292 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
3293 Rule = rule(_,_,Guard,Body),
3294 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
3295 gen_var(OtherSusps),
3296 functor(CurrentHead,_OtherF,OtherA),
3297 gen_vars(OtherA,OtherVars),
3298 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
3299 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
3301 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3303 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
3304 create_get_mutable(active,State,GetMutable),
3305 CurrentSuspTest = (
3306 OtherSusp = OtherSuspension,
3307 GetMutable,
3308 DiffSuspGoals,
3309 FirstMatching
3310 ),
3311 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
3312 inc_id(Id,NestedId),
3313 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3314 build_head(F,A,Id,ClauseVars,ClauseHead),
3315 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
3316 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
3317 build_head(F,A,NestedId,NestedVars,NestedHead),
3319 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3320 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3321 Clause = (
3322 ClauseHead :-
3323 ( CurrentSuspTest,
3324 NextSuspGoal
3325 ->
3326 NestedHead
3327 ; RecursiveHead
3328 )
3329 ),
3330 L = [Clause|T].
3332 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
3333 !,
3334 functor(Head,_F,A),
3335 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
3336 head_arg_matches(HeadPairs,[],_,VarDict),
3337 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3338 append(VarsSusp,ExtraVars,HeadVars).
3339 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
3340 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
3341 functor(Head,_F,A),
3342 gen_var(NextSusps),
3343 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3344 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3345 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3346 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
3348 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3350 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3351 %% ____ _ _ _ _
3352 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
3353 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
3354 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
3355 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
3356 %%
3357 %% ____ _ _ _
3358 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
3359 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
3360 %% | _ < __/ |_| | | | __/\ V / (_| | |
3361 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
3362 %%
3363 %% ____ _ _
3364 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
3365 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
3366 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
3367 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
3368 %% |___/
3370 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3371 ( chr_pp_flag(reorder_heads,on) ->
3372 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
3373 ;
3374 NRestHeads = RestHeads,
3375 NRestIDs = RestIDs
3376 ).
3378 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3379 term_variables(Head,Vars),
3380 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
3381 a_star(InitialData,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
3382 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
3383 reverse(RNRestHeads,NRestHeads),
3384 reverse(RNRestIDs,NRestIDs).
3386 final_data(Entry) :-
3387 Entry = entry(_,_,_,_,[],_).
3389 expand_data(Entry,NEntry,Cost) :-
3390 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
3391 term_variables(Entry,EVars),
3392 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
3393 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
3394 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost),
3395 term_variables([Head1|Vars],Vars1).
3397 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3398 functor(Head,F,A),
3399 get_store_type(F/A,StoreType),
3400 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
3402 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3403 term_variables(Head,HeadVars),
3404 term_variables(RestHeads,RestVars),
3405 order_score_vars(HeadVars,KnownVars,RestHeads,0,Score).
3406 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3407 order_score_indexes(Indexes,Head,KnownVars,0,Score).
3408 order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :-
3409 functor(Head,F,A),
3410 ( get_pragma_unique(RuleNb,ID,Vars),
3411 Vars == [] ->
3412 Score = 1 % guaranteed O(1)
3413 ; A == 0 -> % flag constraint
3414 Score = 10 % O(1)? [CHECK: no deleted/triggered/... constraints in store?]
3415 ; A > 0 ->
3416 Score = 100
3417 ).
3419 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3420 find_with_var_identity(
3421 S,
3422 t(Head,KnownVars,RestHeads),
3423 ( member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
3424 Scores
3425 ),
3426 min_list(Scores,Score).
3429 order_score_indexes([],_,_,Score,Score) :-
3430 Score > 0.
3431 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
3432 multi_hash_key_args(I,Head,Args),
3433 ( forall(Arg,Args,hprolog:memberchk_eq(Arg,KnownVars)) ->
3434 Score1 is Score + 10
3435 ;
3436 Score1 = Score
3437 ),
3438 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
3440 order_score_vars([],_,_,Score,NScore) :-
3441 ( Score == 0 ->
3442 NScore = 0
3443 ;
3444 NScore = Score
3445 ).
3446 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
3447 ( memberchk_eq(V,KnownVars) ->
3448 TScore is Score + 10
3449 ; memberchk_eq(V,RestVars) ->
3450 TScore is Score + 100
3451 ;
3452 TScore = Score
3453 ),
3454 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
3456 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3457 %% ___ _ _ _
3458 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
3459 %% | || '_ \| | | '_ \| | '_ \ / _` |
3460 %% | || | | | | | | | | | | | | (_| |
3461 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
3462 %% |___/
3464 create_get_mutable(V,M,GM) :-
3465 GM = (M = mutable(V)).
3467 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3469 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3470 %% _ _ _ _ _ _ _
3471 %% | | | | |_(_) (_) |_ _ _
3472 %% | | | | __| | | | __| | | |
3473 %% | |_| | |_| | | | |_| |_| |
3474 %% \___/ \__|_|_|_|\__|\__, |
3475 %% |___/
3477 gen_var(_).
3478 gen_vars(N,Xs) :-
3479 length(Xs,N).
3481 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
3482 vars_susp(A,Vars,Susp,VarsSusp),
3483 Head =.. [_|Args],
3484 pairup(Args,Vars,HeadPairs).
3486 inc_id([N|Ns],[O|Ns]) :-
3487 O is N + 1.
3488 dec_id([N|Ns],[M|Ns]) :-
3489 M is N - 1.
3491 extend_id(Id,[0|Id]).
3493 next_id([_,N|Ns],[O|Ns]) :-
3494 O is N + 1.
3496 build_head(F,A,Id,Args,Head) :-
3497 buildName(F,A,Id,Name),
3498 Head =.. [Name|Args].
3500 buildName(Fct,Aty,List,Result) :-
3501 atom_concat(Fct, (/) ,FctSlash),
3502 atom_concat(FctSlash,Aty,FctSlashAty),
3503 buildName_(List,FctSlashAty,Result).
3505 buildName_([],Name,Name).
3506 buildName_([N|Ns],Name,Result) :-
3507 buildName_(Ns,Name,Name1),
3508 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
3509 atom_concat(NameDash,N,Result).
3511 vars_susp(A,Vars,Susp,VarsSusp) :-
3512 length(Vars,A),
3513 append(Vars,[Susp],VarsSusp).
3515 make_attr(N,Mask,SuspsList,Attr) :-
3516 length(SuspsList,N),
3517 Attr =.. [v,Mask|SuspsList].
3519 or_pattern(Pos,Pat) :-
3520 Pow is Pos - 1,
3521 Pat is 1 << Pow. % was 2 ** X
3523 and_pattern(Pos,Pat) :-
3524 X is Pos - 1,
3525 Y is 1 << X, % was 2 ** X
3526 Pat is (-1)*(Y + 1). % because fx (-) is redefined
3528 conj2list(Conj,L) :- %% transform conjunctions to list
3529 conj2list(Conj,L,[]).
3531 conj2list(Conj,L,T) :-
3532 Conj = (G1,G2), !,
3533 conj2list(G1,L,T1),
3534 conj2list(G2,T1,T).
3535 conj2list(G,[G | T],T).
3537 list2conj([],true).
3538 list2conj([G],X) :- !, X = G.
3539 list2conj([G|Gs],C) :-
3540 ( G == true -> %% remove some redundant trues
3541 list2conj(Gs,C)
3542 ;
3543 C = (G,R),
3544 list2conj(Gs,R)
3545 ).
3547 list2disj([],fail).
3548 list2disj([G],X) :- !, X = G.
3549 list2disj([G|Gs],C) :-
3550 ( G == fail -> %% remove some redundant fails
3551 list2disj(Gs,C)
3552 ;
3553 C = (G;R),
3554 list2disj(Gs,R)
3555 ).
3557 atom_concat_list([X],X) :- ! .
3558 atom_concat_list([X|Xs],A) :-
3559 atom_concat_list(Xs,B),
3560 atom_concat(X,B,A).
3562 make_name(Prefix,F/A,Name) :-
3563 atom_concat_list([Prefix,F,(/),A],Name).
3565 set_elems([],_).
3566 set_elems([X|Xs],X) :-
3567 set_elems(Xs,X).
3569 member2([X|_],[Y|_],X-Y).
3570 member2([_|Xs],[_|Ys],P) :-
3571 member2(Xs,Ys,P).
3573 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
3574 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
3575 select2(X, Y, Xs, Ys, NXs, NYs).
3577 pair_all_with([],_,[]).
3578 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
3579 pair_all_with(Xs,Y,Rest).
3580 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3582 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
3583 functor(Head,F,A),
3584 get_store_type(F/A,StoreType),
3585 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
3587 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
3588 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
3589 instantiate_pattern_goals(AttrDict),
3590 get_max_constraint_index(N),
3591 ( N == 1 ->
3592 AllSusps = Attr
3593 ;
3594 functor(Head,F,A),
3595 get_constraint_index(F/A,Pos),
3596 make_attr(N,_,SuspsList,Attr),
3597 nth(Pos,SuspsList,AllSusps)
3598 ).
3599 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
3600 once((
3601 member(Index,Indexes),
3602 multi_hash_key_args(Index,Head,KeyArgs),
3603 translate(KeyArgs,VarDict,KeyArgCopies)
3604 )),
3605 ( KeyArgCopies = [KeyCopy] ->
3606 true
3607 ;
3608 KeyCopy =.. [k|KeyArgCopies]
3609 ),
3610 functor(Head,F,A),
3611 multi_hash_via_lookup_name(F/A,Index,ViaName),
3612 Goal =.. [ViaName,KeyCopy,AllSusps],
3613 update_store_type(F/A,multi_hash([Index])).
3614 lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :-
3615 functor(Head,F,A),
3616 global_ground_store_name(F/A,StoreName),
3617 Goal = nb_getval(StoreName,AllSusps),
3618 update_store_type(F/A,global_ground).
3619 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
3620 once((
3621 member(ST,StoreTypes),
3622 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
3623 )).
3624 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3625 assume_constraint_stores([]).
3626 assume_constraint_stores([C|Cs]) :-
3627 ( \+ may_trigger(C),
3628 is_attached(C),
3629 get_store_type(C,default) ->
3630 get_indexed_arguments(C,IndexedArgs),
3631 findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes),
3632 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
3633 ;
3634 true
3635 ),
3636 assume_constraint_stores(Cs).
3638 get_indexed_arguments(C,IndexedArgs) :-
3639 C = F/A,
3640 get_indexed_arguments(1,A,C,IndexedArgs).
3642 get_indexed_arguments(I,N,C,L) :-
3643 ( I > N ->
3644 L = []
3645 ; ( is_indexed_argument(C,I) ->
3646 L = [I|T]
3647 ;
3648 L = T
3649 ),
3650 J is I + 1,
3651 get_indexed_arguments(J,N,C,T)
3652 ).
3654 validate_store_type_assumptions([]).
3655 validate_store_type_assumptions([C|Cs]) :-
3656 validate_store_type_assumption(C),
3657 validate_store_type_assumptions(Cs).