| blob | 2c585296c64327007c8a35d8df9fa2474027b0b6 |
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 ].
857 option_definition(type_definition, _, []). % JW: ignored by bootstrap compiler
858 option_definition(type_declaration, _, []). % JW: ignored by bootstrap compiler
860 init_chr_pp_flags :-
861 chr_pp_flag_definition(Name,[DefaultValue|_]),
862 set_chr_pp_flag(Name,DefaultValue),
863 fail.
864 init_chr_pp_flags.
866 set_chr_pp_flags([]).
867 set_chr_pp_flags([Name-Value|Flags]) :-
868 set_chr_pp_flag(Name,Value),
869 set_chr_pp_flags(Flags).
871 set_chr_pp_flag(Name,Value) :-
872 atom_concat('$chr_pp_',Name,GlobalVar),
873 nb_setval(GlobalVar,Value).
875 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
876 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
877 chr_pp_flag_definition(reorder_heads,[on,off]).
878 chr_pp_flag_definition(set_semantics_rule,[on,off]).
879 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
880 chr_pp_flag_definition(guard_locks,[on,off]).
881 chr_pp_flag_definition(check_attachments,[on,off]).
882 chr_pp_flag_definition(debugable,[off,on]).
883 chr_pp_flag_definition(reduced_indexing,[on,off]).
885 chr_pp_flag(Name,Value) :-
886 atom_concat('$chr_pp_',Name,GlobalVar),
887 nb_getval(GlobalVar,V),
888 ( V == [] ->
889 chr_pp_flag_definition(Name,[Value|_])
890 ;
891 V = Value
892 ).
893 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
895 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
896 %%
897 %% Generated predicates
898 %% attach_$CONSTRAINT
899 %% attach_increment
900 %% detach_$CONSTRAINT
901 %% attr_unify_hook
903 %% attach_$CONSTRAINT
904 generate_attach_detach_a_constraint_all([],[]).
905 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
906 ( may_trigger(Constraint) ->
907 generate_attach_a_constraint(Constraint,Clauses1),
908 generate_detach_a_constraint(Constraint,Clauses2)
909 ;
910 Clauses1 = [],
911 Clauses2 = []
912 ),
913 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
914 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
916 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
917 generate_attach_a_constraint_empty_list(Constraint,Clause1),
918 get_max_constraint_index(N),
919 ( N == 1 ->
920 generate_attach_a_constraint_1_1(Constraint,Clause2)
921 ;
922 generate_attach_a_constraint_t_p(Constraint,Clause2)
923 ).
925 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
926 make_name('attach_',FA,Fct),
927 Head =.. [Fct | Args],
928 Clause = ( Head :- Body).
930 generate_attach_a_constraint_empty_list(FA,Clause) :-
931 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
933 generate_attach_a_constraint_1_1(FA,Clause) :-
934 Args = [[Var|Vars],Susp],
935 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
936 generate_attach_body_1(FA,Var,Susp,AttachBody),
937 make_name('attach_',FA,Fct),
938 RecursiveCall =.. [Fct,Vars,Susp],
939 Body =
940 (
941 AttachBody,
942 RecursiveCall
943 ).
945 generate_attach_body_1(FA,Var,Susp,Body) :-
946 get_target_module(Mod),
947 Body =
948 ( get_attr(Var, Mod, Susps) ->
949 NewSusps=[Susp|Susps],
950 put_attr(Var, Mod, NewSusps)
951 ;
952 put_attr(Var, Mod, [Susp])
953 ).
955 generate_attach_a_constraint_t_p(FA,Clause) :-
956 Args = [[Var|Vars],Susp],
957 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
958 make_name('attach_',FA,Fct),
959 RecursiveCall =.. [Fct,Vars,Susp],
960 generate_attach_body_n(FA,Var,Susp,AttachBody),
961 Body =
962 (
963 AttachBody,
964 RecursiveCall
965 ).
967 generate_attach_body_n(F/A,Var,Susp,Body) :-
968 get_constraint_index(F/A,Position),
969 or_pattern(Position,Pattern),
970 get_max_constraint_index(Total),
971 make_attr(Total,Mask,SuspsList,Attr),
972 nth(Position,SuspsList,Susps),
973 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
974 make_attr(Total,Mask,SuspsList1,NewAttr1),
975 substitute(Susps,SuspsList,[Susp],SuspsList2),
976 make_attr(Total,NewMask,SuspsList2,NewAttr2),
977 copy_term(SuspsList,SuspsList3),
978 nth(Position,SuspsList3,[Susp]),
979 delete(SuspsList3,[Susp],RestSuspsList),
980 set_elems(RestSuspsList,[]),
981 make_attr(Total,Pattern,SuspsList3,NewAttr3),
982 get_target_module(Mod),
983 Body =
984 ( get_attr(Var,Mod,TAttr) ->
985 TAttr = Attr,
986 ( Mask /\ Pattern =:= Pattern ->
987 put_attr(Var, Mod, NewAttr1)
988 ;
989 NewMask is Mask \/ Pattern,
990 put_attr(Var, Mod, NewAttr2)
991 )
992 ;
993 put_attr(Var,Mod,NewAttr3)
994 ).
996 %% detach_$CONSTRAINT
997 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
998 generate_detach_a_constraint_empty_list(Constraint,Clause1),
999 get_max_constraint_index(N),
1000 ( N == 1 ->
1001 generate_detach_a_constraint_1_1(Constraint,Clause2)
1002 ;
1003 generate_detach_a_constraint_t_p(Constraint,Clause2)
1004 ).
1006 generate_detach_a_constraint_empty_list(FA,Clause) :-
1007 make_name('detach_',FA,Fct),
1008 Args = [[],_],
1009 Head =.. [Fct | Args],
1010 Clause = ( Head :- true).
1012 generate_detach_a_constraint_1_1(FA,Clause) :-
1013 make_name('detach_',FA,Fct),
1014 Args = [[Var|Vars],Susp],
1015 Head =.. [Fct | Args],
1016 RecursiveCall =.. [Fct,Vars,Susp],
1017 generate_detach_body_1(FA,Var,Susp,DetachBody),
1018 Body =
1019 (
1020 DetachBody,
1021 RecursiveCall
1022 ),
1023 Clause = (Head :- Body).
1025 generate_detach_body_1(FA,Var,Susp,Body) :-
1026 get_target_module(Mod),
1027 Body =
1028 ( get_attr(Var,Mod,Susps) ->
1029 'chr sbag_del_element'(Susps,Susp,NewSusps),
1030 ( NewSusps == [] ->
1031 del_attr(Var,Mod)
1032 ;
1033 put_attr(Var,Mod,NewSusps)
1034 )
1035 ;
1036 true
1037 ).
1039 generate_detach_a_constraint_t_p(FA,Clause) :-
1040 make_name('detach_',FA,Fct),
1041 Args = [[Var|Vars],Susp],
1042 Head =.. [Fct | Args],
1043 RecursiveCall =.. [Fct,Vars,Susp],
1044 generate_detach_body_n(FA,Var,Susp,DetachBody),
1045 Body =
1046 (
1047 DetachBody,
1048 RecursiveCall
1049 ),
1050 Clause = (Head :- Body).
1052 generate_detach_body_n(F/A,Var,Susp,Body) :-
1053 get_constraint_index(F/A,Position),
1054 or_pattern(Position,Pattern),
1055 and_pattern(Position,DelPattern),
1056 get_max_constraint_index(Total),
1057 make_attr(Total,Mask,SuspsList,Attr),
1058 nth(Position,SuspsList,Susps),
1059 substitute(Susps,SuspsList,[],SuspsList1),
1060 make_attr(Total,NewMask,SuspsList1,Attr1),
1061 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1062 make_attr(Total,Mask,SuspsList2,Attr2),
1063 get_target_module(Mod),
1064 Body =
1065 ( get_attr(Var,Mod,TAttr) ->
1066 TAttr = Attr,
1067 ( Mask /\ Pattern =:= Pattern ->
1068 'chr sbag_del_element'(Susps,Susp,NewSusps),
1069 ( NewSusps == [] ->
1070 NewMask is Mask /\ DelPattern,
1071 ( NewMask == 0 ->
1072 del_attr(Var,Mod)
1073 ;
1074 put_attr(Var,Mod,Attr1)
1075 )
1076 ;
1077 put_attr(Var,Mod,Attr2)
1078 )
1079 ;
1080 true
1081 )
1082 ;
1083 true
1084 ).
1086 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1087 generate_indexed_variables_clauses(Constraints,Clauses) :-
1088 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1089 generate_indexed_variables_clauses_(Constraints,Clauses)
1090 ;
1091 Clauses = []
1092 ).
1094 generate_indexed_variables_clauses_([],[]).
1095 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1096 ( ( is_attached(C) ; chr_pp_flag(debugable,on)) ->
1097 Clauses = [Clause|RestClauses],
1098 generate_indexed_variables_clause(C,Clause)
1099 ;
1100 Clauses = RestClauses
1101 ),
1102 generate_indexed_variables_clauses_(Cs,RestClauses).
1104 generate_indexed_variables_clause(F/A,Clause) :-
1105 functor(Term,F,A),
1106 get_constraint_mode(F/A,ArgModes),
1107 Term =.. [_|Args],
1108 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1109 ( MaybeBody == empty ->
1111 Body = (Vars = [])
1112 ; N == 0 ->
1113 Body = term_variables(Susp,Vars)
1114 ;
1115 MaybeBody = Body
1116 ),
1117 Clause =
1118 ( '$indexed_variables'(Susp,Vars) :-
1119 Susp = Term,
1120 Body
1121 ).
1123 create_indexed_variables_body([],[],_,_,_,empty,0).
1124 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1125 J is I + 1,
1126 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1127 ( Mode \== (+),
1128 is_indexed_argument(FA,I) ->
1129 ( RBody == empty ->
1130 Body = term_variables(V,Vars)
1131 ;
1132 Body = (term_variables(V,Vars,Tail),RBody)
1133 ),
1134 N = M
1135 ;
1136 Vars = Tail,
1137 Body = RBody,
1138 N is M + 1
1139 ).
1141 generate_extra_clauses(Constraints,[A,B,C,D,E]) :-
1142 ( chr_pp_flag(reduced_indexing,on) ->
1143 global_indexed_variables_clause(Constraints,D)
1144 ;
1145 D =
1146 ( chr_indexed_variables(Susp,Vars) :-
1147 'chr chr_indexed_variables'(Susp,Vars)
1148 )
1149 ),
1150 generate_remove_clause(A),
1151 generate_activate_clause(B),
1152 generate_allocate_clause(C),
1153 generate_insert_constraint_internal(E).
1155 generate_remove_clause(RemoveClause) :-
1156 RemoveClause =
1157 (
1158 remove_constraint_internal(Susp, Agenda, Delete) :-
1159 arg( 2, Susp, Mref),
1160 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1161 'chr update_mutable'( removed, Mref), % mark in any case
1162 ( compound(State) -> % passive/1
1163 Agenda = [],
1164 Delete = no
1165 ; State==removed ->
1166 Agenda = [],
1167 Delete = no
1168 %; State==triggered ->
1169 % Agenda = []
1170 ;
1171 Delete = yes,
1172 chr_indexed_variables(Susp,Agenda)
1173 )
1174 ).
1176 generate_activate_clause(ActivateClause) :-
1177 ActivateClause =
1178 (
1179 activate_constraint(Store, Vars, Susp, Generation) :-
1180 arg( 2, Susp, Mref),
1181 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1182 'chr update_mutable'( active, Mref),
1183 ( nonvar(Generation) -> % aih
1184 true
1185 ;
1186 arg( 4, Susp, Gref),
1187 Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
1188 Generation is Gen+1,
1189 'chr update_mutable'( Generation, Gref)
1190 ),
1191 ( compound(State) -> % passive/1
1192 term_variables( State, Vars),
1193 'chr none_locked'( Vars),
1194 Store = yes
1195 ; State == removed -> % the price for eager removal ...
1196 chr_indexed_variables(Susp,Vars),
1197 Store = yes
1198 ;
1199 Vars = [],
1200 Store = no
1201 )
1202 ).
1204 generate_allocate_clause(AllocateClause) :-
1205 AllocateClause =
1206 (
1207 allocate_constraint( Closure, Self, F, Args) :-
1208 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1209 Gref = mutable(0),
1210 'chr empty_history'(History),
1211 Href = mutable(History),
1212 chr_indexed_variables(Self,Vars),
1213 Mref = mutable(passive(Vars)),
1214 'chr gen_id'( Id)
1215 ).
1217 generate_insert_constraint_internal(Clause) :-
1218 Clause =
1219 (
1220 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1221 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1222 chr_indexed_variables(Self,Vars),
1223 'chr none_locked'(Vars),
1224 Mref = mutable(active),
1225 Gref = mutable(0),
1226 Href = mutable(History),
1227 'chr empty_history'(History),
1228 'chr gen_id'(Id)
1229 ).
1231 global_indexed_variables_clause(Constraints,Clause) :-
1232 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1233 Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
1234 ;
1235 Body = true,
1236 Vars = []
1237 ),
1238 Clause = ( chr_indexed_variables(Susp,Vars) :- Body ).
1240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1241 generate_attach_increment(Clauses) :-
1242 get_max_constraint_index(N),
1243 ( N > 0 ->
1244 Clauses = [Clause1,Clause2],
1245 generate_attach_increment_empty(Clause1),
1246 ( N == 1 ->
1247 generate_attach_increment_one(Clause2)
1248 ;
1249 generate_attach_increment_many(N,Clause2)
1250 )
1251 ;
1252 Clauses = []
1253 ).
1255 generate_attach_increment_empty((attach_increment([],_) :- true)).
1257 generate_attach_increment_one(Clause) :-
1258 Head = attach_increment([Var|Vars],Susps),
1259 get_target_module(Mod),
1260 Body =
1261 (
1262 'chr not_locked'(Var),
1263 ( get_attr(Var,Mod,VarSusps) ->
1264 sort(VarSusps,SortedVarSusps),
1265 merge(Susps,SortedVarSusps,MergedSusps),
1266 put_attr(Var,Mod,MergedSusps)
1267 ;
1268 put_attr(Var,Mod,Susps)
1269 ),
1270 attach_increment(Vars,Susps)
1271 ),
1272 Clause = (Head :- Body).
1274 generate_attach_increment_many(N,Clause) :-
1275 make_attr(N,Mask,SuspsList,Attr),
1276 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1277 Head = attach_increment([Var|Vars],Attr),
1278 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1279 list2conj(Gs,SortGoals),
1280 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1281 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1282 get_target_module(Mod),
1283 Body =
1284 (
1285 'chr not_locked'(Var),
1286 ( get_attr(Var,Mod,TOtherAttr) ->
1287 TOtherAttr = OtherAttr,
1288 SortGoals,
1289 MergedMask is Mask \/ OtherMask,
1290 put_attr(Var,Mod,NewAttr)
1291 ;
1292 put_attr(Var,Mod,Attr)
1293 ),
1294 attach_increment(Vars,Attr)
1295 ),
1296 Clause = (Head :- Body).
1298 %% attr_unify_hook
1299 generate_attr_unify_hook([Clause]) :-
1300 get_max_constraint_index(N),
1301 ( N == 0 ->
1302 get_target_module(Mod),
1303 Clause =
1304 ( attr_unify_hook(Attr,Var) :-
1305 write('ERROR: Unexpected triggering of attr_unify_hook/2 in module '),
1306 writeln(Mod)
1307 )
1308 ; N == 1 ->
1309 generate_attr_unify_hook_one(Clause)
1310 ;
1311 generate_attr_unify_hook_many(N,Clause)
1312 ).
1314 generate_attr_unify_hook_one(Clause) :-
1315 Head = attr_unify_hook(Susps,Other),
1316 get_target_module(Mod),
1317 make_run_suspensions(NewSusps,WakeNewSusps),
1318 make_run_suspensions(Susps,WakeSusps),
1319 Body =
1320 (
1321 sort(Susps, SortedSusps),
1322 ( var(Other) ->
1323 ( get_attr(Other,Mod,OtherSusps) ->
1324 true
1325 ;
1326 OtherSusps = []
1327 ),
1328 sort(OtherSusps,SortedOtherSusps),
1329 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1330 put_attr(Other,Mod,NewSusps),
1331 WakeNewSusps
1332 ;
1333 ( compound(Other) ->
1334 term_variables(Other,OtherVars),
1335 attach_increment(OtherVars, SortedSusps)
1336 ;
1337 true
1338 ),
1339 WakeSusps
1340 )
1341 ),
1342 Clause = (Head :- Body).
1344 generate_attr_unify_hook_many(N,Clause) :-
1345 make_attr(N,Mask,SuspsList,Attr),
1346 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1347 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1348 list2conj(SortGoalList,SortGoals),
1349 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1350 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1351 C = (sort(E,F),
1352 'chr merge_attributes'(D,F,G)) ),
1353 SortMergeGoalList),
1354 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1355 list2conj(SortMergeGoalList,SortMergeGoals),
1356 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1357 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1358 Head = attr_unify_hook(Attr,Other),
1359 get_target_module(Mod),
1360 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1361 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1362 Body =
1363 (
1364 SortGoals,
1365 ( var(Other) ->
1366 ( get_attr(Other,Mod,TOtherAttr) ->
1367 TOtherAttr = OtherAttr,
1368 SortMergeGoals,
1369 MergedMask is Mask \/ OtherMask,
1370 put_attr(Other,Mod,MergedAttr),
1371 WakeMergedSusps
1372 ;
1373 put_attr(Other,Mod,SortedAttr),
1374 WakeSortedSusps
1375 )
1376 ;
1377 ( compound(Other) ->
1378 term_variables(Other,OtherVars),
1379 attach_increment(OtherVars,SortedAttr)
1380 ;
1381 true
1382 ),
1383 WakeSortedSusps
1384 )
1385 ),
1386 Clause = (Head :- Body).
1388 make_run_suspensions(Susps,Goal) :-
1389 ( chr_pp_flag(debugable,on) ->
1390 Goal = 'chr run_suspensions_d'(Susps)
1391 ;
1392 Goal = 'chr run_suspensions'(Susps)
1393 ).
1395 make_run_suspensions_loop(SuspsList,Goal) :-
1396 ( chr_pp_flag(debugable,on) ->
1397 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1398 ;
1399 Goal = 'chr run_suspensions_loop'(SuspsList)
1400 ).
1402 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1403 % $insert_in_store_F/A
1404 % $delete_from_store_F/A
1406 generate_insert_delete_constraints([],[]).
1407 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1408 ( is_attached(FA) ->
1409 Clauses = [IClause,DClause|RestClauses],
1410 generate_insert_delete_constraint(FA,IClause,DClause)
1411 ;
1412 Clauses = RestClauses
1413 ),
1414 generate_insert_delete_constraints(Rest,RestClauses).
1416 generate_insert_delete_constraint(FA,IClause,DClause) :-
1417 get_store_type(FA,StoreType),
1418 generate_insert_constraint(StoreType,FA,IClause),
1419 generate_delete_constraint(StoreType,FA,DClause).
1421 generate_insert_constraint(StoreType,C,Clause) :-
1422 make_name('$insert_in_store_',C,ClauseName),
1423 Head =.. [ClauseName,Susp],
1424 generate_insert_constraint_body(StoreType,C,Susp,Body),
1425 Clause = (Head :- Body).
1427 generate_insert_constraint_body(default,C,Susp,Body) :-
1428 get_target_module(Mod),
1429 get_max_constraint_index(Total),
1430 ( Total == 1 ->
1431 generate_attach_body_1(C,Store,Susp,AttachBody)
1432 ;
1433 generate_attach_body_n(C,Store,Susp,AttachBody)
1434 ),
1435 Body =
1436 (
1437 'chr global_term_ref_1'(Store),
1438 AttachBody
1439 ).
1440 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1441 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1442 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1443 global_ground_store_name(C,StoreName),
1444 Body =
1445 (
1446 nb_getval(StoreName,Store),
1447 b_setval(StoreName,[Susp|Store])
1448 ).
1449 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1450 find_with_var_identity(
1451 B,
1452 [Susp],
1453 (
1454 member(ST,StoreTypes),
1455 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1456 ),
1457 Bodies
1458 ),
1459 list2conj(Bodies,Body).
1461 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1462 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1463 multi_hash_store_name(FA,Index,StoreName),
1464 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1465 Body =
1466 (
1467 KeyBody,
1468 nb_getval(StoreName,Store),
1469 insert_ht(Store,Key,Susp)
1470 ),
1471 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1473 generate_delete_constraint(StoreType,FA,Clause) :-
1474 make_name('$delete_from_store_',FA,ClauseName),
1475 Head =.. [ClauseName,Susp],
1476 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1477 Clause = (Head :- Body).
1479 generate_delete_constraint_body(default,C,Susp,Body) :-
1480 get_target_module(Mod),
1481 get_max_constraint_index(Total),
1482 ( Total == 1 ->
1483 generate_detach_body_1(C,Store,Susp,DetachBody),
1484 Body =
1485 (
1486 'chr global_term_ref_1'(Store),
1487 DetachBody
1488 )
1489 ;
1490 generate_detach_body_n(C,Store,Susp,DetachBody),
1491 Body =
1492 (
1493 'chr global_term_ref_1'(Store),
1494 DetachBody
1495 )
1496 ).
1497 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1498 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1499 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1500 global_ground_store_name(C,StoreName),
1501 Body =
1502 (
1503 nb_getval(StoreName,Store),
1504 'chr sbag_del_element'(Store,Susp,NStore),
1505 b_setval(StoreName,NStore)
1506 ).
1507 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1508 find_with_var_identity(
1509 B,
1510 [Susp],
1511 (
1512 member(ST,StoreTypes),
1513 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1514 ),
1515 Bodies
1516 ),
1517 list2conj(Bodies,Body).
1519 generate_multi_hash_delete_constraint_bodies([],_,_,true).
1520 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1521 multi_hash_store_name(FA,Index,StoreName),
1522 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1523 Body =
1524 (
1525 KeyBody,
1526 nb_getval(StoreName,Store),
1527 delete_ht(Store,Key,Susp)
1528 ),
1529 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
1531 generate_delete_constraint_call(FA,Susp,Call) :-
1532 make_name('$delete_from_store_',FA,Functor),
1533 Call =.. [Functor,Susp].
1535 generate_insert_constraint_call(FA,Susp,Call) :-
1536 make_name('$insert_in_store_',FA,Functor),
1537 Call =.. [Functor,Susp].
1539 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1541 generate_store_code(Constraints,[Enumerate|L]) :-
1542 enumerate_stores_code(Constraints,Enumerate),
1543 generate_store_code(Constraints,L,[]).
1545 generate_store_code([],L,L).
1546 generate_store_code([C|Cs],L,T) :-
1547 get_store_type(C,StoreType),
1548 generate_store_code(StoreType,C,L,L1),
1549 generate_store_code(Cs,L1,T).
1551 generate_store_code(default,_,L,L).
1552 generate_store_code(multi_hash(Indexes),C,L,T) :-
1553 multi_hash_store_initialisations(Indexes,C,L,L1),
1554 multi_hash_via_lookups(Indexes,C,L1,T).
1555 generate_store_code(global_ground,C,L,T) :-
1556 global_ground_store_initialisation(C,L,T).
1557 generate_store_code(multi_store(StoreTypes),C,L,T) :-
1558 multi_store_generate_store_code(StoreTypes,C,L,T).
1560 multi_store_generate_store_code([],_,L,L).
1561 multi_store_generate_store_code([ST|STs],C,L,T) :-
1562 generate_store_code(ST,C,L,L1),
1563 multi_store_generate_store_code(STs,C,L1,T).
1565 multi_hash_store_initialisations([],_,L,L).
1566 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
1567 multi_hash_store_name(FA,Index,StoreName),
1568 L = [(:- (new_ht(HT),nb_setval(StoreName,HT)) )|L1],
1569 multi_hash_store_initialisations(Indexes,FA,L1,T).
1571 global_ground_store_initialisation(C,L,T) :-
1572 global_ground_store_name(C,StoreName),
1573 L = [(:- nb_setval(StoreName,[]))|T].
1575 multi_hash_via_lookups([],_,L,L).
1576 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
1577 multi_hash_via_lookup_name(C,Index,PredName),
1578 Head =.. [PredName,Key,SuspsList],
1579 multi_hash_store_name(C,Index,StoreName),
1580 Body =
1581 (
1582 nb_getval(StoreName,HT),
1583 lookup_ht(HT,Key,SuspsList)
1584 ),
1585 L = [(Head :- Body)|L1],
1586 multi_hash_via_lookups(Indexes,C,L1,T).
1588 multi_hash_via_lookup_name(F/A,Index,Name) :-
1589 ( integer(Index) ->
1590 IndexName = Index
1591 ; is_list(Index) ->
1592 atom_concat_list(Index,IndexName)
1593 ),
1594 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
1596 multi_hash_store_name(F/A,Index,Name) :-
1597 get_target_module(Mod),
1598 ( integer(Index) ->
1599 IndexName = Index
1600 ; is_list(Index) ->
1601 atom_concat_list(Index,IndexName)
1602 ),
1603 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
1605 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
1606 ( ( integer(Index) ->
1607 I = Index
1608 ;
1609 Index = [I]
1610 ) ->
1611 SuspIndex is I + 6,
1612 KeyBody = arg(SuspIndex,Susp,Key)
1613 ; is_list(Index) ->
1614 sort(Index,Indexes),
1615 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
1616 pairup(Bodies,Keys,ArgKeyPairs),
1617 Key =.. [k|Keys],
1618 list2conj(Bodies,KeyBody)
1619 ).
1621 multi_hash_key_args(Index,Head,KeyArgs) :-
1622 ( integer(Index) ->
1623 arg(Index,Head,Arg),
1624 KeyArgs = [Arg]
1625 ; is_list(Index) ->
1626 sort(Index,Indexes),
1627 term_variables(Head,Vars),
1628 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
1629 ).
1631 global_ground_store_name(F/A,Name) :-
1632 get_target_module(Mod),
1633 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
1634 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1635 enumerate_stores_code(Constraints,Clause) :-
1636 Head = '$enumerate_suspensions'(Susp),
1637 enumerate_store_bodies(Constraints,Susp,Bodies),
1638 list2disj(Bodies,Body),
1639 Clause = (Head :- Body).
1641 enumerate_store_bodies([],_,[]).
1642 enumerate_store_bodies([C|Cs],Susp,L) :-
1643 ( is_attached(C) ->
1644 get_store_type(C,StoreType),
1645 enumerate_store_body(StoreType,C,Susp,B),
1646 L = [B|T]
1647 ;
1648 L = T
1649 ),
1650 enumerate_store_bodies(Cs,Susp,T).
1652 enumerate_store_body(default,C,Susp,Body) :-
1653 get_constraint_index(C,Index),
1654 get_target_module(Mod),
1655 get_max_constraint_index(MaxIndex),
1656 Body1 =
1657 (
1658 'chr global_term_ref_1'(GlobalStore),
1659 get_attr(GlobalStore,Mod,Attr)
1660 ),
1661 ( MaxIndex > 1 ->
1662 NIndex is Index + 1,
1663 Body2 =
1664 (
1665 arg(NIndex,Attr,List),
1666 'chr sbag_member'(Susp,List)
1667 )
1668 ;
1669 Body2 = 'chr sbag_member'(Susp,Attr)
1670 ),
1671 Body = (Body1,Body2).
1672 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
1673 multi_hash_enumerate_store_body(Index,C,Susp,Body).
1674 enumerate_store_body(global_ground,C,Susp,Body) :-
1675 global_ground_store_name(C,StoreName),
1676 Body =
1677 (
1678 nb_getval(StoreName,List),
1679 'chr sbag_member'(Susp,List)
1680 ).
1681 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
1682 once((
1683 member(ST,STs),
1684 enumerate_store_body(ST,C,Susp,Body)
1685 )).
1687 multi_hash_enumerate_store_body(I,C,Susp,B) :-
1688 multi_hash_store_name(C,I,StoreName),
1689 B =
1690 (
1691 nb_getval(StoreName,HT),
1692 value_ht(HT,Susp)
1693 ).
1694 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1695 check_attachments(Constraints) :-
1696 ( chr_pp_flag(check_attachments,on) ->
1697 check_constraint_attachments(Constraints)
1698 ;
1699 true
1700 ).
1702 check_constraint_attachments([]).
1703 check_constraint_attachments([C|Cs]) :-
1704 check_constraint_attachment(C),
1705 check_constraint_attachments(Cs).
1707 check_constraint_attachment(C) :-
1708 get_max_occurrence(C,MO),
1709 check_occurrences_attachment(C,1,MO).
1711 check_occurrences_attachment(C,O,MO) :-
1712 ( O > MO ->
1713 true
1714 ;
1715 check_occurrence_attachment(C,O),
1716 NO is O + 1,
1717 check_occurrences_attachment(C,NO,MO)
1718 ).
1720 check_occurrence_attachment(C,O) :-
1721 get_occurrence(C,O,RuleNb,ID),
1722 get_rule(RuleNb,PragmaRule),
1723 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
1724 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
1725 check_attachment_head1(Head1,ID,RuleNb,Heads1,Heads2,Guard)
1726 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
1727 check_attachment_head2(Head2,ID,RuleNb,Heads1,Body)
1728 ).
1730 check_attachment_head1(C,ID,RuleNb,H1,H2,G) :-
1731 functor(C,F,A),
1732 ( H1 == [C],
1733 H2 == [],
1734 G == true,
1735 C =.. [_|L],
1736 no_matching(L,[]),
1737 \+ is_passive(RuleNb,ID) ->
1738 attached(F/A,no)
1739 ;
1740 attached(F/A,maybe)
1741 ).
1743 no_matching([],_).
1744 no_matching([X|Xs],Prev) :-
1745 var(X),
1746 \+ memberchk_eq(X,Prev),
1747 no_matching(Xs,[X|Prev]).
1749 check_attachment_head2(C,ID,RuleNb,H1,B) :-
1750 functor(C,F,A),
1751 ( is_passive(RuleNb,ID) ->
1752 attached(F/A,maybe)
1753 ; H1 \== [],
1754 B == true ->
1755 attached(F/A,maybe)
1756 ;
1757 attached(F/A,yes)
1758 ).
1760 all_attached([]).
1761 all_attached([C|Cs]) :-
1762 functor(C,F,A),
1763 is_attached(F/A),
1764 all_attached(Cs).
1766 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1768 set_constraint_indices([],M) :-
1769 N is M - 1,
1770 max_constraint_index(N).
1771 set_constraint_indices([C|Cs],N) :-
1772 ( ( may_trigger(C) ; is_attached(C), get_store_type(C,default)) ->
1773 constraint_index(C,N),
1774 M is N + 1,
1775 set_constraint_indices(Cs,M)
1776 ;
1777 set_constraint_indices(Cs,N)
1778 ).
1780 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1781 %% ____ _ ____ _ _ _ _
1782 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
1783 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
1784 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
1785 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
1786 %% |_|
1788 constraints_code(Constraints,Rules,Clauses) :-
1789 post_constraints(Constraints,1),
1790 constraints_code1(1,Rules,L,[]),
1791 clean_clauses(L,Clauses).
1793 %% Add global data
1794 post_constraints([],MaxIndex1) :-
1795 MaxIndex is MaxIndex1 - 1,
1796 constraint_count(MaxIndex).
1797 post_constraints([F/A|Cs],N) :-
1798 constraint(F/A,N),
1799 M is N + 1,
1800 post_constraints(Cs,M).
1801 constraints_code1(I,Rules,L,T) :-
1802 get_constraint_count(N),
1803 ( I > N ->
1804 T = L
1805 ;
1806 constraint_code(I,Rules,L,T1),
1807 J is I + 1,
1808 constraints_code1(J,Rules,T1,T)
1809 ).
1811 %% Generate code for a single CHR constraint
1812 constraint_code(I, Rules, L, T) :-
1813 get_constraint(Constraint,I),
1814 constraint_prelude(Constraint,Clause),
1815 L = [Clause | L1],
1816 Id1 = [0],
1817 rules_code(Rules,I,Id1,Id2,L1,L2),
1818 gen_cond_attach_clause(Constraint,Id2,L2,T).
1820 %% Generate prelude predicate for a constraint.
1821 %% f(...) :- f/a_0(...,Susp).
1822 constraint_prelude(F/A, Clause) :-
1823 vars_susp(A,Vars,Susp,VarsSusp),
1824 Head =.. [ F | Vars],
1825 build_head(F,A,[0],VarsSusp,Delegate),
1826 get_target_module(Mod),
1827 FTerm =.. [F|Vars],
1828 ( chr_pp_flag(debugable,on) ->
1829 Clause =
1830 ( Head :-
1831 allocate_constraint(Mod : Delegate, Susp, FTerm, Vars),
1832 (
1833 'chr debug_event'(call(Susp)),
1834 Delegate
1835 ;
1836 'chr debug_event'(fail(Susp)), !,
1837 fail
1838 ),
1839 (
1840 'chr debug_event'(exit(Susp))
1841 ;
1842 'chr debug_event'(redo(Susp)),
1843 fail
1844 )
1845 )
1846 ;
1847 Clause = ( Head :- Delegate )
1848 ).
1850 gen_cond_attach_clause(F/A,Id,L,T) :-
1851 ( is_attached(F/A) ->
1852 ( Id == [0] ->
1853 ( may_trigger(F/A) ->
1854 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
1855 ;
1856 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
1857 )
1858 ; vars_susp(A,Args,Susp,AllArgs),
1859 gen_uncond_attach_goal(F/A,Susp,Body,_)
1860 ),
1861 ( chr_pp_flag(debugable,on) ->
1862 Constraint =.. [F|Args],
1863 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
1864 ;
1865 DebugEvent = true
1866 ),
1867 build_head(F,A,Id,AllArgs,Head),
1868 Clause = ( Head :- DebugEvent,Body ),
1869 L = [Clause | T]
1870 ;
1871 L = T
1872 ).
1874 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
1875 vars_susp(A,Args,Susp,AllArgs),
1876 build_head(F,A,[0],AllArgs,Closure),
1877 ( may_trigger(F/A) ->
1878 make_name('attach_',F/A,AttachF),
1879 Attach =.. [AttachF,Vars,Susp]
1880 ;
1881 Attach = true
1882 ),
1883 get_target_module(Mod),
1884 FTerm =.. [F|Args],
1885 generate_insert_constraint_call(F/A,Susp,InsertCall),
1886 Goal =
1887 (
1888 ( var(Susp) ->
1889 insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args)
1890 ;
1891 activate_constraint(Stored,Vars,Susp,_)
1892 ),
1893 ( Stored == yes ->
1894 InsertCall,
1895 Attach
1896 ;
1897 true
1898 )
1899 ).
1901 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
1902 vars_susp(A,Args,Susp,AllArgs),
1903 build_head(F,A,[0],AllArgs,Closure),
1904 ( may_trigger(F/A) ->
1905 make_name('attach_',F/A,AttachF),
1906 Attach =.. [AttachF,Vars,Susp]
1907 ;
1908 Attach = true
1909 ),
1910 get_target_module(Mod),
1911 FTerm =.. [F|Args],
1912 generate_insert_constraint_call(F/A,Susp,InsertCall),
1913 Goal =
1914 (
1915 insert_constraint_internal(_,Vars,Susp,Mod:Closure,FTerm,Args),
1916 InsertCall,
1917 Attach
1918 ).
1920 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
1921 ( may_trigger(FA) ->
1922 make_name('attach_',FA,AttachF),
1923 Attach =.. [AttachF,Vars,Susp]
1924 ;
1925 Attach = true
1926 ),
1927 generate_insert_constraint_call(FA,Susp,InsertCall),
1928 AttachGoal =
1929 (
1930 activate_constraint(Stored,Vars, Susp, Generation),
1931 ( Stored == yes ->
1932 InsertCall,
1933 Attach
1934 ;
1935 true
1936 )
1937 ).
1939 occurrences_code(O,MO,C,Id,NId,L,T) :-
1940 ( O > MO ->
1941 NId = Id,
1942 L = T
1943 ;
1944 occurrence_code(O,C,Id,Id1,L,L1),
1945 NO is O + 1,
1946 occurrences_code(NO,MO,C,Id1,NId,L1,T)
1947 ).
1949 occurrences_code(O,C,Id,NId,L,T) :-
1950 get_occurrence(C,O,RuleNb,ID),
1951 ( is_passive(RuleNb,ID) ->
1952 NId = Id,
1953 L = T
1954 ;
1955 get_rule(RuleNb,PragmaRule),
1956 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
1957 ( select2(IDs1,Heads1,ID,Head1,RIDs1,RHeads1) ->
1958 NId = Id,
1959 head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,Id,L,T)
1960 ; select2(IDs2,Heads2,ID,Head2,RIDs2,RHeads2) ->
1961 length(RHeads2,RestHeadNb),
1962 head2_code(Head2,RHeads2,RIDs2,PragmaRule,RestHeadNb,C,Id,L,L1),
1963 inc_id(Id,NId),
1964 gen_alloc_inc_clause(C,Id,L1,T)
1965 )
1966 ).
1969 %% Generate all the code for a constraint based on all CHR rules
1970 rules_code([],_,Id,Id,L,L).
1971 rules_code([R |Rs],I,Id1,Id3,L,T) :-
1972 rule_code(R,I,Id1,Id2,L,T1),
1973 rules_code(Rs,I,Id2,Id3,T1,T).
1975 %% Generate code for a constraint based on a single CHR rule
1976 rule_code(PragmaRule,I,Id1,Id2,L,T) :-
1977 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name,_RuleNb),
1978 HeadIDs = ids(Head1IDs,Head2IDs),
1979 Rule = rule(Head1,Head2,_,_),
1980 heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
1981 heads2_code(Head2,[],Head2IDs,[],PragmaRule,I,Id1,Id2,L1,T).
1983 %% Generate code based on all the removed heads of a CHR rule
1984 heads1_code([],_,_,_,_,_,_,L,L).
1985 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
1986 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
1987 get_constraint(F/A,I),
1988 ( functor(Head,F,A),
1989 \+ is_passive(RuleNb,HeadID),
1990 \+ check_unnecessary_active(Head,RestHeads,Rule),
1991 all_attached(Heads),
1992 all_attached(RestHeads),
1993 Rule = rule(_,Heads2,_,_),
1994 all_attached(Heads2) ->
1995 append(Heads,RestHeads,OtherHeads),
1996 append(HeadIDs,RestIDs,OtherIDs),
1997 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
1998 ;
1999 L = L1
2000 ),
2001 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
2003 %% Generate code based on one removed head of a CHR rule
2004 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
2005 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2006 Rule = rule(_,Head2,_,_),
2007 ( Head2 == [] ->
2008 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
2009 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
2010 ;
2011 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2012 ).
2014 %% Generate code based on all the persistent heads of a CHR rule
2015 heads2_code([],_,_,_,_,_,Id,Id,L,L).
2016 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id1,Id3,L,T) :-
2017 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
2018 get_constraint(F/A,I),
2019 ( functor(Head,F,A),
2020 \+ is_passive(RuleNb,HeadID),
2021 \+ check_unnecessary_active(Head,RestHeads,Rule),
2022 \+ set_semantics_rule(PragmaRule),
2023 all_attached(Heads),
2024 all_attached(RestHeads),
2025 Rule = rule(Heads1,_,_,_),
2026 all_attached(Heads1) ->
2027 append(Heads,RestHeads,OtherHeads),
2028 append(HeadIDs,RestIDs,OtherIDs),
2029 length(Heads,RestHeadNb),
2030 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,F/A,Id1,L,L0),
2031 inc_id(Id1,Id2),
2032 gen_alloc_inc_clause(F/A,Id1,L0,L1)
2033 ;
2034 L = L1,
2035 Id2 = Id1
2036 ),
2037 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id2,Id3,L1,T).
2039 %% Generate code based on one persistent head of a CHR rule
2040 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,FA,Id,L,T) :-
2041 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2042 Rule = rule(Head1,_,_,_),
2043 ( Head1 == [] ->
2044 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,_),
2045 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
2046 ;
2047 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2048 ).
2050 gen_alloc_inc_clause(F/A,Id,L,T) :-
2051 vars_susp(A,Vars,Susp,VarsSusp),
2052 build_head(F,A,Id,VarsSusp,Head),
2053 inc_id(Id,IncId),
2054 build_head(F,A,IncId,VarsSusp,CallHead),
2055 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,ConditionalAlloc),
2056 Clause =
2057 (
2058 Head :-
2059 ConditionalAlloc,
2060 CallHead
2061 ),
2062 L = [Clause|T].
2064 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2065 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
2066 ConstraintAllocationGoal =
2067 ( var(Susp) ->
2068 UncondConstraintAllocationGoal
2069 ;
2070 true
2071 ).
2072 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
2073 build_head(F,A,[0],VarsSusp,Term),
2074 get_target_module(Mod),
2075 FTerm =.. [F|Vars],
2076 ConstraintAllocationGoal = allocate_constraint(Mod : Term, Susp, FTerm, Vars).
2078 gen_allocation(Id,Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2079 ( Id == [0] ->
2080 ( is_attached(FA) ->
2081 ( may_trigger(FA) ->
2082 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2083 ;
2084 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2085 )
2086 ;
2087 ConstraintAllocationGoal = true
2088 )
2089 ;
2090 ConstraintAllocationGoal = true
2091 ).
2092 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2095 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2097 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
2098 ( chr_pp_flag(guard_via_reschedule,on) ->
2099 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
2100 ;
2101 append(Retrievals,GuardList,GoalList),
2102 list2conj(GoalList,Goal)
2103 ).
2105 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
2106 initialize_unit_dictionary(Prelude,Dict),
2107 build_units(Retrievals,GuardList,Dict,Units),
2108 dependency_reorder(Units,NUnits),
2109 units2goal(NUnits,Goal).
2111 units2goal([],true).
2112 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
2113 units2goal(Units,Goals).
2115 dependency_reorder(Units,NUnits) :-
2116 dependency_reorder(Units,[],NUnits).
2118 dependency_reorder([],Acc,Result) :-
2119 reverse(Acc,Result).
2121 dependency_reorder([Unit|Units],Acc,Result) :-
2122 Unit = unit(_GID,_Goal,Type,GIDs),
2123 ( Type == fixed ->
2124 NAcc = [Unit|Acc]
2125 ;
2126 dependency_insert(Acc,Unit,GIDs,NAcc)
2127 ),
2128 dependency_reorder(Units,NAcc,Result).
2130 dependency_insert([],Unit,_,[Unit]).
2131 dependency_insert([X|Xs],Unit,GIDs,L) :-
2132 X = unit(GID,_,_,_),
2133 ( memberchk(GID,GIDs) ->
2134 L = [Unit,X|Xs]
2135 ;
2136 L = [X | T],
2137 dependency_insert(Xs,Unit,GIDs,T)
2138 ).
2140 build_units(Retrievals,Guard,InitialDict,Units) :-
2141 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
2142 build_guard_units(Guard,N,Dict,Tail).
2144 build_retrieval_units([],N,N,Dict,Dict,L,L).
2145 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
2146 term_variables(U,Vs),
2147 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2148 L = [unit(N,U,movable,GIDs)|L1],
2149 N1 is N + 1,
2150 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
2152 build_retrieval_units2([],N,N,Dict,Dict,L,L).
2153 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
2154 term_variables(U,Vs),
2155 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2156 L = [unit(N,U,fixed,GIDs)|L1],
2157 N1 is N + 1,
2158 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
2160 initialize_unit_dictionary(Term,Dict) :-
2161 term_variables(Term,Vars),
2162 pair_all_with(Vars,0,Dict).
2164 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
2165 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2166 ( lookup_eq(Dict,V,GID) ->
2167 ( (GID == This ; memberchk(GID,GIDs) ) ->
2168 GIDs1 = GIDs
2169 ;
2170 GIDs1 = [GID|GIDs]
2171 ),
2172 Dict1 = Dict
2173 ;
2174 Dict1 = [V - This|Dict],
2175 GIDs1 = GIDs
2176 ),
2177 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2179 build_guard_units(Guard,N,Dict,Units) :-
2180 ( Guard = [Goal] ->
2181 Units = [unit(N,Goal,fixed,[])]
2182 ; Guard = [Goal|Goals] ->
2183 term_variables(Goal,Vs),
2184 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
2185 Units = [unit(N,Goal,movable,GIDs)|RUnits],
2186 N1 is N + 1,
2187 build_guard_units(Goals,N1,NDict,RUnits)
2188 ).
2190 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
2191 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2192 ( lookup_eq(Dict,V,GID) ->
2193 ( (GID == This ; memberchk(GID,GIDs) ) ->
2194 GIDs1 = GIDs
2195 ;
2196 GIDs1 = [GID|GIDs]
2197 ),
2198 Dict1 = [V - This|Dict]
2199 ;
2200 Dict1 = [V - This|Dict],
2201 GIDs1 = GIDs
2202 ),
2203 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2205 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2207 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2208 %% ____ _ ____ _ _
2209 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
2210 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
2211 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
2212 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
2213 %%
2214 %% _ _ _ ___ __
2215 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
2216 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
2217 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
2218 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
2219 %% |_|
2220 unique_analyse_optimise(Rules,NRules) :-
2221 ( chr_pp_flag(unique_analyse_optimise,on) ->
2222 unique_analyse_optimise_main(Rules,1,[],NRules)
2223 ;
2224 NRules = Rules
2225 ).
2227 unique_analyse_optimise_main([],_,_,[]).
2228 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
2229 ( discover_unique_pattern(PRule,N,Pattern) ->
2230 NPatternList = [Pattern|PatternList]
2231 ;
2232 NPatternList = PatternList
2233 ),
2234 PRule = pragma(Rule,Ids,Pragmas,Name,RuleNb),
2235 Rule = rule(H1,H2,_,_),
2236 Ids = ids(Ids1,Ids2),
2237 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
2238 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
2239 globalize_unique_pragmas(MorePragmas1,RuleNb),
2240 globalize_unique_pragmas(MorePragmas2,RuleNb),
2241 append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
2242 NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb),
2243 N1 is N + 1,
2244 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
2246 globalize_unique_pragmas([],_).
2247 globalize_unique_pragmas([unique(ID,Vars)|R],RuleNb) :-
2248 pragma_unique(RuleNb,ID,Vars),
2249 globalize_unique_pragmas(R,RuleNb).
2251 apply_unique_patterns_to_constraints([],_,_,[]).
2252 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
2253 ( member(Pattern,Patterns),
2254 apply_unique_pattern(C,Id,Pattern,Pragma) ->
2255 Pragmas = [Pragma | RPragmas]
2256 ;
2257 Pragmas = RPragmas
2258 ),
2259 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
2261 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
2262 Pattern = unique(PatternConstraint,PatternKey),
2263 subsumes(Constraint,PatternConstraint,Unifier),
2264 ( setof( V,
2265 T^Term^Vs^(
2266 member(T,PatternKey),
2267 lookup_eq(Unifier,T,Term),
2268 term_variables(Term,Vs),
2269 member(V,Vs)
2270 ),
2271 Vars) ->
2272 true
2273 ;
2274 Vars = []
2275 ),
2276 Pragma = unique(Id,Vars).
2278 % subsumes(+Term1, +Term2, -Unifier)
2279 %
2280 % If Term1 is a more general term than Term2 (e.g. has a larger
2281 % part instantiated), unify Unifier with a list Var-Value of
2282 % variables from Term2 and their corresponding values in Term1.
2284 subsumes(Term1,Term2,Unifier) :-
2285 empty_assoc(S0),
2286 subsumes_aux(Term1,Term2,S0,S),
2287 assoc_to_list(S,L),
2288 build_unifier(L,Unifier).
2290 subsumes_aux(Term1, Term2, S0, S) :-
2291 ( compound(Term2),
2292 functor(Term2, F, N)
2293 -> compound(Term1), functor(Term1, F, N),
2294 subsumes_aux(N, Term1, Term2, S0, S)
2295 ; Term1 == Term2
2296 -> S = S0
2297 ; var(Term2),
2298 get_assoc(Term1,S0,V)
2299 -> V == Term2, S = S0
2300 ; var(Term2),
2301 put_assoc(Term1, S0, Term2, S)
2302 ).
2304 subsumes_aux(0, _, _, S, S) :- ! .
2305 subsumes_aux(N, T1, T2, S0, S) :-
2306 arg(N, T1, T1x),
2307 arg(N, T2, T2x),
2308 subsumes_aux(T1x, T2x, S0, S1),
2309 M is N-1,
2310 subsumes_aux(M, T1, T2, S1, S).
2312 build_unifier([],[]).
2313 build_unifier([X-V|R],[V - X | T]) :-
2314 build_unifier(R,T).
2316 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
2317 PragmaRule = pragma(Rule,_,_Pragmas,Name,RuleNb),
2318 Rule = rule(H1,H2,Guard,_),
2319 ( H1 = [C1],
2320 H2 = [C2] ->
2321 true
2322 ; H1 = [C1,C2],
2323 H2 == [] ->
2324 true
2325 ),
2326 check_unique_constraints(C1,C2,Guard,RuleNb,List),
2327 term_variables(C1,Vs),
2328 select_pragma_unique_variables(List,Vs,Key),
2329 Pattern0 = unique(C1,Key),
2330 copy_term(Pattern0,Pattern),
2331 ( prolog_flag(verbose,V), V == yes ->
2332 format('Found unique pattern ~w in rule ~d~@\n',
2333 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
2334 ;
2335 true
2336 ).
2338 select_pragma_unique_variables([],_,[]).
2339 select_pragma_unique_variables([X-Y|R],Vs,L) :-
2340 ( X == Y ->
2341 L = [X|T]
2342 ;
2343 once((
2344 \+ memberchk_eq(X,Vs)
2345 ;
2346 \+ memberchk_eq(Y,Vs)
2347 )),
2348 L = T
2349 ),
2350 select_pragma_unique_variables(R,Vs,T).
2352 check_unique_constraints(C1,C2,G,RuleNb,List) :-
2353 \+ any_passive_head(RuleNb),
2354 variable_replacement(C1-C2,C2-C1,List),
2355 copy_with_variable_replacement(G,OtherG,List),
2356 negate_b(G,NotG),
2357 once(entails_b(NotG,OtherG)).
2359 check_unnecessary_active(Constraint,Previous,Rule) :-
2360 ( chr_pp_flag(check_unnecessary_active,full) ->
2361 check_unnecessary_active_main(Constraint,Previous,Rule)
2362 ; chr_pp_flag(check_unnecessary_active,simplification),
2363 Rule = rule(_,[],_,_) ->
2364 check_unnecessary_active_main(Constraint,Previous,Rule)
2365 ;
2366 fail
2367 ).
2369 check_unnecessary_active_main(Constraint,Previous,Rule) :-
2370 member(Other,Previous),
2371 variable_replacement(Other,Constraint,List),
2372 copy_with_variable_replacement(Rule,Rule2,List),
2373 identical_rules(Rule,Rule2), ! .
2375 set_semantics_rule(PragmaRule) :-
2376 ( chr_pp_flag(set_semantics_rule,on) ->
2377 set_semantics_rule_main(PragmaRule)
2378 ;
2379 fail
2380 ).
2382 set_semantics_rule_main(PragmaRule) :-
2383 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
2384 Rule = rule([C1],[C2],true,_),
2385 IDs = ids([ID1],[ID2]),
2386 once(member(unique(ID1,L1),Pragmas)),
2387 once(member(unique(ID2,L2),Pragmas)),
2388 L1 == L2,
2389 \+ is_passive(RuleNb,ID1).
2390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2392 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2393 %% ____ _ _____ _ _
2394 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
2395 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
2396 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
2397 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
2398 %% |_|
2399 % have to check for no duplicates in value list
2401 % check wether two rules are identical
2403 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
2404 G1 == G2,
2405 identical_bodies(B1,B2),
2406 permutation(H11,P1),
2407 P1 == H12,
2408 permutation(H21,P2),
2409 P2 == H22.
2411 identical_bodies(B1,B2) :-
2412 ( B1 = (X1 = Y1),
2413 B2 = (X2 = Y2) ->
2414 ( X1 == X2,
2415 Y1 == Y2
2416 ; X1 == Y2,
2417 X2 == Y1
2418 ),
2419 !
2420 ; B1 == B2
2421 ).
2423 % replace variables in list
2425 copy_with_variable_replacement(X,Y,L) :-
2426 ( var(X) ->
2427 ( lookup_eq(L,X,Y) ->
2428 true
2429 ; X = Y
2430 )
2431 ; functor(X,F,A),
2432 functor(Y,F,A),
2433 X =.. [_|XArgs],
2434 Y =.. [_|YArgs],
2435 copy_with_variable_replacement_l(XArgs,YArgs,L)
2436 ).
2438 copy_with_variable_replacement_l([],[],_).
2439 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
2440 copy_with_variable_replacement(X,Y,L),
2441 copy_with_variable_replacement_l(Xs,Ys,L).
2443 %% build variable replacement list
2445 variable_replacement(X,Y,L) :-
2446 variable_replacement(X,Y,[],L).
2448 variable_replacement(X,Y,L1,L2) :-
2449 ( var(X) ->
2450 var(Y),
2451 ( lookup_eq(L1,X,Z) ->
2452 Z == Y,
2453 L2 = L1
2454 ; L2 = [X-Y|L1]
2455 )
2456 ; X =.. [F|XArgs],
2457 nonvar(Y),
2458 Y =.. [F|YArgs],
2459 variable_replacement_l(XArgs,YArgs,L1,L2)
2460 ).
2462 variable_replacement_l([],[],L,L).
2463 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
2464 variable_replacement(X,Y,L1,L2),
2465 variable_replacement_l(Xs,Ys,L2,L3).
2466 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2468 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2469 %% ____ _ _ _ __ _ _ _
2470 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
2471 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
2472 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
2473 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
2474 %% |_|
2476 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
2477 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
2478 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2479 build_head(F,A,Id,HeadVars,ClauseHead),
2480 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2482 ( RestHeads == [] ->
2483 Susps = [],
2484 VarDict = VarDict1,
2485 GetRestHeads = []
2486 ;
2487 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
2488 ),
2490 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2491 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2493 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
2494 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2496 ( chr_pp_flag(debugable,on) ->
2497 Rule = rule(_,_,Guard,Body),
2498 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2499 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
2500 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
2501 ;
2502 DebugTry = true,
2503 DebugApply = true
2504 ),
2506 Clause = ( ClauseHead :-
2507 FirstMatching,
2508 RescheduledTest,
2509 DebugTry,
2510 !,
2511 DebugApply,
2512 SuspsDetachments,
2513 SuspDetachment,
2514 BodyCopy
2515 ),
2516 L = [Clause | T].
2518 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
2519 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
2520 list2conj(GoalList,Goal).
2522 head_arg_matches_([],VarDict,[],VarDict).
2523 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
2524 ( var(Arg) ->
2525 ( lookup_eq(VarDict,Arg,OtherVar) ->
2526 GoalList = [Var == OtherVar | RestGoalList],
2527 VarDict1 = VarDict
2528 ; VarDict1 = [Arg-Var | VarDict],
2529 GoalList = RestGoalList
2530 ),
2531 Pairs = Rest
2532 ; atomic(Arg) ->
2533 GoalList = [ Var == Arg | RestGoalList],
2534 VarDict = VarDict1,
2535 Pairs = Rest
2536 ; Arg =.. [_|Args],
2537 functor(Arg,Fct,N),
2538 functor(Term,Fct,N),
2539 Term =.. [_|Vars],
2540 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
2541 pairup(Args,Vars,NewPairs),
2542 append(NewPairs,Rest,Pairs),
2543 VarDict1 = VarDict
2544 ),
2545 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
2547 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,[],[],[]).
2550 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
2551 ( Heads = [_|_] ->
2552 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
2553 ;
2554 GoalList = [],
2555 Susps = [],
2556 VarDict = NVarDict
2557 ).
2559 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
2560 instantiate_pattern_goals(AttrDict).
2561 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
2562 functor(H,F,A),
2563 get_store_type(F/A,StoreType),
2564 ( StoreType == default ->
2565 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
2566 get_max_constraint_index(N),
2567 ( N == 1 ->
2568 VarSusps = Attr
2569 ;
2570 get_constraint_index(F/A,Pos),
2571 make_attr(N,_Mask,SuspsList,Attr),
2572 nth(Pos,SuspsList,VarSusps)
2573 )
2574 ;
2575 lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
2576 NewAttrDict = AttrDict
2577 ),
2578 head_info(H,A,Vars,_,_,Pairs),
2579 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
2580 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
2581 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
2582 create_get_mutable(active,State,GetMutable),
2583 Goal1 =
2584 (
2585 'chr sbag_member'(Susp,VarSusps),
2586 Susp = Suspension,
2587 GetMutable,
2588 DiffSuspGoals,
2589 MatchingGoal
2590 ),
2591 ( member(unique(ID,UniqueKeus),Pragmas),
2592 check_unique_keys(UniqueKeus,VarDict) ->
2593 Goal = (Goal1 -> true)
2594 ;
2595 Goal = Goal1
2596 ),
2597 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
2599 instantiate_pattern_goals([]).
2600 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
2601 get_max_constraint_index(N),
2602 ( N == 1 ->
2603 Goal = true
2604 ;
2605 make_attr(N,Mask,_,Attr),
2606 or_list(Bits,Pattern), !,
2607 Goal = (Mask /\ Pattern =:= Pattern)
2608 ),
2609 instantiate_pattern_goals(Rest).
2612 check_unique_keys([],_).
2613 check_unique_keys([V|Vs],Dict) :-
2614 lookup_eq(Dict,V,_),
2615 check_unique_keys(Vs,Dict).
2617 % Generates tests to ensure the found constraint differs from previously found constraints
2618 % TODO: detect more cases where constraints need be different
2619 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
2620 ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
2621 list2conj(DiffSuspGoalList,DiffSuspGoals)
2622 ;
2623 DiffSuspGoals = true
2624 ).
2626 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
2627 functor(Head,F,A),
2628 get_constraint_index(F/A,Pos),
2629 common_variables(Head,PrevHeads,CommonVars),
2630 translate(CommonVars,VarDict,Vars),
2631 or_pattern(Pos,Bit),
2632 ( permutation(Vars,PermutedVars),
2633 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
2634 member(Bit,Positions), !,
2635 NewAttrDict = AttrDict,
2636 Goal = true
2637 ;
2638 Goal = (Goal1, PatternGoal),
2639 gen_get_mod_constraints(Vars,Goal1,Attr),
2640 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
2641 ).
2643 common_variables(T,Ts,Vs) :-
2644 term_variables(T,V1),
2645 term_variables(Ts,V2),
2646 intersect_eq(V1,V2,Vs).
2648 gen_get_mod_constraints(L,Goal,Susps) :-
2649 get_target_module(Mod),
2650 ( L == [] ->
2651 Goal =
2652 ( 'chr global_term_ref_1'(Global),
2653 get_attr(Global,Mod,TSusps),
2654 TSusps = Susps
2655 )
2656 ;
2657 ( L = [A] ->
2658 VIA = 'chr via_1'(A,V)
2659 ; ( L = [A,B] ->
2660 VIA = 'chr via_2'(A,B,V)
2661 ; VIA = 'chr via'(L,V)
2662 )
2663 ),
2664 Goal =
2665 ( VIA,
2666 get_attr(V,Mod,TSusps),
2667 TSusps = Susps
2668 )
2669 ).
2671 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
2672 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2673 list2conj(GuardCopyList,GuardCopy).
2675 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
2676 Rule = rule(_,_,Guard,Body),
2677 conj2list(Guard,GuardList),
2678 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
2679 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
2681 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
2682 term_variables(RestGuardList,GuardVars),
2683 term_variables(RestGuardListCopyCore,GuardCopyVars),
2684 ( chr_pp_flag(guard_locks,on),
2685 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
2686 X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
2687 lookup_eq(VarDict,X,Y), % translate X into new variable
2688 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
2689 ),
2690 LocksUnlocks) ->
2691 once(pairup(Locks,Unlocks,LocksUnlocks))
2692 ;
2693 Locks = [],
2694 Unlocks = []
2695 ),
2696 list2conj(Locks,LockPhase),
2697 list2conj(Unlocks,UnlockPhase),
2698 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
2699 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
2700 my_term_copy(Body,VarDict2,BodyCopy).
2703 split_off_simple_guard([],_,[],[]).
2704 split_off_simple_guard([G|Gs],VarDict,S,C) :-
2705 ( simple_guard(G,VarDict) ->
2706 S = [G|Ss],
2707 split_off_simple_guard(Gs,VarDict,Ss,C)
2708 ;
2709 S = [],
2710 C = [G|Gs]
2711 ).
2713 % simple guard: cheap and benign (does not bind variables)
2714 simple_guard(G,VarDict) :-
2715 binds_b(G,Vars),
2716 \+ (( member(V,Vars),
2717 lookup_eq(VarDict,V,_)
2718 )).
2720 my_term_copy(X,Dict,Y) :-
2721 my_term_copy(X,Dict,_,Y).
2723 my_term_copy(X,Dict1,Dict2,Y) :-
2724 ( var(X) ->
2725 ( lookup_eq(Dict1,X,Y) ->
2726 Dict2 = Dict1
2727 ; Dict2 = [X-Y|Dict1]
2728 )
2729 ; functor(X,XF,XA),
2730 functor(Y,XF,XA),
2731 X =.. [_|XArgs],
2732 Y =.. [_|YArgs],
2733 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
2734 ).
2736 my_term_copy_list([],Dict,Dict,[]).
2737 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
2738 my_term_copy(X,Dict1,Dict2,Y),
2739 my_term_copy_list(Xs,Dict2,Dict3,Ys).
2741 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
2742 ( is_attached(FA) ->
2743 ( Id == [0], \+ may_trigger(FA) ->
2744 SuspDetachment = true
2745 ;
2746 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
2747 SuspDetachment =
2748 ( var(Susp) ->
2749 true
2750 ; UnCondSuspDetachment
2751 )
2752 )
2753 ;
2754 SuspDetachment = true
2755 ).
2757 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
2758 ( is_attached(FA) ->
2759 ( may_trigger(FA) ->
2760 make_name('detach_',FA,Fct),
2761 Detach =.. [Fct,Vars,Susp]
2762 ;
2763 Detach = true
2764 ),
2765 ( chr_pp_flag(debugable,on) ->
2766 DebugEvent = 'chr debug_event'(remove(Susp))
2767 ;
2768 DebugEvent = true
2769 ),
2770 generate_delete_constraint_call(FA,Susp,DeleteCall),
2771 SuspDetachment =
2772 (
2773 DebugEvent,
2774 remove_constraint_internal(Susp, Vars, Delete),
2775 ( Delete == yes ->
2776 DeleteCall,
2777 Detach
2778 ;
2779 true
2780 )
2781 )
2782 ;
2783 SuspDetachment = true
2784 ).
2786 gen_uncond_susps_detachments([],[],true).
2787 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
2788 functor(Term,F,A),
2789 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
2790 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
2792 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2794 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2795 %% ____ _ _ _ _
2796 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
2797 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
2798 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
2799 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
2800 %% |_| |___/
2802 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
2803 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
2804 Rule = rule(_Heads,Heads2,Guard,Body),
2806 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2807 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2809 build_head(F,A,Id,HeadVars,ClauseHead),
2811 append(RestHeads,Heads2,Heads),
2812 append(OtherIDs,Heads2IDs,IDs),
2813 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
2814 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
2815 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
2817 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2818 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2820 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
2821 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2823 ( chr_pp_flag(debugable,on) ->
2824 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2825 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
2826 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
2827 ;
2828 DebugTry = true,
2829 DebugApply = true
2830 ),
2832 Clause = ( ClauseHead :-
2833 FirstMatching,
2834 RescheduledTest,
2835 DebugTry,
2836 !,
2837 DebugApply,
2838 SuspsDetachments,
2839 SuspDetachment,
2840 BodyCopy
2841 ),
2842 L = [Clause | T].
2844 split_by_ids([],[],_,[],[]).
2845 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
2846 ( memberchk_eq(I,I1s) ->
2847 S1s = [S | R1s],
2848 S2s = R2s
2849 ;
2850 S1s = R1s,
2851 S2s = [S | R2s]
2852 ),
2853 split_by_ids(Is,Ss,I1s,R1s,R2s).
2855 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2858 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2859 %% ____ _ _ _ ____
2860 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
2861 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
2862 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
2863 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
2864 %% |_| |___/
2866 %% Genereate prelude + worker predicate
2867 %% prelude calls worker
2868 %% worker iterates over one type of removed constraints
2869 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
2870 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name,RuleNb),
2871 Rule = rule(Heads1,_,Guard,Body),
2872 reorder_heads(RuleNb,Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
2873 % IDs1 = [ID1|RestIDs1],
2874 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
2875 extend_id(Id,Id2),
2876 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,PragmaRule,FA,Id2,L1,T).
2878 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2879 simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
2880 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2881 build_head(F,A,Id1,VarsSusp,ClauseHead),
2882 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
2884 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
2886 gen_allocation(Id1,Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal),
2888 extend_id(Id1,DelegateId),
2889 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2890 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
2891 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
2893 PreludeClause =
2894 ( ClauseHead :-
2895 FirstMatching,
2896 ModConstraintsGoal,
2897 !,
2898 ConstraintAllocationGoal,
2899 Delegate
2900 ),
2901 L = [PreludeClause|T].
2903 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
2904 Term =.. [_|Args],
2905 delegate_variables(Term,Terms,VarDict,Args,Vars).
2907 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
2908 term_variables(PrevTerms,PrevVars),
2909 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
2911 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
2912 term_variables(Term,V1),
2913 term_variables(Terms,V2),
2914 intersect_eq(V1,V2,V3),
2915 list_difference_eq(V3,PrevVars,V4),
2916 translate(V4,VarDict,Vars).
2919 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2920 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L,T) :-
2921 PragmaRule = pragma(Rule,_,_,_,_),
2922 Rule = rule(_,_,Guard,Body),
2923 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
2924 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L1,T).
2926 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2927 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,F/A,Id,L,T) :-
2928 gen_var(OtherSusp),
2929 gen_var(OtherSusps),
2931 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
2932 head_arg_matches(Head2Pairs,[],_,VarDict1),
2934 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
2935 Rule = rule(_,_,Guard,Body),
2936 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
2937 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
2938 build_head(F,A,Id,HeadVars,ClauseHead),
2940 functor(Head1,_OtherF,OtherA),
2941 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
2942 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
2944 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
2945 create_get_mutable(active,OtherState,GetMutable),
2946 IteratorSuspTest =
2947 ( OtherSusp = OtherSuspension,
2948 GetMutable
2949 ),
2951 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
2952 append(RestHeads1,RestHeads2,RestHeads),
2953 append(IDs1,IDs2,IDs),
2954 reorder_heads(RuleNb,Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
2955 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
2956 split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
2957 ; RestSuspsRetrieval = [],
2958 Susps1 = [],
2959 Susps2 = [],
2960 VarDict = VarDict2
2961 ),
2963 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
2965 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
2966 build_head(F,A,Id,RecursiveVars,RecursiveCall),
2967 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
2968 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
2970 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2971 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
2972 ( BodyCopy \== true ->
2973 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2974 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2975 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
2976 ; Attachment = true,
2977 ConditionalRecursiveCall = RecursiveCall,
2978 ConditionalRecursiveCall2 = RecursiveCall2
2979 ),
2981 ( chr_pp_flag(debugable,on) ->
2982 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2983 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
2984 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
2985 ;
2986 DebugTry = true,
2987 DebugApply = true
2988 ),
2990 ( member(unique(ID1,UniqueKeys), Pragmas),
2991 check_unique_keys(UniqueKeys,VarDict1) ->
2992 Clause =
2993 ( ClauseHead :-
2994 ( IteratorSuspTest,
2995 FirstMatching ->
2996 ( RescheduledTest,
2997 DebugTry ->
2998 DebugApply,
2999 Susps1Detachments,
3000 Attachment,
3001 BodyCopy,
3002 ConditionalRecursiveCall2
3003 ;
3004 RecursiveCall2
3005 )
3006 ;
3007 RecursiveCall
3008 )
3009 )
3010 ;
3011 Clause =
3012 ( ClauseHead :-
3013 ( IteratorSuspTest,
3014 FirstMatching,
3015 RescheduledTest,
3016 DebugTry ->
3017 DebugApply,
3018 Susps1Detachments,
3019 Attachment,
3020 BodyCopy,
3021 ConditionalRecursiveCall
3022 ;
3023 RecursiveCall
3024 )
3025 )
3026 ),
3027 L = [Clause | T].
3029 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
3030 length(Args,N),
3031 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
3032 create_get_mutable(active,State,GetState),
3033 create_get_mutable(Generation,NewGeneration,GetGeneration),
3034 ConditionalCall =
3035 ( Susp = Suspension,
3036 GetState,
3037 GetGeneration ->
3038 'chr update_mutable'(inactive,State),
3039 Call
3040 ; true
3041 ).
3043 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3044 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
3045 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
3046 head_arg_matches(Pairs,[],_,VarDict),
3047 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
3048 append([[]|VarsSusp],ExtraVars,HeadVars),
3049 build_head(F,A,Id,HeadVars,ClauseHead),
3050 next_id(Id,ContinuationId),
3051 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
3052 Clause = ( ClauseHead :- ContinuationHead ),
3053 L = [Clause | T].
3055 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3058 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3059 %% ____ _ _
3060 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
3061 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
3062 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
3063 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
3064 %% |_| |___/
3066 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3067 ( RestHeads == [] ->
3068 propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
3069 ;
3070 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
3071 ).
3072 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3073 %% Single headed propagation
3074 %% everything in a single clause
3075 propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
3076 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3077 build_head(F,A,Id,VarsSusp,ClauseHead),
3079 inc_id(Id,NextId),
3080 build_head(F,A,NextId,VarsSusp,NextHead),
3082 NextCall = NextHead,
3084 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
3085 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3086 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,Allocation),
3087 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
3089 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
3091 ( chr_pp_flag(debugable,on) ->
3092 Rule = rule(_,_,Guard,Body),
3093 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3094 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
3095 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
3096 ;
3097 DebugTry = true,
3098 DebugApply = true
3099 ),
3101 Clause = (
3102 ClauseHead :-
3103 HeadMatching,
3104 Allocation,
3105 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
3106 GuardCopy,
3107 DebugTry,
3108 !,
3109 DebugApply,
3110 'chr extend_history'(Susp,RuleNb),
3111 Attachment,
3112 BodyCopy,
3113 ConditionalNextCall
3114 ),
3115 L = [Clause | T].
3117 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3118 %% multi headed propagation
3119 %% prelude + predicates to accumulate the necessary combinations of suspended
3120 %% constraints + predicate to execute the body
3121 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3122 RestHeads = [First|Rest],
3123 propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
3124 extend_id(Id,ExtendedId),
3125 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
3127 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3128 propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
3129 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3130 build_head(F,A,Id,VarsSusp,PreludeHead),
3131 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
3132 Rule = rule(_,_,Guard,Body),
3133 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
3135 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
3137 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,CondAllocation),
3139 extend_id(Id,NestedId),
3140 append([Susps|VarsSusp],ExtraVars,NestedVars),
3141 build_head(F,A,NestedId,NestedVars,NestedHead),
3142 NestedCall = NestedHead,
3144 Prelude = (
3145 PreludeHead :-
3146 FirstMatching,
3147 FirstSuspGoal,
3148 !,
3149 CondAllocation,
3150 NestedCall
3151 ),
3152 L = [Prelude|T].
3154 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3155 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3156 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
3157 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
3159 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3160 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
3161 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
3162 inc_id(Id,IncId),
3163 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
3165 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
3166 Rule = rule(_,_,Guard,Body),
3167 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
3168 gen_var(OtherSusp),
3169 gen_var(OtherSusps),
3170 functor(CurrentHead,_OtherF,OtherA),
3171 gen_vars(OtherA,OtherVars),
3172 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3173 create_get_mutable(active,State,GetMutable),
3174 CurrentSuspTest = (
3175 OtherSusp = Suspension,
3176 GetMutable
3177 ),
3178 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3179 build_head(F,A,Id,ClauseVars,ClauseHead),
3180 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3181 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3182 RecursiveCall = RecursiveHead,
3183 CurrentHead =.. [_|OtherArgs],
3184 pairup(OtherArgs,OtherVars,OtherPairs),
3185 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
3187 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
3189 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3190 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
3191 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
3193 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
3194 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
3195 list2conj(NovelProductionsList,NovelProductions),
3196 Tuple =.. [t,RuleNb|HistorySusps],
3198 ( chr_pp_flag(debugable,on) ->
3199 Rule = rule(_,_,Guard,Body),
3200 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3201 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
3202 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
3203 ;
3204 DebugTry = true,
3205 DebugApply = true
3206 ),
3208 Clause = (
3209 ClauseHead :-
3210 ( CurrentSuspTest,
3211 DiffSuspGoals,
3212 Matching,
3213 TupleVar = Tuple,
3214 NovelProductions,
3215 GuardCopy,
3216 DebugTry ->
3217 DebugApply,
3218 'chr extend_history'(Susp,TupleVar),
3219 Attach,
3220 BodyCopy,
3221 ConditionalRecursiveCall
3222 ; RecursiveCall
3223 )
3224 ),
3225 L = [Clause|T].
3227 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
3228 ( Count == 0 ->
3229 reverse(OtherSusps,ReversedSusps),
3230 append(ReversedSusps,[Susp|Acc],HistorySusps)
3231 ;
3232 OtherSusps = [OtherSusp|RestOtherSusps],
3233 NCount is Count - 1,
3234 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
3235 ).
3237 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
3238 !,
3239 functor(Head,_F,A),
3240 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
3241 head_arg_matches(Pairs,[],_,VarDict),
3242 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3243 append(VarsSusp,ExtraVars,HeadVars).
3244 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
3245 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
3246 functor(Head,_F,A),
3247 gen_var(Susps),
3248 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
3249 head_arg_matches(Pairs,VarDict,_,NVarDict),
3250 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3251 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
3253 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
3254 Rule = rule(_,_,Guard,Body),
3255 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
3257 Vars = [ [] | VarsAndSusps],
3259 build_head(F,A,Id,Vars,Head),
3261 ( Id = [0|_] ->
3262 next_id(Id,PrevId),
3263 PrevVarsAndSusps = AllButFirst
3264 ;
3265 dec_id(Id,PrevId),
3266 PrevVarsAndSusps = [FirstSusp|AllButFirst]
3267 ),
3269 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
3270 PredecessorCall = PrevHead,
3272 Clause = (
3273 Head :-
3274 PredecessorCall
3275 ),
3276 L = [Clause | T].
3278 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
3279 !,
3280 functor(Head,_F,A),
3281 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
3282 head_arg_matches(HeadPairs,[],_,VarDict),
3283 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3284 append(VarsSusp,ExtraVars,HeadVars).
3285 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
3286 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
3287 functor(Head,_F,A),
3288 gen_var(Susps),
3289 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3290 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3291 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3292 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
3294 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
3295 Rule = rule(_,_,Guard,Body),
3296 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
3297 gen_var(OtherSusps),
3298 functor(CurrentHead,_OtherF,OtherA),
3299 gen_vars(OtherA,OtherVars),
3300 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
3301 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
3303 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3305 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
3306 create_get_mutable(active,State,GetMutable),
3307 CurrentSuspTest = (
3308 OtherSusp = OtherSuspension,
3309 GetMutable,
3310 DiffSuspGoals,
3311 FirstMatching
3312 ),
3313 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
3314 inc_id(Id,NestedId),
3315 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3316 build_head(F,A,Id,ClauseVars,ClauseHead),
3317 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
3318 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
3319 build_head(F,A,NestedId,NestedVars,NestedHead),
3321 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3322 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3323 Clause = (
3324 ClauseHead :-
3325 ( CurrentSuspTest,
3326 NextSuspGoal
3327 ->
3328 NestedHead
3329 ; RecursiveHead
3330 )
3331 ),
3332 L = [Clause|T].
3334 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
3335 !,
3336 functor(Head,_F,A),
3337 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
3338 head_arg_matches(HeadPairs,[],_,VarDict),
3339 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3340 append(VarsSusp,ExtraVars,HeadVars).
3341 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
3342 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
3343 functor(Head,_F,A),
3344 gen_var(NextSusps),
3345 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3346 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3347 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3348 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
3350 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3352 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3353 %% ____ _ _ _ _
3354 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
3355 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
3356 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
3357 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
3358 %%
3359 %% ____ _ _ _
3360 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
3361 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
3362 %% | _ < __/ |_| | | | __/\ V / (_| | |
3363 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
3364 %%
3365 %% ____ _ _
3366 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
3367 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
3368 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
3369 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
3370 %% |___/
3372 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3373 ( chr_pp_flag(reorder_heads,on) ->
3374 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
3375 ;
3376 NRestHeads = RestHeads,
3377 NRestIDs = RestIDs
3378 ).
3380 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3381 term_variables(Head,Vars),
3382 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
3383 a_star(InitialData,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
3384 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
3385 reverse(RNRestHeads,NRestHeads),
3386 reverse(RNRestIDs,NRestIDs).
3388 final_data(Entry) :-
3389 Entry = entry(_,_,_,_,[],_).
3391 expand_data(Entry,NEntry,Cost) :-
3392 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
3393 term_variables(Entry,EVars),
3394 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
3395 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
3396 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost),
3397 term_variables([Head1|Vars],Vars1).
3399 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3400 functor(Head,F,A),
3401 get_store_type(F/A,StoreType),
3402 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
3404 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3405 term_variables(Head,HeadVars),
3406 term_variables(RestHeads,RestVars),
3407 order_score_vars(HeadVars,KnownVars,RestHeads,0,Score).
3408 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3409 order_score_indexes(Indexes,Head,KnownVars,0,Score).
3410 order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :-
3411 functor(Head,F,A),
3412 ( get_pragma_unique(RuleNb,ID,Vars),
3413 Vars == [] ->
3414 Score = 1 % guaranteed O(1)
3415 ; A == 0 -> % flag constraint
3416 Score = 10 % O(1)? [CHECK: no deleted/triggered/... constraints in store?]
3417 ; A > 0 ->
3418 Score = 100
3419 ).
3421 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3422 find_with_var_identity(
3423 S,
3424 t(Head,KnownVars,RestHeads),
3425 ( member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
3426 Scores
3427 ),
3428 min_list(Scores,Score).
3431 order_score_indexes([],_,_,Score,Score) :-
3432 Score > 0.
3433 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
3434 multi_hash_key_args(I,Head,Args),
3435 ( forall(Arg,Args,hprolog:memberchk_eq(Arg,KnownVars)) ->
3436 Score1 is Score + 10
3437 ;
3438 Score1 = Score
3439 ),
3440 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
3442 order_score_vars([],_,_,Score,NScore) :-
3443 ( Score == 0 ->
3444 NScore = 0
3445 ;
3446 NScore = Score
3447 ).
3448 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
3449 ( memberchk_eq(V,KnownVars) ->
3450 TScore is Score + 10
3451 ; memberchk_eq(V,RestVars) ->
3452 TScore is Score + 100
3453 ;
3454 TScore = Score
3455 ),
3456 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
3458 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3459 %% ___ _ _ _
3460 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
3461 %% | || '_ \| | | '_ \| | '_ \ / _` |
3462 %% | || | | | | | | | | | | | | (_| |
3463 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
3464 %% |___/
3466 create_get_mutable(V,M,GM) :-
3467 GM = (M = mutable(V)).
3469 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3471 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3472 %% _ _ _ _ _ _ _
3473 %% | | | | |_(_) (_) |_ _ _
3474 %% | | | | __| | | | __| | | |
3475 %% | |_| | |_| | | | |_| |_| |
3476 %% \___/ \__|_|_|_|\__|\__, |
3477 %% |___/
3479 gen_var(_).
3480 gen_vars(N,Xs) :-
3481 length(Xs,N).
3483 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
3484 vars_susp(A,Vars,Susp,VarsSusp),
3485 Head =.. [_|Args],
3486 pairup(Args,Vars,HeadPairs).
3488 inc_id([N|Ns],[O|Ns]) :-
3489 O is N + 1.
3490 dec_id([N|Ns],[M|Ns]) :-
3491 M is N - 1.
3493 extend_id(Id,[0|Id]).
3495 next_id([_,N|Ns],[O|Ns]) :-
3496 O is N + 1.
3498 build_head(F,A,Id,Args,Head) :-
3499 buildName(F,A,Id,Name),
3500 Head =.. [Name|Args].
3502 buildName(Fct,Aty,List,Result) :-
3503 atom_concat(Fct, (/) ,FctSlash),
3504 atom_concat(FctSlash,Aty,FctSlashAty),
3505 buildName_(List,FctSlashAty,Result).
3507 buildName_([],Name,Name).
3508 buildName_([N|Ns],Name,Result) :-
3509 buildName_(Ns,Name,Name1),
3510 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
3511 atom_concat(NameDash,N,Result).
3513 vars_susp(A,Vars,Susp,VarsSusp) :-
3514 length(Vars,A),
3515 append(Vars,[Susp],VarsSusp).
3517 make_attr(N,Mask,SuspsList,Attr) :-
3518 length(SuspsList,N),
3519 Attr =.. [v,Mask|SuspsList].
3521 or_pattern(Pos,Pat) :-
3522 Pow is Pos - 1,
3523 Pat is 1 << Pow. % was 2 ** X
3525 and_pattern(Pos,Pat) :-
3526 X is Pos - 1,
3527 Y is 1 << X, % was 2 ** X
3528 Pat is (-1)*(Y + 1). % because fx (-) is redefined
3530 conj2list(Conj,L) :- %% transform conjunctions to list
3531 conj2list(Conj,L,[]).
3533 conj2list(Conj,L,T) :-
3534 Conj = (G1,G2), !,
3535 conj2list(G1,L,T1),
3536 conj2list(G2,T1,T).
3537 conj2list(G,[G | T],T).
3539 list2conj([],true).
3540 list2conj([G],X) :- !, X = G.
3541 list2conj([G|Gs],C) :-
3542 ( G == true -> %% remove some redundant trues
3543 list2conj(Gs,C)
3544 ;
3545 C = (G,R),
3546 list2conj(Gs,R)
3547 ).
3549 list2disj([],fail).
3550 list2disj([G],X) :- !, X = G.
3551 list2disj([G|Gs],C) :-
3552 ( G == fail -> %% remove some redundant fails
3553 list2disj(Gs,C)
3554 ;
3555 C = (G;R),
3556 list2disj(Gs,R)
3557 ).
3559 atom_concat_list([X],X) :- ! .
3560 atom_concat_list([X|Xs],A) :-
3561 atom_concat_list(Xs,B),
3562 atom_concat(X,B,A).
3564 make_name(Prefix,F/A,Name) :-
3565 atom_concat_list([Prefix,F,(/),A],Name).
3567 set_elems([],_).
3568 set_elems([X|Xs],X) :-
3569 set_elems(Xs,X).
3571 member2([X|_],[Y|_],X-Y).
3572 member2([_|Xs],[_|Ys],P) :-
3573 member2(Xs,Ys,P).
3575 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
3576 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
3577 select2(X, Y, Xs, Ys, NXs, NYs).
3579 pair_all_with([],_,[]).
3580 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
3581 pair_all_with(Xs,Y,Rest).
3582 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3584 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
3585 functor(Head,F,A),
3586 get_store_type(F/A,StoreType),
3587 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
3589 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
3590 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
3591 instantiate_pattern_goals(AttrDict),
3592 get_max_constraint_index(N),
3593 ( N == 1 ->
3594 AllSusps = Attr
3595 ;
3596 functor(Head,F,A),
3597 get_constraint_index(F/A,Pos),
3598 make_attr(N,_,SuspsList,Attr),
3599 nth(Pos,SuspsList,AllSusps)
3600 ).
3601 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
3602 once((
3603 member(Index,Indexes),
3604 multi_hash_key_args(Index,Head,KeyArgs),
3605 translate(KeyArgs,VarDict,KeyArgCopies)
3606 )),
3607 ( KeyArgCopies = [KeyCopy] ->
3608 true
3609 ;
3610 KeyCopy =.. [k|KeyArgCopies]
3611 ),
3612 functor(Head,F,A),
3613 multi_hash_via_lookup_name(F/A,Index,ViaName),
3614 Goal =.. [ViaName,KeyCopy,AllSusps],
3615 update_store_type(F/A,multi_hash([Index])).
3616 lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :-
3617 functor(Head,F,A),
3618 global_ground_store_name(F/A,StoreName),
3619 Goal = nb_getval(StoreName,AllSusps),
3620 update_store_type(F/A,global_ground).
3621 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
3622 once((
3623 member(ST,StoreTypes),
3624 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
3625 )).
3626 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3627 assume_constraint_stores([]).
3628 assume_constraint_stores([C|Cs]) :-
3629 ( \+ may_trigger(C),
3630 is_attached(C),
3631 get_store_type(C,default) ->
3632 get_indexed_arguments(C,IndexedArgs),
3633 findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes),
3634 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
3635 ;
3636 true
3637 ),
3638 assume_constraint_stores(Cs).
3640 get_indexed_arguments(C,IndexedArgs) :-
3641 C = F/A,
3642 get_indexed_arguments(1,A,C,IndexedArgs).
3644 get_indexed_arguments(I,N,C,L) :-
3645 ( I > N ->
3646 L = []
3647 ; ( is_indexed_argument(C,I) ->
3648 L = [I|T]
3649 ;
3650 L = T
3651 ),
3652 J is I + 1,
3653 get_indexed_arguments(J,N,C,T)
3654 ).
3656 validate_store_type_assumptions([]).
3657 validate_store_type_assumptions([C|Cs]) :-
3658 validate_store_type_assumption(C),
3659 validate_store_type_assumptions(Cs).