| blob | 8d682765367c78ab251c684cded98f1854c40ace |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% URGENTLY TODO
52 %%
53 %% * 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 %% SWI begin
116 :- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]).
117 :- use_module(library(ordsets)).
118 %% SWI end
120 :- use_module(hprolog).
121 :- use_module(pairlist).
122 :- use_module(a_star).
123 :- use_module(clean_code).
124 :- use_module(builtins).
125 :- use_module(find).
126 :- include(chr_op2).
128 :- chr_option(debug,off).
129 :- chr_option(optimize,full).
131 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
132 :- chr_constraint
134 constraint/2, % constraint(F/A,ConstraintIndex)
135 get_constraint/2,
137 constraint_count/1, % constraint_count(MaxConstraintIndex)
138 get_constraint_count/1,
140 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
141 get_constraint_index/2,
143 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
144 get_max_constraint_index/1,
146 target_module/1, % target_module(Module)
147 get_target_module/1,
149 attached/2, % attached(F/A,yes/no/maybe)
150 is_attached/1,
152 indexed_argument/2, % argument instantiation may enable applicability of rule
153 is_indexed_argument/2,
155 constraint_mode/2,
156 get_constraint_mode/2,
158 may_trigger/1,
160 has_nonground_indexed_argument/3,
162 store_type/2,
163 get_store_type/2,
164 update_store_type/2,
165 actual_store_types/2,
166 assumed_store_type/2,
167 validate_store_type_assumption/1,
169 rule_count/1,
170 inc_rule_count/1,
171 get_rule_count/1,
173 passive/2,
174 is_passive/2,
175 any_passive_head/1,
177 pragma_unique/3,
178 get_pragma_unique/3,
180 occurrence/4,
181 get_occurrence/4,
183 max_occurrence/2,
184 get_max_occurrence/2,
186 allocation_occurrence/2,
187 get_allocation_occurrence/2,
188 rule/2,
189 get_rule/2
190 .
192 :- chr_option(mode,constraint(+,+)).
193 :- chr_option(mode,constraint_count(+)).
194 :- chr_option(mode,constraint_index(+,+)).
195 :- chr_option(mode,max_constraint_index(+)).
196 :- chr_option(mode,target_module(+)).
197 :- chr_option(mode,attached(+,+)).
198 :- chr_option(mode,indexed_argument(+,+)).
199 :- chr_option(mode,constraint_mode(+,+)).
200 :- chr_option(mode,may_trigger(+)).
201 :- chr_option(mode,store_type(+,+)).
202 :- chr_option(mode,actual_store_types(+,+)).
203 :- chr_option(mode,assumed_store_type(+,+)).
204 :- chr_option(mode,rule_count(+)).
205 :- chr_option(mode,passive(+,+)).
206 :- chr_option(mode,pragma_unique(+,+,?)).
207 :- chr_option(mode,occurrence(+,+,+,+)).
208 :- chr_option(mode,max_occurrence(+,+)).
209 :- chr_option(mode,allocation_occurrence(+,+)).
210 :- chr_option(mode,rule(+,+)).
212 constraint(FA,Index) \ get_constraint(Query,Index)
213 <=> Query = FA.
214 get_constraint(_,_)
215 <=> fail.
217 constraint_count(Index) \ get_constraint_count(Query)
218 <=> Query = Index.
219 get_constraint_count(Query)
220 <=> Query = 0.
222 target_module(Mod) \ get_target_module(Query)
223 <=> Query = Mod .
224 get_target_module(Query)
225 <=> Query = user.
227 constraint_index(C,Index) \ get_constraint_index(C,Query)
228 <=> Query = Index.
229 get_constraint_index(_,_)
230 <=> fail.
232 max_constraint_index(Index) \ get_max_constraint_index(Query)
233 <=> Query = Index.
234 get_max_constraint_index(Query)
235 <=> Query = 0.
237 attached(Constr,yes) \ attached(Constr,_) <=> true.
238 attached(Constr,no) \ attached(Constr,_) <=> true.
239 attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
241 attached(Constr,Type) \ is_attached(Constr)
242 <=> Type \== no.
243 is_attached(_) <=> true.
245 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
246 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
247 is_indexed_argument(_,_) <=> fail.
249 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Query)
250 <=> Query = Mode.
251 get_constraint_mode(FA,Query)
252 <=> FA = _/A, length(Query,A), set_elems(Query,?).
254 may_trigger(FA) <=>
255 is_attached(FA),
256 get_constraint_mode(FA,Mode),
257 has_nonground_indexed_argument(FA,1,Mode).
259 has_nonground_indexed_argument(FA,I,[Mode|Modes])
260 <=>
261 true
262 |
263 ( is_indexed_argument(FA,I),
264 Mode \== (+) ->
265 true
266 ;
267 J is I + 1,
268 has_nonground_indexed_argument(FA,J,Modes)
269 ).
270 has_nonground_indexed_argument(_,_,_)
271 <=> fail.
273 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
274 store_type(FA,Store) \ get_store_type(FA,Query)
275 <=> Query = Store.
276 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
277 <=> Query = Store.
278 get_store_type(_,Query)
279 <=> Query = default.
281 actual_store_types(C,STs) \ update_store_type(C,ST)
282 <=> member(ST,STs) | true.
283 update_store_type(C,ST), actual_store_types(C,STs)
284 <=>
285 actual_store_types(C,[ST|STs]).
286 update_store_type(C,ST)
287 <=>
288 actual_store_types(C,[ST]).
290 % refine store type assumption
291 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
292 <=>
293 store_type(C,multi_store(STs)).
294 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
295 <=>
296 store_type(C,multi_store(STs)).
297 validate_store_type_assumption(_)
298 <=> true.
300 rule_count(C), inc_rule_count(NC)
301 <=> NC is C + 1, rule_count(NC).
302 inc_rule_count(NC)
303 <=> NC = 1, rule_count(NC).
305 rule_count(C) \ get_rule_count(Q)
306 <=> Q = C.
307 get_rule_count(Q)
308 <=> Q = 0.
310 passive(RuleNb,ID) \ is_passive(RuleNb,ID)
311 <=> true.
312 is_passive(_,_)
313 <=> fail.
314 passive(RuleNb,_) \ any_passive_head(RuleNb)
315 <=> true.
316 any_passive_head(_)
317 <=> fail.
319 pragma_unique(RuleNb,ID,Vars) \ get_pragma_unique(RuleNb,ID,Query)
320 <=> Query = Vars.
321 get_pragma_unique(_,_,_)
322 <=> true.
324 occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
325 <=> Rule = QRule, ID = QID.
326 get_occurrence(_,_,_,_)
327 <=> fail.
329 occurrence(C,ON,_,_) ==> max_occurrence(C,ON).
330 max_occurrence(C,N) \ max_occurrence(C,M)
331 <=> N >= M | true.
332 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
333 <=> Q = MON.
334 get_max_occurrence(_,Q)
335 <=> Q = 0.
337 % need not store constraint that is removed
338 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
339 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs)
340 | NO is O + 1, allocation_occurrence(C,NO).
341 % need not store constraint when body is true
342 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
343 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
344 | NO is O + 1, allocation_occurrence(C,NO).
345 % cannot store constraint at passive occurrence
346 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
347 <=> NO is O + 1, allocation_occurrence(C,NO).
348 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
349 <=> Q = O.
350 get_allocation_occurrence(_,_)
351 <=> fail.
353 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
354 <=> Q = Rule.
355 get_rule(_,_)
356 <=> fail.
359 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
362 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
363 %%
364 %% Translation
366 chr_translate(Declarations,NewDeclarations) :-
367 init_chr_pp_flags,
368 partition_clauses(Declarations,Constraints,Rules,OtherClauses),
369 ( Constraints == [] ->
370 insert_declarations(OtherClauses, NewDeclarations)
371 ;
372 % start analysis
373 add_rules(Rules),
374 check_rules(Rules,Constraints),
375 add_occurrences(Rules),
376 late_allocation(Constraints),
377 unique_analyse_optimise(Rules,NRules),
378 check_attachments(Constraints),
379 assume_constraint_stores(Constraints),
380 set_constraint_indices(Constraints,1),
381 % end analysis
382 constraints_code(Constraints,NRules,ConstraintClauses),
383 validate_store_type_assumptions(Constraints),
384 store_management_preds(Constraints,StoreClauses), % depends on actual code used
385 insert_declarations(OtherClauses, Clauses0),
386 chr_module_declaration(CHRModuleDeclaration),
387 append([Clauses0,
388 StoreClauses,
389 ConstraintClauses,
390 CHRModuleDeclaration
391 ],
392 NewDeclarations)
393 ).
395 store_management_preds(Constraints,Clauses) :-
396 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
397 generate_indexed_variables_clauses(Constraints,IndexedClauses),
398 generate_attach_increment(AttachIncrementClauses),
399 generate_attr_unify_hook(AttrUnifyHookClauses),
400 generate_extra_clauses(Constraints,ExtraClauses),
401 generate_insert_delete_constraints(Constraints,DeleteClauses),
402 generate_store_code(Constraints,StoreClauses),
403 append([AttachAConstraintClauses
404 ,IndexedClauses
405 ,AttachIncrementClauses
406 ,AttrUnifyHookClauses
407 ,ExtraClauses
408 ,DeleteClauses
409 ,StoreClauses]
410 ,Clauses).
413 %% SWI begin
414 specific_declarations([:- use_module('chr_runtime')
415 ,:- use_module('chr_hashtable_store')
416 ,:- style_check(-discontiguous)
417 |Tail],Tail).
418 %% SWI end
420 %% SICStus begin
421 %% specific_declarations([(:- use_module('chr_runtime')),
422 %% (:- use_module('chr_hashtable_store')),
423 %% (:- set_prolog_flag(discontiguous_warnings,off)),
424 %% (:- set_prolog_flag(single_var_warnings,off))
425 %% |Tail],Tail).
426 %% SICStus end
429 insert_declarations(Clauses0, Clauses) :-
430 specific_declarations(Decls,Tail),
431 ( Clauses0 = [ (:- module(M,E))|FileBody] ->
432 Clauses = [ (:- module(M,E))|Decls],
433 Tail = FileBody
434 ;
435 Clauses = Decls,
436 Tail = Clauses0
437 ).
440 chr_module_declaration(CHRModuleDeclaration) :-
441 get_target_module(Mod),
442 ( Mod \== chr_translate ->
443 CHRModuleDeclaration = [
444 (:- multifile chr:'$chr_module'/1),
445 chr:'$chr_module'(Mod)
446 ]
447 ;
448 CHRModuleDeclaration = []
449 ).
452 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
453 %%
454 %% Partitioning of clauses into constraint declarations, chr rules and other
455 %% clauses
457 partition_clauses([],[],[],[]).
458 partition_clauses([C|Cs],Ds,Rs,OCs) :-
459 ( parse_rule(C,R) ->
460 Ds = RDs,
461 Rs = [R | RRs],
462 OCs = ROCs
463 ; is_declaration(C,D) ->
464 append(D,RDs,Ds),
465 Rs = RRs,
466 OCs = ROCs
467 ; is_module_declaration(C,Mod) ->
468 target_module(Mod),
469 Ds = RDs,
470 Rs = RRs,
471 OCs = [C|ROCs]
472 ; C = (handler _) ->
473 format('CHR compiler WARNING: ~w.\n',[C]),
474 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
475 Ds = RDs,
476 Rs = RRs,
477 OCs = ROCs
478 ; C = (rules _) ->
479 format('CHR compiler WARNING: ~w.\n',[C]),
480 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
481 Ds = RDs,
482 Rs = RRs,
483 OCs = ROCs
484 ; C = (:- chr_option(OptionName,OptionValue)) ->
485 handle_option(OptionName,OptionValue),
486 Ds = RDs,
487 Rs = RRs,
488 OCs = ROCs
489 ; C = (:- chr_type _) ->
490 Ds = RDs,
491 Rs = RRs,
492 OCs = ROCs
493 ; Ds = RDs,
494 Rs = RRs,
495 OCs = [C|ROCs]
496 ),
497 partition_clauses(Cs,RDs,RRs,ROCs).
499 is_declaration(D, Constraints) :- %% constraint declaration
500 D = (:- Decl),
501 ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
502 conj2list(Cs,Constraints).
504 %% Data Declaration
505 %%
506 %% pragma_rule
507 %% -> pragma(
508 %% rule,
509 %% ids,
510 %% list(pragma),
511 %% yesno(string), :: maybe rule nane
512 %% int :: rule number
513 %% )
514 %%
515 %% ids -> ids(
516 %% list(int),
517 %% list(int)
518 %% )
519 %%
520 %% rule -> rule(
521 %% list(constraint), :: constraints to be removed
522 %% list(constraint), :: surviving constraints
523 %% goal, :: guard
524 %% goal :: body
525 %% )
527 parse_rule(RI,R) :- %% name @ rule
528 RI = (Name @ RI2), !,
529 rule(RI2,yes(Name),R).
530 parse_rule(RI,R) :-
531 rule(RI,no,R).
533 rule(RI,Name,R) :-
534 RI = (RI2 pragma P), !, %% pragmas
535 is_rule(RI2,R1,IDs),
536 conj2list(P,Ps),
537 inc_rule_count(RuleCount),
538 R = pragma(R1,IDs,Ps,Name,RuleCount).
539 rule(RI,Name,R) :-
540 is_rule(RI,R1,IDs),
541 inc_rule_count(RuleCount),
542 R = pragma(R1,IDs,[],Name,RuleCount).
544 is_rule(RI,R,IDs) :- %% propagation rule
545 RI = (H ==> B), !,
546 conj2list(H,Head2i),
547 get_ids(Head2i,IDs2,Head2),
548 IDs = ids([],IDs2),
549 ( B = (G | RB) ->
550 R = rule([],Head2,G,RB)
551 ;
552 R = rule([],Head2,true,B)
553 ).
554 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
555 RI = (H <=> B), !,
556 ( B = (G | RB) ->
557 Guard = G,
558 Body = RB
559 ; Guard = true,
560 Body = B
561 ),
562 ( H = (H1 \ H2) ->
563 conj2list(H1,Head2i),
564 conj2list(H2,Head1i),
565 get_ids(Head2i,IDs2,Head2,0,N),
566 get_ids(Head1i,IDs1,Head1,N,_),
567 IDs = ids(IDs1,IDs2)
568 ; conj2list(H,Head1i),
569 Head2 = [],
570 get_ids(Head1i,IDs1,Head1),
571 IDs = ids(IDs1,[])
572 ),
573 R = rule(Head1,Head2,Guard,Body).
575 get_ids(Cs,IDs,NCs) :-
576 get_ids(Cs,IDs,NCs,0,_).
578 get_ids([],[],[],N,N).
579 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
580 ( C = (NC # N) ->
581 true
582 ;
583 NC = C
584 ),
585 M is N + 1,
586 get_ids(Cs,IDs,NCs, M,NN).
588 is_module_declaration((:- module(Mod)),Mod).
589 is_module_declaration((:- module(Mod,_)),Mod).
591 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
593 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
594 % Add rules
595 add_rules([]).
596 add_rules([Rule|Rules]) :-
597 Rule = pragma(_,_,_,_,RuleNb),
598 rule(RuleNb,Rule),
599 add_rules(Rules).
601 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
603 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
604 %% Some input verification:
605 %% - all constraints in heads are declared constraints
606 %% - all passive pragmas refer to actual head constraints
608 check_rules([],_).
609 check_rules([PragmaRule|Rest],Decls) :-
610 check_rule(PragmaRule,Decls),
611 check_rules(Rest,Decls).
613 check_rule(PragmaRule,Decls) :-
614 check_rule_indexing(PragmaRule),
615 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
616 Rule = rule(H1,H2,_,_),
617 append(H1,H2,HeadConstraints),
618 check_head_constraints(HeadConstraints,Decls,PragmaRule),
619 check_pragmas(Pragmas,PragmaRule).
621 check_head_constraints([],_,_).
622 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
623 functor(Constr,F,A),
624 ( member(F/A,Decls) ->
625 check_head_constraints(Rest,Decls,PragmaRule)
626 ;
627 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
628 [F/A,format_rule(PragmaRule)]),
629 format(' `--> Constraint should be one of ~w.\n',[Decls]),
630 fail
631 ).
633 check_pragmas([],_).
634 check_pragmas([Pragma|Pragmas],PragmaRule) :-
635 check_pragma(Pragma,PragmaRule),
636 check_pragmas(Pragmas,PragmaRule).
638 check_pragma(Pragma,PragmaRule) :-
639 var(Pragma), !,
640 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
641 [Pragma,format_rule(PragmaRule)]),
642 format(' `--> Pragma should not be a variable!\n',[]),
643 fail.
644 check_pragma(passive(ID), PragmaRule) :-
645 !,
646 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
647 ( memberchk_eq(ID,IDs1) ->
648 true
649 ; memberchk_eq(ID,IDs2) ->
650 true
651 ;
652 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
653 [ID,format_rule(PragmaRule)]),
654 fail
655 ),
656 passive(RuleNb,ID).
658 check_pragma(Pragma, PragmaRule) :-
659 Pragma = unique(ID,Vars),
660 !,
661 PragmaRule = pragma(_,_,_,_,RuleNb),
662 pragma_unique(RuleNb,ID,Vars),
663 format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
664 format(' `--> Only use this pragma if you know what you are doing.\n',[]).
666 check_pragma(Pragma, PragmaRule) :-
667 Pragma = already_in_heads,
668 !,
669 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
670 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
672 check_pragma(Pragma, PragmaRule) :-
673 Pragma = already_in_head(_),
674 !,
675 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
676 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
678 check_pragma(Pragma,PragmaRule) :-
679 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
680 format(' `--> Pragma should be one of passive/1!\n',[]),
681 fail.
683 format_rule(PragmaRule) :-
684 PragmaRule = pragma(_,_,_,MaybeName,N),
685 ( MaybeName = yes(Name) ->
686 write('rule '), write(Name)
687 ;
688 write('rule number '), write(N)
689 ).
691 check_rule_indexing(PragmaRule) :-
692 PragmaRule = pragma(Rule,_,_,_,_),
693 Rule = rule(H1,H2,G,_),
694 term_variables(H1-H2,HeadVars),
695 remove_anti_monotonic_guards(G,HeadVars,NG),
696 check_indexing(H1,NG-H2),
697 check_indexing(H2,NG-H1).
699 remove_anti_monotonic_guards(G,Vars,NG) :-
700 conj2list(G,GL),
701 remove_anti_monotonic_guard_list(GL,Vars,NGL),
702 list2conj(NGL,NG).
704 remove_anti_monotonic_guard_list([],_,[]).
705 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
706 ( G = var(X),
707 memberchk_eq(X,Vars) ->
708 NGs = RGs
709 ;
710 NGs = [G|RGs]
711 ),
712 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
714 check_indexing([],_).
715 check_indexing([Head|Heads],Other) :-
716 functor(Head,F,A),
717 Head =.. [_|Args],
718 term_variables(Heads-Other,OtherVars),
719 check_indexing(Args,1,F/A,OtherVars),
720 check_indexing(Heads,[Head|Other]).
722 check_indexing([],_,_,_).
723 check_indexing([Arg|Args],I,FA,OtherVars) :-
724 ( is_indexed_argument(FA,I) ->
725 true
726 ; nonvar(Arg) ->
727 indexed_argument(FA,I)
728 ; % var(Arg) ->
729 term_variables(Args,ArgsVars),
730 append(ArgsVars,OtherVars,RestVars),
731 ( memberchk_eq(Arg,RestVars) ->
732 indexed_argument(FA,I)
733 ;
734 true
735 )
736 ),
737 J is I + 1,
738 term_variables(Arg,NVars),
739 append(NVars,OtherVars,NOtherVars),
740 check_indexing(Args,J,FA,NOtherVars).
742 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
744 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
745 % Occurrences
747 add_occurrences([]).
748 add_occurrences([Rule|Rules]) :-
749 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
750 add_occurrences(H1,IDs1,Nb),
751 add_occurrences(H2,IDs2,Nb),
752 add_occurrences(Rules).
754 add_occurrences([],[],_).
755 add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
756 functor(H,F,A),
757 FA = F/A,
758 get_max_occurrence(FA,MO),
759 O is MO + 1,
760 occurrence(FA,O,RuleNb,ID),
761 add_occurrences(Hs,IDs,RuleNb).
763 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
765 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
766 % Late allocation
768 late_allocation([]).
769 late_allocation([C|Cs]) :-
770 allocation_occurrence(C,1),
771 late_allocation(Cs).
772 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
774 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
775 % Global Options
776 %
778 handle_option(Var,Value) :-
779 var(Var), !,
780 format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
781 format(' `--> First argument should be an atom, not a variable.\n',[]),
782 fail.
784 handle_option(Name,Value) :-
785 var(Value), !,
786 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
787 format(' `--> Second argument should be a nonvariable.\n',[]),
788 fail.
790 handle_option(Name,Value) :-
791 option_definition(Name,Value,Flags),
792 !,
793 set_chr_pp_flags(Flags).
795 handle_option(Name,Value) :-
796 \+ option_definition(Name,_,_), !,
797 % setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
798 format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
799 format(' `--> Invalid option name \n',[]). %~w: should be one of ~w.\n',[Name,Ns]).
801 handle_option(Name,Value) :-
802 findall(V,option_definition(Name,V,_),Vs),
803 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
804 format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
805 fail.
807 option_definition(optimize,experimental,Flags) :-
808 Flags = [ unique_analyse_optimise - on,
809 check_unnecessary_active - full,
810 reorder_heads - on,
811 set_semantics_rule - on,
812 check_attachments - on,
813 guard_via_reschedule - on
814 ].
815 option_definition(optimize,full,Flags) :-
816 Flags = [ unique_analyse_optimise - off,
817 check_unnecessary_active - full,
818 reorder_heads - on,
819 set_semantics_rule - on,
820 check_attachments - on,
821 guard_via_reschedule - on
822 ].
824 option_definition(optimize,sicstus,Flags) :-
825 Flags = [ unique_analyse_optimise - off,
826 check_unnecessary_active - simplification,
827 reorder_heads - off,
828 set_semantics_rule - off,
829 check_attachments - off,
830 guard_via_reschedule - off
831 ].
833 option_definition(optimize,off,Flags) :-
834 Flags = [ unique_analyse_optimise - off,
835 check_unnecessary_active - off,
836 reorder_heads - off,
837 set_semantics_rule - off,
838 check_attachments - off,
839 guard_via_reschedule - off
840 ].
842 option_definition(check_guard_bindings,on,Flags) :-
843 Flags = [ guard_locks - on ].
845 option_definition(check_guard_bindings,off,Flags) :-
846 Flags = [ guard_locks - off ].
848 option_definition(reduced_indexing,on,Flags) :-
849 Flags = [ reduced_indexing - on ].
851 option_definition(reduced_indexing,off,Flags) :-
852 Flags = [ reduced_indexing - off ].
854 option_definition(mode,ModeDecl,[]) :-
855 (nonvar(ModeDecl) ->
856 functor(ModeDecl,F,A),
857 ModeDecl =.. [_|ArgModes],
858 constraint_mode(F/A,ArgModes)
859 ;
860 true
861 ).
862 option_definition(store,FA-Store,[]) :-
863 store_type(FA,Store).
865 option_definition(debug,on,Flags) :-
866 Flags = [ debugable - on ].
867 option_definition(debug,off,Flags) :-
868 Flags = [ debugable - off ].
869 option_definition(type_definition, _, []). % JW: ignored by bootstrap compiler
870 option_definition(type_declaration, _, []). % JW: ignored by bootstrap compiler
871 option_definition(verbosity,_,[]).
873 init_chr_pp_flags :-
874 chr_pp_flag_definition(Name,[DefaultValue|_]),
875 set_chr_pp_flag(Name,DefaultValue),
876 fail.
877 init_chr_pp_flags.
879 set_chr_pp_flags([]).
880 set_chr_pp_flags([Name-Value|Flags]) :-
881 set_chr_pp_flag(Name,Value),
882 set_chr_pp_flags(Flags).
884 set_chr_pp_flag(Name,Value) :-
885 atom_concat('$chr_pp_',Name,GlobalVar),
886 nb_setval(GlobalVar,Value).
888 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
889 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
890 chr_pp_flag_definition(reorder_heads,[on,off]).
891 chr_pp_flag_definition(set_semantics_rule,[on,off]).
892 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
893 chr_pp_flag_definition(guard_locks,[on,off]).
894 chr_pp_flag_definition(check_attachments,[on,off]).
895 chr_pp_flag_definition(debugable,[off,on]).
896 chr_pp_flag_definition(reduced_indexing,[on,off]).
898 chr_pp_flag(Name,Value) :-
899 atom_concat('$chr_pp_',Name,GlobalVar),
900 nb_getval(GlobalVar,V),
901 ( V == [] ->
902 chr_pp_flag_definition(Name,[Value|_])
903 ;
904 V = Value
905 ).
906 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
908 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
909 %%
910 %% Generated predicates
911 %% attach_$CONSTRAINT
912 %% attach_increment
913 %% detach_$CONSTRAINT
914 %% attr_unify_hook
916 %% attach_$CONSTRAINT
917 generate_attach_detach_a_constraint_all([],[]).
918 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
919 ( may_trigger(Constraint) ->
920 generate_attach_a_constraint(Constraint,Clauses1),
921 generate_detach_a_constraint(Constraint,Clauses2)
922 ;
923 Clauses1 = [],
924 Clauses2 = []
925 ),
926 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
927 append([Clauses1,Clauses2,Clauses3],Clauses).
929 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
930 generate_attach_a_constraint_empty_list(Constraint,Clause1),
931 get_max_constraint_index(N),
932 ( N == 1 ->
933 generate_attach_a_constraint_1_1(Constraint,Clause2)
934 ;
935 generate_attach_a_constraint_t_p(Constraint,Clause2)
936 ).
938 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
939 make_name('attach_',FA,Fct),
940 Head =.. [Fct | Args],
941 Clause = ( Head :- Body).
943 generate_attach_a_constraint_empty_list(FA,Clause) :-
944 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
946 generate_attach_a_constraint_1_1(FA,Clause) :-
947 Args = [[Var|Vars],Susp],
948 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
949 generate_attach_body_1(FA,Var,Susp,AttachBody),
950 make_name('attach_',FA,Fct),
951 RecursiveCall =.. [Fct,Vars,Susp],
952 Body =
953 (
954 AttachBody,
955 RecursiveCall
956 ).
958 generate_attach_body_1(FA,Var,Susp,Body) :-
959 get_target_module(Mod),
960 Body =
961 ( get_attr(Var, Mod, Susps) ->
962 NewSusps=[Susp|Susps],
963 put_attr(Var, Mod, NewSusps)
964 ;
965 put_attr(Var, Mod, [Susp])
966 ).
968 generate_attach_a_constraint_t_p(FA,Clause) :-
969 Args = [[Var|Vars],Susp],
970 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
971 make_name('attach_',FA,Fct),
972 RecursiveCall =.. [Fct,Vars,Susp],
973 generate_attach_body_n(FA,Var,Susp,AttachBody),
974 Body =
975 (
976 AttachBody,
977 RecursiveCall
978 ).
980 generate_attach_body_n(F/A,Var,Susp,Body) :-
981 get_constraint_index(F/A,Position),
982 or_pattern(Position,Pattern),
983 get_max_constraint_index(Total),
984 make_attr(Total,Mask,SuspsList,Attr),
985 nth1(Position,SuspsList,Susps),
986 substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1),
987 make_attr(Total,Mask,SuspsList1,NewAttr1),
988 substitute_eq(Susps,SuspsList,[Susp],SuspsList2),
989 make_attr(Total,NewMask,SuspsList2,NewAttr2),
990 copy_term_nat(SuspsList,SuspsList3),
991 nth1(Position,SuspsList3,[Susp]),
992 delete(SuspsList3,[Susp],RestSuspsList),
993 set_elems(RestSuspsList,[]),
994 make_attr(Total,Pattern,SuspsList3,NewAttr3),
995 get_target_module(Mod),
996 Body =
997 ( get_attr(Var,Mod,TAttr) ->
998 TAttr = Attr,
999 ( Mask /\ Pattern =:= Pattern ->
1000 put_attr(Var, Mod, NewAttr1)
1001 ;
1002 NewMask is Mask \/ Pattern,
1003 put_attr(Var, Mod, NewAttr2)
1004 )
1005 ;
1006 put_attr(Var,Mod,NewAttr3)
1007 ).
1009 %% detach_$CONSTRAINT
1010 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1011 generate_detach_a_constraint_empty_list(Constraint,Clause1),
1012 get_max_constraint_index(N),
1013 ( N == 1 ->
1014 generate_detach_a_constraint_1_1(Constraint,Clause2)
1015 ;
1016 generate_detach_a_constraint_t_p(Constraint,Clause2)
1017 ).
1019 generate_detach_a_constraint_empty_list(FA,Clause) :-
1020 make_name('detach_',FA,Fct),
1021 Args = [[],_],
1022 Head =.. [Fct | Args],
1023 Clause = ( Head :- true).
1025 generate_detach_a_constraint_1_1(FA,Clause) :-
1026 make_name('detach_',FA,Fct),
1027 Args = [[Var|Vars],Susp],
1028 Head =.. [Fct | Args],
1029 RecursiveCall =.. [Fct,Vars,Susp],
1030 generate_detach_body_1(FA,Var,Susp,DetachBody),
1031 Body =
1032 (
1033 DetachBody,
1034 RecursiveCall
1035 ),
1036 Clause = (Head :- Body).
1038 generate_detach_body_1(FA,Var,Susp,Body) :-
1039 get_target_module(Mod),
1040 Body =
1041 ( get_attr(Var,Mod,Susps) ->
1042 'chr sbag_del_element'(Susps,Susp,NewSusps),
1043 ( NewSusps == [] ->
1044 del_attr(Var,Mod)
1045 ;
1046 put_attr(Var,Mod,NewSusps)
1047 )
1048 ;
1049 true
1050 ).
1052 generate_detach_a_constraint_t_p(FA,Clause) :-
1053 make_name('detach_',FA,Fct),
1054 Args = [[Var|Vars],Susp],
1055 Head =.. [Fct | Args],
1056 RecursiveCall =.. [Fct,Vars,Susp],
1057 generate_detach_body_n(FA,Var,Susp,DetachBody),
1058 Body =
1059 (
1060 DetachBody,
1061 RecursiveCall
1062 ),
1063 Clause = (Head :- Body).
1065 generate_detach_body_n(F/A,Var,Susp,Body) :-
1066 get_constraint_index(F/A,Position),
1067 or_pattern(Position,Pattern),
1068 and_pattern(Position,DelPattern),
1069 get_max_constraint_index(Total),
1070 make_attr(Total,Mask,SuspsList,Attr),
1071 nth1(Position,SuspsList,Susps),
1072 substitute_eq(Susps,SuspsList,[],SuspsList1),
1073 make_attr(Total,NewMask,SuspsList1,Attr1),
1074 substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
1075 make_attr(Total,Mask,SuspsList2,Attr2),
1076 get_target_module(Mod),
1077 Body =
1078 ( get_attr(Var,Mod,TAttr) ->
1079 TAttr = Attr,
1080 ( Mask /\ Pattern =:= Pattern ->
1081 'chr sbag_del_element'(Susps,Susp,NewSusps),
1082 ( NewSusps == [] ->
1083 NewMask is Mask /\ DelPattern,
1084 ( NewMask == 0 ->
1085 del_attr(Var,Mod)
1086 ;
1087 put_attr(Var,Mod,Attr1)
1088 )
1089 ;
1090 put_attr(Var,Mod,Attr2)
1091 )
1092 ;
1093 true
1094 )
1095 ;
1096 true
1097 ).
1099 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1100 generate_indexed_variables_clauses(Constraints,Clauses) :-
1101 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1102 generate_indexed_variables_clauses_(Constraints,Clauses)
1103 ;
1104 Clauses = []
1105 ).
1107 generate_indexed_variables_clauses_([],[]).
1108 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1109 ( ( is_attached(C) ; chr_pp_flag(debugable,on)) ->
1110 Clauses = [Clause|RestClauses],
1111 generate_indexed_variables_clause(C,Clause)
1112 ;
1113 Clauses = RestClauses
1114 ),
1115 generate_indexed_variables_clauses_(Cs,RestClauses).
1117 generate_indexed_variables_clause(F/A,Clause) :-
1118 functor(Term,F,A),
1119 get_constraint_mode(F/A,ArgModes),
1120 Term =.. [_|Args],
1121 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1122 ( MaybeBody == empty ->
1124 Body = (Vars = [])
1125 ; N == 0 ->
1126 Body = term_variables(Susp,Vars)
1127 ;
1128 MaybeBody = Body
1129 ),
1130 Clause =
1131 ( '$indexed_variables'(Susp,Vars) :-
1132 Susp = Term,
1133 Body
1134 ).
1136 create_indexed_variables_body([],[],_,_,_,empty,0).
1137 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1138 J is I + 1,
1139 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1140 ( Mode \== (+),
1141 is_indexed_argument(FA,I) ->
1142 ( RBody == empty ->
1143 Body = term_variables(V,Vars)
1144 ;
1145 Body = (term_variables(V,Vars,Tail),RBody)
1146 ),
1147 N = M
1148 ;
1149 Vars = Tail,
1150 Body = RBody,
1151 N is M + 1
1152 ).
1154 generate_extra_clauses(Constraints,[A,B,C,D,E]) :-
1155 ( chr_pp_flag(reduced_indexing,on) ->
1156 global_indexed_variables_clause(Constraints,D)
1157 ;
1158 D =
1159 ( chr_indexed_variables(Susp,Vars) :-
1160 'chr chr_indexed_variables'(Susp,Vars)
1161 )
1162 ),
1163 generate_remove_clause(A),
1164 generate_activate_clause(B),
1165 generate_allocate_clause(C),
1166 generate_insert_constraint_internal(E).
1168 generate_remove_clause(RemoveClause) :-
1169 RemoveClause =
1170 (
1171 remove_constraint_internal(Susp, Agenda, Delete) :-
1172 arg( 2, Susp, Mref),
1173 'chr get_mutable'( State, Mref),
1174 'chr update_mutable'( removed, Mref), % mark in any case
1175 ( compound(State) -> % passive/1
1176 Agenda = [],
1177 Delete = no
1178 ; State==removed ->
1179 Agenda = [],
1180 Delete = no
1181 %; State==triggered ->
1182 % Agenda = []
1183 ;
1184 Delete = yes,
1185 chr_indexed_variables(Susp,Agenda)
1186 )
1187 ).
1189 generate_activate_clause(ActivateClause) :-
1190 ActivateClause =
1191 (
1192 activate_constraint(Store, Vars, Susp, Generation) :-
1193 arg( 2, Susp, Mref),
1194 'chr get_mutable'( State, Mref),
1195 'chr update_mutable'( active, Mref),
1196 ( nonvar(Generation) -> % aih
1197 true
1198 ;
1199 arg( 4, Susp, Gref),
1200 'chr get_mutable'( Gen, Gref),
1201 Generation is Gen+1,
1202 'chr update_mutable'( Generation, Gref)
1203 ),
1204 ( compound(State) -> % passive/1
1205 term_variables( State, Vars),
1206 'chr none_locked'( Vars),
1207 Store = yes
1208 ; State == removed -> % the price for eager removal ...
1209 chr_indexed_variables(Susp,Vars),
1210 Store = yes
1211 ;
1212 Vars = [],
1213 Store = no
1214 )
1215 ).
1217 generate_allocate_clause(AllocateClause) :-
1218 AllocateClause =
1219 (
1220 allocate_constraint( Closure, Self, F, Args) :-
1221 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1222 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1223 'chr empty_history'(History),
1224 'chr create_mutable'(History,Href), % Href = mutable(History),
1225 chr_indexed_variables(Self,Vars),
1226 'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)),
1227 'chr gen_id'( Id)
1228 ).
1230 generate_insert_constraint_internal(Clause) :-
1231 Clause =
1232 (
1233 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1234 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1235 chr_indexed_variables(Self,Vars),
1236 'chr none_locked'(Vars),
1237 'chr create_mutable'(active,Mref), % Mref = mutable(active),
1238 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1239 'chr empty_history'(History),
1240 'chr create_mutable'(History,Href), % Href = mutable(History),
1241 'chr gen_id'(Id)
1242 ).
1244 global_indexed_variables_clause(Constraints,Clause) :-
1245 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1246 Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
1247 ;
1248 Body = true,
1249 Vars = []
1250 ),
1251 Clause = ( chr_indexed_variables(Susp,Vars) :- Body ).
1253 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1254 generate_attach_increment(Clauses) :-
1255 get_max_constraint_index(N),
1256 ( N > 0 ->
1257 Clauses = [Clause1,Clause2],
1258 generate_attach_increment_empty(Clause1),
1259 ( N == 1 ->
1260 generate_attach_increment_one(Clause2)
1261 ;
1262 generate_attach_increment_many(N,Clause2)
1263 )
1264 ;
1265 Clauses = []
1266 ).
1268 generate_attach_increment_empty((attach_increment([],_) :- true)).
1270 generate_attach_increment_one(Clause) :-
1271 Head = attach_increment([Var|Vars],Susps),
1272 get_target_module(Mod),
1273 Body =
1274 (
1275 'chr not_locked'(Var),
1276 ( get_attr(Var,Mod,VarSusps) ->
1277 sort(VarSusps,SortedVarSusps),
1278 merge(Susps,SortedVarSusps,MergedSusps),
1279 put_attr(Var,Mod,MergedSusps)
1280 ;
1281 put_attr(Var,Mod,Susps)
1282 ),
1283 attach_increment(Vars,Susps)
1284 ),
1285 Clause = (Head :- Body).
1287 generate_attach_increment_many(N,Clause) :-
1288 make_attr(N,Mask,SuspsList,Attr),
1289 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1290 Head = attach_increment([Var|Vars],Attr),
1291 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1292 list2conj(Gs,SortGoals),
1293 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1294 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1295 get_target_module(Mod),
1296 Body =
1297 (
1298 'chr not_locked'(Var),
1299 ( get_attr(Var,Mod,TOtherAttr) ->
1300 TOtherAttr = OtherAttr,
1301 SortGoals,
1302 MergedMask is Mask \/ OtherMask,
1303 put_attr(Var,Mod,NewAttr)
1304 ;
1305 put_attr(Var,Mod,Attr)
1306 ),
1307 attach_increment(Vars,Attr)
1308 ),
1309 Clause = (Head :- Body).
1311 %% attr_unify_hook
1312 generate_attr_unify_hook([Clause]) :-
1313 get_max_constraint_index(N),
1314 ( N == 0 ->
1315 get_target_module(Mod),
1316 Clause =
1317 ( attr_unify_hook(Attr,Var) :-
1318 write('ERROR: Unexpected triggering of attr_unify_hook/2 in module '),
1319 writeln(Mod)
1320 )
1321 ; N == 1 ->
1322 generate_attr_unify_hook_one(Clause)
1323 ;
1324 generate_attr_unify_hook_many(N,Clause)
1325 ).
1327 generate_attr_unify_hook_one(Clause) :-
1328 Head = attr_unify_hook(Susps,Other),
1329 get_target_module(Mod),
1330 make_run_suspensions(NewSusps,WakeNewSusps),
1331 make_run_suspensions(Susps,WakeSusps),
1332 Body =
1333 (
1334 sort(Susps, SortedSusps),
1335 ( var(Other) ->
1336 ( get_attr(Other,Mod,OtherSusps) ->
1337 true
1338 ;
1339 OtherSusps = []
1340 ),
1341 sort(OtherSusps,SortedOtherSusps),
1342 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1343 put_attr(Other,Mod,NewSusps),
1344 WakeNewSusps
1345 ;
1346 ( compound(Other) ->
1347 term_variables(Other,OtherVars),
1348 attach_increment(OtherVars, SortedSusps)
1349 ;
1350 true
1351 ),
1352 WakeSusps
1353 )
1354 ),
1355 Clause = (Head :- Body).
1357 generate_attr_unify_hook_many(N,Clause) :-
1358 make_attr(N,Mask,SuspsList,Attr),
1359 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1360 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1361 list2conj(SortGoalList,SortGoals),
1362 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1363 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1364 C = (sort(E,F),
1365 'chr merge_attributes'(D,F,G)) ),
1366 SortMergeGoalList),
1367 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1368 list2conj(SortMergeGoalList,SortMergeGoals),
1369 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1370 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1371 Head = attr_unify_hook(Attr,Other),
1372 get_target_module(Mod),
1373 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1374 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1375 Body =
1376 (
1377 SortGoals,
1378 ( var(Other) ->
1379 ( get_attr(Other,Mod,TOtherAttr) ->
1380 TOtherAttr = OtherAttr,
1381 SortMergeGoals,
1382 MergedMask is Mask \/ OtherMask,
1383 put_attr(Other,Mod,MergedAttr),
1384 WakeMergedSusps
1385 ;
1386 put_attr(Other,Mod,SortedAttr),
1387 WakeSortedSusps
1388 )
1389 ;
1390 ( compound(Other) ->
1391 term_variables(Other,OtherVars),
1392 attach_increment(OtherVars,SortedAttr)
1393 ;
1394 true
1395 ),
1396 WakeSortedSusps
1397 )
1398 ),
1399 Clause = (Head :- Body).
1401 make_run_suspensions(Susps,Goal) :-
1402 ( chr_pp_flag(debugable,on) ->
1403 Goal = 'chr run_suspensions_d'(Susps)
1404 ;
1405 Goal = 'chr run_suspensions'(Susps)
1406 ).
1408 make_run_suspensions_loop(SuspsList,Goal) :-
1409 ( chr_pp_flag(debugable,on) ->
1410 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1411 ;
1412 Goal = 'chr run_suspensions_loop'(SuspsList)
1413 ).
1415 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1416 % $insert_in_store_F/A
1417 % $delete_from_store_F/A
1419 generate_insert_delete_constraints([],[]).
1420 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1421 ( is_attached(FA) ->
1422 Clauses = [IClause,DClause|RestClauses],
1423 generate_insert_delete_constraint(FA,IClause,DClause)
1424 ;
1425 Clauses = RestClauses
1426 ),
1427 generate_insert_delete_constraints(Rest,RestClauses).
1429 generate_insert_delete_constraint(FA,IClause,DClause) :-
1430 get_store_type(FA,StoreType),
1431 generate_insert_constraint(StoreType,FA,IClause),
1432 generate_delete_constraint(StoreType,FA,DClause).
1434 generate_insert_constraint(StoreType,C,Clause) :-
1435 make_name('$insert_in_store_',C,ClauseName),
1436 Head =.. [ClauseName,Susp],
1437 generate_insert_constraint_body(StoreType,C,Susp,Body),
1438 Clause = (Head :- Body).
1440 generate_insert_constraint_body(default,C,Susp,Body) :-
1441 get_target_module(Mod),
1442 get_max_constraint_index(Total),
1443 ( Total == 1 ->
1444 generate_attach_body_1(C,Store,Susp,AttachBody)
1445 ;
1446 generate_attach_body_n(C,Store,Susp,AttachBody)
1447 ),
1448 Body =
1449 (
1450 'chr default_store'(Store),
1451 AttachBody
1452 ).
1453 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1454 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1455 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1456 global_ground_store_name(C,StoreName),
1457 make_get_store_goal(StoreName,Store,GetStoreGoal),
1458 make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
1459 Body =
1460 (
1461 GetStoreGoal, % nb_getval(StoreName,Store),
1462 UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
1463 ).
1464 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1465 find_with_var_identity(
1466 B,
1467 [Susp],
1468 (
1469 member(ST,StoreTypes),
1470 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1471 ),
1472 Bodies
1473 ),
1474 list2conj(Bodies,Body).
1476 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1477 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1478 multi_hash_store_name(FA,Index,StoreName),
1479 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1480 make_get_store_goal(StoreName,Store,GetStoreGoal),
1481 Body =
1482 (
1483 KeyBody,
1484 GetStoreGoal, % nb_getval(StoreName,Store),
1485 insert_ht(Store,Key,Susp)
1486 ),
1487 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1489 generate_delete_constraint(StoreType,FA,Clause) :-
1490 make_name('$delete_from_store_',FA,ClauseName),
1491 Head =.. [ClauseName,Susp],
1492 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1493 Clause = (Head :- Body).
1495 generate_delete_constraint_body(default,C,Susp,Body) :-
1496 get_target_module(Mod),
1497 get_max_constraint_index(Total),
1498 ( Total == 1 ->
1499 generate_detach_body_1(C,Store,Susp,DetachBody),
1500 Body =
1501 (
1502 'chr default_store'(Store),
1503 DetachBody
1504 )
1505 ;
1506 generate_detach_body_n(C,Store,Susp,DetachBody),
1507 Body =
1508 (
1509 'chr default_store'(Store),
1510 DetachBody
1511 )
1512 ).
1513 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1514 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1515 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1516 global_ground_store_name(C,StoreName),
1517 make_get_store_goal(StoreName,Store,GetStoreGoal),
1518 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
1519 Body =
1520 (
1521 GetStoreGoal, % nb_getval(StoreName,Store),
1522 'chr sbag_del_element'(Store,Susp,NStore),
1523 UpdateStoreGoal % b_setval(StoreName,NStore)
1524 ).
1525 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1526 find_with_var_identity(
1527 B,
1528 [Susp],
1529 (
1530 member(ST,StoreTypes),
1531 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1532 ),
1533 Bodies
1534 ),
1535 list2conj(Bodies,Body).
1537 generate_multi_hash_delete_constraint_bodies([],_,_,true).
1538 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1539 multi_hash_store_name(FA,Index,StoreName),
1540 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1541 make_get_store_goal(StoreName,Store,GetStoreGoal),
1542 Body =
1543 (
1544 KeyBody,
1545 GetStoreGoal, % nb_getval(StoreName,Store),
1546 delete_ht(Store,Key,Susp)
1547 ),
1548 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
1550 generate_delete_constraint_call(FA,Susp,Call) :-
1551 make_name('$delete_from_store_',FA,Functor),
1552 Call =.. [Functor,Susp].
1554 generate_insert_constraint_call(FA,Susp,Call) :-
1555 make_name('$insert_in_store_',FA,Functor),
1556 Call =.. [Functor,Susp].
1558 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1560 generate_store_code(Constraints,[Enumerate|L]) :-
1561 enumerate_stores_code(Constraints,Enumerate),
1562 generate_store_code(Constraints,L,[]).
1564 generate_store_code([],L,L).
1565 generate_store_code([C|Cs],L,T) :-
1566 get_store_type(C,StoreType),
1567 generate_store_code(StoreType,C,L,L1),
1568 generate_store_code(Cs,L1,T).
1570 generate_store_code(default,_,L,L).
1571 generate_store_code(multi_hash(Indexes),C,L,T) :-
1572 multi_hash_store_initialisations(Indexes,C,L,L1),
1573 multi_hash_via_lookups(Indexes,C,L1,T).
1574 generate_store_code(global_ground,C,L,T) :-
1575 global_ground_store_initialisation(C,L,T).
1576 generate_store_code(multi_store(StoreTypes),C,L,T) :-
1577 multi_store_generate_store_code(StoreTypes,C,L,T).
1579 multi_store_generate_store_code([],_,L,L).
1580 multi_store_generate_store_code([ST|STs],C,L,T) :-
1581 generate_store_code(ST,C,L,L1),
1582 multi_store_generate_store_code(STs,C,L1,T).
1584 multi_hash_store_initialisations([],_,L,L).
1585 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
1586 multi_hash_store_name(FA,Index,StoreName),
1587 make_init_store_goal(StoreName,HT,InitStoreGoal),
1588 L = [(:- (new_ht(HT),InitStoreGoal)) | L1],
1589 multi_hash_store_initialisations(Indexes,FA,L1,T).
1591 global_ground_store_initialisation(C,L,T) :-
1592 global_ground_store_name(C,StoreName),
1593 make_init_store_goal(StoreName,[],InitStoreGoal),
1594 L = [(:- InitStoreGoal)|T].
1596 multi_hash_via_lookups([],_,L,L).
1597 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
1598 multi_hash_via_lookup_name(C,Index,PredName),
1599 Head =.. [PredName,Key,SuspsList],
1600 multi_hash_store_name(C,Index,StoreName),
1601 make_get_store_goal(StoreName,HT,GetStoreGoal),
1602 Body =
1603 (
1604 GetStoreGoal, % nb_getval(StoreName,HT),
1605 lookup_ht(HT,Key,SuspsList)
1606 ),
1607 L = [(Head :- Body)|L1],
1608 multi_hash_via_lookups(Indexes,C,L1,T).
1610 multi_hash_via_lookup_name(F/A,Index,Name) :-
1611 ( integer(Index) ->
1612 IndexName = Index
1613 ; is_list(Index) ->
1614 atom_concat_list(Index,IndexName)
1615 ),
1616 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
1618 multi_hash_store_name(F/A,Index,Name) :-
1619 get_target_module(Mod),
1620 ( integer(Index) ->
1621 IndexName = Index
1622 ; is_list(Index) ->
1623 atom_concat_list(Index,IndexName)
1624 ),
1625 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
1627 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
1628 ( ( integer(Index) ->
1629 I = Index
1630 ;
1631 Index = [I]
1632 ) ->
1633 SuspIndex is I + 6,
1634 KeyBody = arg(SuspIndex,Susp,Key)
1635 ; is_list(Index) ->
1636 sort(Index,Indexes),
1637 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
1638 pairup(Bodies,Keys,ArgKeyPairs),
1639 Key =.. [k|Keys],
1640 list2conj(Bodies,KeyBody)
1641 ).
1643 multi_hash_key_args(Index,Head,KeyArgs) :-
1644 ( integer(Index) ->
1645 arg(Index,Head,Arg),
1646 KeyArgs = [Arg]
1647 ; is_list(Index) ->
1648 sort(Index,Indexes),
1649 term_variables(Head,Vars),
1650 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
1651 ).
1653 global_ground_store_name(F/A,Name) :-
1654 get_target_module(Mod),
1655 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
1656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1657 enumerate_stores_code(Constraints,Clause) :-
1658 Head = '$enumerate_suspensions'(Susp),
1659 enumerate_store_bodies(Constraints,Susp,Bodies),
1660 list2disj(Bodies,Body),
1661 Clause = (Head :- Body).
1663 enumerate_store_bodies([],_,[]).
1664 enumerate_store_bodies([C|Cs],Susp,L) :-
1665 ( is_attached(C) ->
1666 get_store_type(C,StoreType),
1667 enumerate_store_body(StoreType,C,Susp,B),
1668 L = [B|T]
1669 ;
1670 L = T
1671 ),
1672 enumerate_store_bodies(Cs,Susp,T).
1674 enumerate_store_body(default,C,Susp,Body) :-
1675 get_constraint_index(C,Index),
1676 get_target_module(Mod),
1677 get_max_constraint_index(MaxIndex),
1678 Body1 =
1679 (
1680 'chr default_store'(GlobalStore),
1681 get_attr(GlobalStore,Mod,Attr)
1682 ),
1683 ( MaxIndex > 1 ->
1684 NIndex is Index + 1,
1685 Body2 =
1686 (
1687 arg(NIndex,Attr,List),
1688 'chr sbag_member'(Susp,List)
1689 )
1690 ;
1691 Body2 = 'chr sbag_member'(Susp,Attr)
1692 ),
1693 Body = (Body1,Body2).
1694 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
1695 multi_hash_enumerate_store_body(Index,C,Susp,Body).
1696 enumerate_store_body(global_ground,C,Susp,Body) :-
1697 global_ground_store_name(C,StoreName),
1698 make_get_store_goal(StoreName,List,GetStoreGoal),
1699 Body =
1700 (
1701 GetStoreGoal, % nb_getval(StoreName,List),
1702 'chr sbag_member'(Susp,List)
1703 ).
1704 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
1705 once((
1706 member(ST,STs),
1707 enumerate_store_body(ST,C,Susp,Body)
1708 )).
1710 multi_hash_enumerate_store_body(I,C,Susp,B) :-
1711 multi_hash_store_name(C,I,StoreName),
1712 make_get_store_goal(StoreName,HT,GetStoreGoal),
1713 B =
1714 (
1715 GetStoreGoal, % nb_getval(StoreName,HT),
1716 value_ht(HT,Susp)
1717 ).
1718 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1719 check_attachments(Constraints) :-
1720 ( chr_pp_flag(check_attachments,on) ->
1721 check_constraint_attachments(Constraints)
1722 ;
1723 true
1724 ).
1726 check_constraint_attachments([]).
1727 check_constraint_attachments([C|Cs]) :-
1728 check_constraint_attachment(C),
1729 check_constraint_attachments(Cs).
1731 check_constraint_attachment(C) :-
1732 get_max_occurrence(C,MO),
1733 check_occurrences_attachment(C,1,MO).
1735 check_occurrences_attachment(C,O,MO) :-
1736 ( O > MO ->
1737 true
1738 ;
1739 check_occurrence_attachment(C,O),
1740 NO is O + 1,
1741 check_occurrences_attachment(C,NO,MO)
1742 ).
1744 check_occurrence_attachment(C,O) :-
1745 get_occurrence(C,O,RuleNb,ID),
1746 get_rule(RuleNb,PragmaRule),
1747 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
1748 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
1749 check_attachment_head1(Head1,ID,RuleNb,Heads1,Heads2,Guard)
1750 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
1751 check_attachment_head2(Head2,ID,RuleNb,Heads1,Body)
1752 ).
1754 check_attachment_head1(C,ID,RuleNb,H1,H2,G) :-
1755 functor(C,F,A),
1756 ( H1 == [C],
1757 H2 == [],
1758 G == true,
1759 C =.. [_|L],
1760 no_matching(L,[]),
1761 \+ is_passive(RuleNb,ID) ->
1762 attached(F/A,no)
1763 ;
1764 attached(F/A,maybe)
1765 ).
1767 no_matching([],_).
1768 no_matching([X|Xs],Prev) :-
1769 var(X),
1770 \+ memberchk_eq(X,Prev),
1771 no_matching(Xs,[X|Prev]).
1773 check_attachment_head2(C,ID,RuleNb,H1,B) :-
1774 functor(C,F,A),
1775 ( is_passive(RuleNb,ID) ->
1776 attached(F/A,maybe)
1777 ; H1 \== [],
1778 B == true ->
1779 attached(F/A,maybe)
1780 ;
1781 attached(F/A,yes)
1782 ).
1784 all_attached([]).
1785 all_attached([C|Cs]) :-
1786 functor(C,F,A),
1787 is_attached(F/A),
1788 all_attached(Cs).
1790 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1792 set_constraint_indices([],M) :-
1793 N is M - 1,
1794 max_constraint_index(N).
1795 set_constraint_indices([C|Cs],N) :-
1796 ( ( may_trigger(C) ; is_attached(C), get_store_type(C,default)) ->
1797 constraint_index(C,N),
1798 M is N + 1,
1799 set_constraint_indices(Cs,M)
1800 ;
1801 set_constraint_indices(Cs,N)
1802 ).
1804 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1805 %% ____ _ ____ _ _ _ _
1806 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
1807 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
1808 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
1809 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
1810 %% |_|
1812 constraints_code(Constraints,Rules,Clauses) :-
1813 post_constraints(Constraints,1),
1814 constraints_code1(1,Rules,L,[]),
1815 clean_clauses(L,Clauses).
1817 %% Add global data
1818 post_constraints([],MaxIndex1) :-
1819 MaxIndex is MaxIndex1 - 1,
1820 constraint_count(MaxIndex).
1821 post_constraints([F/A|Cs],N) :-
1822 constraint(F/A,N),
1823 M is N + 1,
1824 post_constraints(Cs,M).
1825 constraints_code1(I,Rules,L,T) :-
1826 get_constraint_count(N),
1827 ( I > N ->
1828 T = L
1829 ;
1830 constraint_code(I,Rules,L,T1),
1831 J is I + 1,
1832 constraints_code1(J,Rules,T1,T)
1833 ).
1835 %% Generate code for a single CHR constraint
1836 constraint_code(I, Rules, L, T) :-
1837 get_constraint(Constraint,I),
1838 constraint_prelude(Constraint,Clause),
1839 L = [Clause | L1],
1840 Id1 = [0],
1841 rules_code(Rules,I,Id1,Id2,L1,L2),
1842 gen_cond_attach_clause(Constraint,Id2,L2,T).
1844 %% Generate prelude predicate for a constraint.
1845 %% f(...) :- f/a_0(...,Susp).
1846 constraint_prelude(F/A, Clause) :-
1847 vars_susp(A,Vars,Susp,VarsSusp),
1848 Head =.. [ F | Vars],
1849 build_head(F,A,[0],VarsSusp,Delegate),
1850 get_target_module(Mod),
1851 FTerm =.. [F|Vars],
1852 ( chr_pp_flag(debugable,on) ->
1853 Clause =
1854 ( Head :-
1855 allocate_constraint(Mod : Delegate, Susp, FTerm, Vars),
1856 (
1857 'chr debug_event'(call(Susp)),
1858 Delegate
1859 ;
1860 'chr debug_event'(fail(Susp)), !,
1861 fail
1862 ),
1863 (
1864 'chr debug_event'(exit(Susp))
1865 ;
1866 'chr debug_event'(redo(Susp)),
1867 fail
1868 )
1869 )
1870 ;
1871 Clause = ( Head :- Delegate )
1872 ).
1874 gen_cond_attach_clause(F/A,Id,L,T) :-
1875 ( is_attached(F/A) ->
1876 ( Id == [0] ->
1877 ( may_trigger(F/A) ->
1878 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
1879 ;
1880 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
1881 )
1882 ; vars_susp(A,Args,Susp,AllArgs),
1883 gen_uncond_attach_goal(F/A,Susp,Body,_)
1884 ),
1885 ( chr_pp_flag(debugable,on) ->
1886 Constraint =.. [F|Args],
1887 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
1888 ;
1889 DebugEvent = true
1890 ),
1891 build_head(F,A,Id,AllArgs,Head),
1892 Clause = ( Head :- DebugEvent,Body ),
1893 L = [Clause | T]
1894 ;
1895 L = T
1896 ).
1898 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
1899 vars_susp(A,Args,Susp,AllArgs),
1900 build_head(F,A,[0],AllArgs,Closure),
1901 ( may_trigger(F/A) ->
1902 make_name('attach_',F/A,AttachF),
1903 Attach =.. [AttachF,Vars,Susp]
1904 ;
1905 Attach = true
1906 ),
1907 get_target_module(Mod),
1908 FTerm =.. [F|Args],
1909 generate_insert_constraint_call(F/A,Susp,InsertCall),
1910 Goal =
1911 (
1912 ( var(Susp) ->
1913 insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args)
1914 ;
1915 activate_constraint(Stored,Vars,Susp,_)
1916 ),
1917 ( Stored == yes ->
1918 InsertCall,
1919 Attach
1920 ;
1921 true
1922 )
1923 ).
1925 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
1926 vars_susp(A,Args,Susp,AllArgs),
1927 build_head(F,A,[0],AllArgs,Closure),
1928 ( may_trigger(F/A) ->
1929 make_name('attach_',F/A,AttachF),
1930 Attach =.. [AttachF,Vars,Susp]
1931 ;
1932 Attach = true
1933 ),
1934 get_target_module(Mod),
1935 FTerm =.. [F|Args],
1936 generate_insert_constraint_call(F/A,Susp,InsertCall),
1937 Goal =
1938 (
1939 insert_constraint_internal(_,Vars,Susp,Mod:Closure,FTerm,Args),
1940 InsertCall,
1941 Attach
1942 ).
1944 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
1945 ( may_trigger(FA) ->
1946 make_name('attach_',FA,AttachF),
1947 Attach =.. [AttachF,Vars,Susp]
1948 ;
1949 Attach = true
1950 ),
1951 generate_insert_constraint_call(FA,Susp,InsertCall),
1952 AttachGoal =
1953 (
1954 activate_constraint(Stored,Vars, Susp, Generation),
1955 ( Stored == yes ->
1956 InsertCall,
1957 Attach
1958 ;
1959 true
1960 )
1961 ).
1963 %% Generate all the code for a constraint based on all CHR rules
1964 rules_code([],_,Id,Id,L,L).
1965 rules_code([R |Rs],I,Id1,Id3,L,T) :-
1966 rule_code(R,I,Id1,Id2,L,T1),
1967 rules_code(Rs,I,Id2,Id3,T1,T).
1969 %% Generate code for a constraint based on a single CHR rule
1970 rule_code(PragmaRule,I,Id1,Id2,L,T) :-
1971 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name,_RuleNb),
1972 HeadIDs = ids(Head1IDs,Head2IDs),
1973 Rule = rule(Head1,Head2,_,_),
1974 heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
1975 heads2_code(Head2,[],Head2IDs,[],PragmaRule,I,Id1,Id2,L1,T).
1977 %% Generate code based on all the removed heads of a CHR rule
1978 heads1_code([],_,_,_,_,_,_,L,L).
1979 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
1980 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
1981 get_constraint(F/A,I),
1982 ( functor(Head,F,A),
1983 \+ is_passive(RuleNb,HeadID),
1984 \+ check_unnecessary_active(Head,RestHeads,Rule),
1985 all_attached(Heads),
1986 all_attached(RestHeads),
1987 Rule = rule(_,Heads2,_,_),
1988 all_attached(Heads2) ->
1989 append(Heads,RestHeads,OtherHeads),
1990 append(HeadIDs,RestIDs,OtherIDs),
1991 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
1992 ;
1993 L = L1
1994 ),
1995 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
1997 %% Generate code based on one removed head of a CHR rule
1998 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
1999 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2000 Rule = rule(_,Head2,_,_),
2001 ( Head2 == [] ->
2002 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
2003 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
2004 ;
2005 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2006 ).
2008 %% Generate code based on all the persistent heads of a CHR rule
2009 heads2_code([],_,_,_,_,_,Id,Id,L,L).
2010 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id1,Id3,L,T) :-
2011 PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
2012 get_constraint(F/A,I),
2013 ( functor(Head,F,A),
2014 \+ is_passive(RuleNb,HeadID),
2015 \+ check_unnecessary_active(Head,RestHeads,Rule),
2016 \+ set_semantics_rule(PragmaRule),
2017 all_attached(Heads),
2018 all_attached(RestHeads),
2019 Rule = rule(Heads1,_,_,_),
2020 all_attached(Heads1) ->
2021 append(Heads,RestHeads,OtherHeads),
2022 append(HeadIDs,RestIDs,OtherIDs),
2023 length(Heads,RestHeadNb),
2024 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,F/A,Id1,L,L0),
2025 inc_id(Id1,Id2),
2026 gen_alloc_inc_clause(F/A,Id1,L0,L1)
2027 ;
2028 L = L1,
2029 Id2 = Id1
2030 ),
2031 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id2,Id3,L1,T).
2033 %% Generate code based on one persistent head of a CHR rule
2034 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,FA,Id,L,T) :-
2035 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
2036 Rule = rule(Head1,_,_,_),
2037 ( Head1 == [] ->
2038 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,_),
2039 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
2040 ;
2041 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
2042 ).
2044 gen_alloc_inc_clause(F/A,Id,L,T) :-
2045 vars_susp(A,Vars,Susp,VarsSusp),
2046 build_head(F,A,Id,VarsSusp,Head),
2047 inc_id(Id,IncId),
2048 build_head(F,A,IncId,VarsSusp,CallHead),
2049 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,ConditionalAlloc),
2050 Clause =
2051 (
2052 Head :-
2053 ConditionalAlloc,
2054 CallHead
2055 ),
2056 L = [Clause|T].
2058 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2059 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
2060 ConstraintAllocationGoal =
2061 ( var(Susp) ->
2062 UncondConstraintAllocationGoal
2063 ;
2064 true
2065 ).
2066 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
2067 build_head(F,A,[0],VarsSusp,Term),
2068 get_target_module(Mod),
2069 FTerm =.. [F|Vars],
2070 ConstraintAllocationGoal = allocate_constraint(Mod : Term, Susp, FTerm, Vars).
2072 gen_allocation(Id,Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
2073 ( Id == [0] ->
2074 ( is_attached(FA) ->
2075 ( may_trigger(FA) ->
2076 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2077 ;
2078 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
2079 )
2080 ;
2081 ConstraintAllocationGoal = true
2082 )
2083 ;
2084 ConstraintAllocationGoal = true
2085 ).
2086 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2091 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
2092 ( chr_pp_flag(guard_via_reschedule,on) ->
2093 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
2094 ;
2095 append(Retrievals,GuardList,GoalList),
2096 list2conj(GoalList,Goal)
2097 ).
2099 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
2100 initialize_unit_dictionary(Prelude,Dict),
2101 build_units(Retrievals,GuardList,Dict,Units),
2102 dependency_reorder(Units,NUnits),
2103 units2goal(NUnits,Goal).
2105 units2goal([],true).
2106 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
2107 units2goal(Units,Goals).
2109 dependency_reorder(Units,NUnits) :-
2110 dependency_reorder(Units,[],NUnits).
2112 dependency_reorder([],Acc,Result) :-
2113 reverse(Acc,Result).
2115 dependency_reorder([Unit|Units],Acc,Result) :-
2116 Unit = unit(_GID,_Goal,Type,GIDs),
2117 ( Type == fixed ->
2118 NAcc = [Unit|Acc]
2119 ;
2120 dependency_insert(Acc,Unit,GIDs,NAcc)
2121 ),
2122 dependency_reorder(Units,NAcc,Result).
2124 dependency_insert([],Unit,_,[Unit]).
2125 dependency_insert([X|Xs],Unit,GIDs,L) :-
2126 X = unit(GID,_,_,_),
2127 ( memberchk(GID,GIDs) ->
2128 L = [Unit,X|Xs]
2129 ;
2130 L = [X | T],
2131 dependency_insert(Xs,Unit,GIDs,T)
2132 ).
2134 build_units(Retrievals,Guard,InitialDict,Units) :-
2135 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
2136 build_guard_units(Guard,N,Dict,Tail).
2138 build_retrieval_units([],N,N,Dict,Dict,L,L).
2139 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
2140 term_variables(U,Vs),
2141 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2142 L = [unit(N,U,movable,GIDs)|L1],
2143 N1 is N + 1,
2144 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
2146 build_retrieval_units2([],N,N,Dict,Dict,L,L).
2147 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
2148 term_variables(U,Vs),
2149 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
2150 L = [unit(N,U,fixed,GIDs)|L1],
2151 N1 is N + 1,
2152 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
2154 initialize_unit_dictionary(Term,Dict) :-
2155 term_variables(Term,Vars),
2156 pair_all_with(Vars,0,Dict).
2158 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
2159 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2160 ( lookup_eq(Dict,V,GID) ->
2161 ( (GID == This ; memberchk(GID,GIDs) ) ->
2162 GIDs1 = GIDs
2163 ;
2164 GIDs1 = [GID|GIDs]
2165 ),
2166 Dict1 = Dict
2167 ;
2168 Dict1 = [V - This|Dict],
2169 GIDs1 = GIDs
2170 ),
2171 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2173 build_guard_units(Guard,N,Dict,Units) :-
2174 ( Guard = [Goal] ->
2175 Units = [unit(N,Goal,fixed,[])]
2176 ; Guard = [Goal|Goals] ->
2177 term_variables(Goal,Vs),
2178 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
2179 Units = [unit(N,Goal,movable,GIDs)|RUnits],
2180 N1 is N + 1,
2181 build_guard_units(Goals,N1,NDict,RUnits)
2182 ).
2184 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
2185 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
2186 ( lookup_eq(Dict,V,GID) ->
2187 ( (GID == This ; memberchk(GID,GIDs) ) ->
2188 GIDs1 = GIDs
2189 ;
2190 GIDs1 = [GID|GIDs]
2191 ),
2192 Dict1 = [V - This|Dict]
2193 ;
2194 Dict1 = [V - This|Dict],
2195 GIDs1 = GIDs
2196 ),
2197 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
2199 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2201 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2202 %% ____ _ ____ _ _
2203 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
2204 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
2205 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
2206 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
2207 %%
2208 %% _ _ _ ___ __
2209 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
2210 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
2211 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
2212 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
2213 %% |_|
2214 unique_analyse_optimise(Rules,NRules) :-
2215 ( chr_pp_flag(unique_analyse_optimise,on) ->
2216 unique_analyse_optimise_main(Rules,1,[],NRules)
2217 ;
2218 NRules = Rules
2219 ).
2221 unique_analyse_optimise_main([],_,_,[]).
2222 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
2223 ( discover_unique_pattern(PRule,N,Pattern) ->
2224 NPatternList = [Pattern|PatternList]
2225 ;
2226 NPatternList = PatternList
2227 ),
2228 PRule = pragma(Rule,Ids,Pragmas,Name,RuleNb),
2229 Rule = rule(H1,H2,_,_),
2230 Ids = ids(Ids1,Ids2),
2231 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
2232 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
2233 globalize_unique_pragmas(MorePragmas1,RuleNb),
2234 globalize_unique_pragmas(MorePragmas2,RuleNb),
2235 append([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
2236 NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb),
2237 N1 is N + 1,
2238 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
2240 globalize_unique_pragmas([],_).
2241 globalize_unique_pragmas([unique(ID,Vars)|R],RuleNb) :-
2242 pragma_unique(RuleNb,ID,Vars),
2243 globalize_unique_pragmas(R,RuleNb).
2245 apply_unique_patterns_to_constraints([],_,_,[]).
2246 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
2247 ( member(Pattern,Patterns),
2248 apply_unique_pattern(C,Id,Pattern,Pragma) ->
2249 Pragmas = [Pragma | RPragmas]
2250 ;
2251 Pragmas = RPragmas
2252 ),
2253 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
2255 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
2256 Pattern = unique(PatternConstraint,PatternKey),
2257 subsumes(Constraint,PatternConstraint,Unifier),
2258 find_with_var_identity( V,
2259 Unifier
2260 ,
2261 (
2262 member(T,PatternKey),
2263 lookup_eq(Unifier,T,Term),
2264 term_variables(Term,Vs),
2265 member(V,Vs)
2266 ),
2267 Vars2),
2268 sort(Vars2,Vars3),
2269 Vars = Vars3,
2270 Pragma = unique(Id,Vars).
2272 % subsumes(+Term1, +Term2, -Unifier)
2273 %
2274 % If Term1 is a more general term than Term2 (e.g. has a larger
2275 % part instantiated), unify Unifier with a list Var-Value of
2276 % variables from Term2 and their corresponding values in Term1.
2278 subsumes(Term1,Term2,Unifier) :-
2279 empty_ds(S0),
2280 subsumes_aux(Term1,Term2,S0,S),
2281 ds_to_list(S,L),
2282 build_unifier(L,Unifier).
2284 subsumes_aux(Term1, Term2, S0, S) :-
2285 ( compound(Term2),
2286 functor(Term2, F, N)
2287 -> compound(Term1), functor(Term1, F, N),
2288 subsumes_aux(N, Term1, Term2, S0, S)
2289 ; Term1 == Term2
2290 -> S = S0
2291 ; var(Term2),
2292 get_ds(Term1,S0,V)
2293 -> V == Term2, S = S0
2294 ; var(Term2),
2295 put_ds(Term1, S0, Term2, S)
2296 ).
2298 subsumes_aux(0, _, _, S, S) :- ! .
2299 subsumes_aux(N, T1, T2, S0, S) :-
2300 arg(N, T1, T1x),
2301 arg(N, T2, T2x),
2302 subsumes_aux(T1x, T2x, S0, S1),
2303 M is N-1,
2304 subsumes_aux(M, T1, T2, S1, S).
2306 build_unifier([],[]).
2307 build_unifier([X-V|R],[V - X | T]) :-
2308 build_unifier(R,T).
2310 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
2311 PragmaRule = pragma(Rule,_,_Pragmas,Name,RuleNb),
2312 Rule = rule(H1,H2,Guard,_),
2313 ( H1 = [C1],
2314 H2 = [C2] ->
2315 true
2316 ; H1 = [C1,C2],
2317 H2 == [] ->
2318 true
2319 ),
2320 check_unique_constraints(C1,C2,Guard,RuleNb,List),
2321 term_variables(C1,Vs),
2322 select_pragma_unique_variables(List,Vs,Key),
2323 Pattern0 = unique(C1,Key),
2324 copy_term_nat(Pattern0,Pattern),
2325 ( verbosity_on ->
2326 format('Found unique pattern ~w in rule ~d~@\n',
2327 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
2328 ;
2329 true
2330 ).
2332 select_pragma_unique_variables([],_,[]).
2333 select_pragma_unique_variables([X-Y|R],Vs,L) :-
2334 ( X == Y ->
2335 L = [X|T]
2336 ;
2337 once((
2338 \+ memberchk_eq(X,Vs)
2339 ;
2340 \+ memberchk_eq(Y,Vs)
2341 )),
2342 L = T
2343 ),
2344 select_pragma_unique_variables(R,Vs,T).
2346 check_unique_constraints(C1,C2,G,RuleNb,List) :-
2347 \+ any_passive_head(RuleNb),
2348 variable_replacement(C1-C2,C2-C1,List),
2349 copy_with_variable_replacement(G,OtherG,List),
2350 negate_b(G,NotG),
2351 once(entails_b(NotG,OtherG)).
2353 check_unnecessary_active(Constraint,Previous,Rule) :-
2354 ( chr_pp_flag(check_unnecessary_active,full) ->
2355 check_unnecessary_active_main(Constraint,Previous,Rule)
2356 ; chr_pp_flag(check_unnecessary_active,simplification),
2357 Rule = rule(_,[],_,_) ->
2358 check_unnecessary_active_main(Constraint,Previous,Rule)
2359 ;
2360 fail
2361 ).
2363 check_unnecessary_active_main(Constraint,Previous,Rule) :-
2364 member(Other,Previous),
2365 variable_replacement(Other,Constraint,List),
2366 copy_with_variable_replacement(Rule,Rule2,List),
2367 identical_rules(Rule,Rule2), ! .
2369 set_semantics_rule(PragmaRule) :-
2370 ( chr_pp_flag(set_semantics_rule,on) ->
2371 set_semantics_rule_main(PragmaRule)
2372 ;
2373 fail
2374 ).
2376 set_semantics_rule_main(PragmaRule) :-
2377 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
2378 Rule = rule([C1],[C2],true,_),
2379 IDs = ids([ID1],[ID2]),
2380 once(member(unique(ID1,L1),Pragmas)),
2381 once(member(unique(ID2,L2),Pragmas)),
2382 L1 == L2,
2383 \+ is_passive(RuleNb,ID1).
2384 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2386 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2387 %% ____ _ _____ _ _
2388 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
2389 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
2390 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
2391 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
2392 %% |_|
2393 % have to check for no duplicates in value list
2395 % check wether two rules are identical
2397 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
2398 G1 == G2,
2399 identical_bodies(B1,B2),
2400 permutation(H11,P1),
2401 P1 == H12,
2402 permutation(H21,P2),
2403 P2 == H22.
2405 identical_bodies(B1,B2) :-
2406 ( B1 = (X1 = Y1),
2407 B2 = (X2 = Y2) ->
2408 ( X1 == X2,
2409 Y1 == Y2
2410 ; X1 == Y2,
2411 X2 == Y1
2412 ),
2413 !
2414 ; B1 == B2
2415 ).
2417 % replace variables in list
2419 copy_with_variable_replacement(X,Y,L) :-
2420 ( var(X) ->
2421 ( lookup_eq(L,X,Y) ->
2422 true
2423 ; X = Y
2424 )
2425 ; functor(X,F,A),
2426 functor(Y,F,A),
2427 X =.. [_|XArgs],
2428 Y =.. [_|YArgs],
2429 copy_with_variable_replacement_l(XArgs,YArgs,L)
2430 ).
2432 copy_with_variable_replacement_l([],[],_).
2433 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
2434 copy_with_variable_replacement(X,Y,L),
2435 copy_with_variable_replacement_l(Xs,Ys,L).
2437 %% build variable replacement list
2439 variable_replacement(X,Y,L) :-
2440 variable_replacement(X,Y,[],L).
2442 variable_replacement(X,Y,L1,L2) :-
2443 ( var(X) ->
2444 var(Y),
2445 ( lookup_eq(L1,X,Z) ->
2446 Z == Y,
2447 L2 = L1
2448 ; L2 = [X-Y|L1]
2449 )
2450 ; X =.. [F|XArgs],
2451 nonvar(Y),
2452 Y =.. [F|YArgs],
2453 variable_replacement_l(XArgs,YArgs,L1,L2)
2454 ).
2456 variable_replacement_l([],[],L,L).
2457 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
2458 variable_replacement(X,Y,L1,L2),
2459 variable_replacement_l(Xs,Ys,L2,L3).
2460 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2462 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2463 %% ____ _ _ _ __ _ _ _
2464 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
2465 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
2466 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
2467 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
2468 %% |_|
2470 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
2471 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
2472 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2473 build_head(F,A,Id,HeadVars,ClauseHead),
2474 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2476 ( RestHeads == [] ->
2477 Susps = [],
2478 VarDict = VarDict1,
2479 GetRestHeads = []
2480 ;
2481 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
2482 ),
2484 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2485 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2487 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
2488 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2490 ( chr_pp_flag(debugable,on) ->
2491 Rule = rule(_,_,Guard,Body),
2492 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2493 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
2494 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
2495 ;
2496 DebugTry = true,
2497 DebugApply = true
2498 ),
2500 Clause = ( ClauseHead :-
2501 FirstMatching,
2502 RescheduledTest,
2503 DebugTry,
2504 !,
2505 DebugApply,
2506 SuspsDetachments,
2507 SuspDetachment,
2508 BodyCopy
2509 ),
2510 L = [Clause | T].
2512 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
2513 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
2514 list2conj(GoalList,Goal).
2516 head_arg_matches_([],VarDict,[],VarDict).
2517 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
2518 ( var(Arg) ->
2519 ( lookup_eq(VarDict,Arg,OtherVar) ->
2520 GoalList = [Var == OtherVar | RestGoalList],
2521 VarDict1 = VarDict
2522 ; VarDict1 = [Arg-Var | VarDict],
2523 GoalList = RestGoalList
2524 ),
2525 Pairs = Rest
2526 ; atomic(Arg) ->
2527 GoalList = [ Var == Arg | RestGoalList],
2528 VarDict = VarDict1,
2529 Pairs = Rest
2530 ; Arg =.. [_|Args],
2531 functor(Arg,Fct,N),
2532 functor(Term,Fct,N),
2533 Term =.. [_|Vars],
2534 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
2535 pairup(Args,Vars,NewPairs),
2536 append(NewPairs,Rest,Pairs),
2537 VarDict1 = VarDict
2538 ),
2539 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
2541 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
2542 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
2544 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
2545 ( Heads = [_|_] ->
2546 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
2547 ;
2548 GoalList = [],
2549 Susps = [],
2550 VarDict = NVarDict
2551 ).
2553 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
2554 instantiate_pattern_goals(AttrDict).
2555 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
2556 functor(H,F,A),
2557 get_store_type(F/A,StoreType),
2558 ( StoreType == default ->
2559 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
2560 get_max_constraint_index(N),
2561 ( N == 1 ->
2562 VarSusps = Attr
2563 ;
2564 get_constraint_index(F/A,Pos),
2565 make_attr(N,_Mask,SuspsList,Attr),
2566 nth1(Pos,SuspsList,VarSusps)
2567 )
2568 ;
2569 lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
2570 NewAttrDict = AttrDict
2571 ),
2572 head_info(H,A,Vars,_,_,Pairs),
2573 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
2574 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
2575 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
2576 create_get_mutable_ref(active,State,GetMutable),
2577 Goal1 =
2578 (
2579 'chr sbag_member'(Susp,VarSusps),
2580 Susp = Suspension,
2581 GetMutable,
2582 DiffSuspGoals,
2583 MatchingGoal
2584 ),
2585 ( member(unique(ID,UniqueKeus),Pragmas),
2586 check_unique_keys(UniqueKeus,VarDict) ->
2587 Goal = (Goal1 -> true)
2588 ;
2589 Goal = Goal1
2590 ),
2591 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
2593 instantiate_pattern_goals([]).
2594 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
2595 get_max_constraint_index(N),
2596 ( N == 1 ->
2597 Goal = true
2598 ;
2599 make_attr(N,Mask,_,Attr),
2600 or_list(Bits,Pattern), !,
2601 Goal = (Mask /\ Pattern =:= Pattern)
2602 ),
2603 instantiate_pattern_goals(Rest).
2606 check_unique_keys([],_).
2607 check_unique_keys([V|Vs],Dict) :-
2608 lookup_eq(Dict,V,_),
2609 check_unique_keys(Vs,Dict).
2611 % Generates tests to ensure the found constraint differs from previously found constraints
2612 % TODO: detect more cases where constraints need be different
2613 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
2614 ( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
2615 list2conj(DiffSuspGoalList,DiffSuspGoals)
2616 ;
2617 DiffSuspGoals = true
2618 ).
2620 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
2621 functor(Head,F,A),
2622 get_constraint_index(F/A,Pos),
2623 common_variables(Head,PrevHeads,CommonVars),
2624 translate(CommonVars,VarDict,Vars),
2625 or_pattern(Pos,Bit),
2626 ( permutation(Vars,PermutedVars),
2627 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
2628 member(Bit,Positions), !,
2629 NewAttrDict = AttrDict,
2630 Goal = true
2631 ;
2632 Goal = (Goal1, PatternGoal),
2633 gen_get_mod_constraints(Vars,Goal1,Attr),
2634 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
2635 ).
2637 common_variables(T,Ts,Vs) :-
2638 term_variables(T,V1),
2639 term_variables(Ts,V2),
2640 intersect_eq(V1,V2,Vs).
2642 gen_get_mod_constraints(L,Goal,Susps) :-
2643 get_target_module(Mod),
2644 ( L == [] ->
2645 Goal =
2646 ( 'chr default_store'(Global),
2647 get_attr(Global,Mod,TSusps),
2648 TSusps = Susps
2649 )
2650 ;
2651 ( L = [A] ->
2652 VIA = 'chr via_1'(A,V)
2653 ; ( L = [A,B] ->
2654 VIA = 'chr via_2'(A,B,V)
2655 ; VIA = 'chr via'(L,V)
2656 )
2657 ),
2658 Goal =
2659 ( VIA,
2660 get_attr(V,Mod,TSusps),
2661 TSusps = Susps
2662 )
2663 ).
2665 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
2666 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2667 list2conj(GuardCopyList,GuardCopy).
2669 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
2670 Rule = rule(_,_,Guard,Body),
2671 conj2list(Guard,GuardList),
2672 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
2673 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
2675 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
2676 term_variables(RestGuardList,GuardVars),
2677 term_variables(RestGuardListCopyCore,GuardCopyVars),
2678 ( chr_pp_flag(guard_locks,on),
2679 find_with_var_identity(('chr lock'(Y)) - ('chr unlock'(Y)),
2680 VarDict,
2681 (member(X,GuardVars), % X is a variable appearing in the original guard
2682 lookup_eq(VarDict,X,Y), % translate X into new variable
2683 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
2684 ),
2685 LocksUnlocks)
2687 ->
2688 once(pairup(Locks,Unlocks,LocksUnlocks))
2689 ;
2690 Locks = [],
2691 Unlocks = []
2692 ),
2693 list2conj(Locks,LockPhase),
2694 list2conj(Unlocks,UnlockPhase),
2695 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
2696 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
2697 my_term_copy(Body,VarDict2,BodyCopy).
2700 split_off_simple_guard([],_,[],[]).
2701 split_off_simple_guard([G|Gs],VarDict,S,C) :-
2702 ( simple_guard(G,VarDict) ->
2703 S = [G|Ss],
2704 split_off_simple_guard(Gs,VarDict,Ss,C)
2705 ;
2706 S = [],
2707 C = [G|Gs]
2708 ).
2710 % simple guard: cheap and benign (does not bind variables)
2711 simple_guard(G,VarDict) :-
2712 binds_b(G,Vars),
2713 not(( member(V,Vars),
2714 lookup_eq(VarDict,V,_)
2715 )).
2717 my_term_copy(X,Dict,Y) :-
2718 my_term_copy(X,Dict,_,Y).
2720 my_term_copy(X,Dict1,Dict2,Y) :-
2721 ( var(X) ->
2722 ( lookup_eq(Dict1,X,Y) ->
2723 Dict2 = Dict1
2724 ; Dict2 = [X-Y|Dict1]
2725 )
2726 ; functor(X,XF,XA),
2727 functor(Y,XF,XA),
2728 X =.. [_|XArgs],
2729 Y =.. [_|YArgs],
2730 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
2731 ).
2733 my_term_copy_list([],Dict,Dict,[]).
2734 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
2735 my_term_copy(X,Dict1,Dict2,Y),
2736 my_term_copy_list(Xs,Dict2,Dict3,Ys).
2738 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
2739 ( is_attached(FA) ->
2740 ( Id == [0], \+ may_trigger(FA) ->
2741 SuspDetachment = true
2742 ;
2743 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
2744 SuspDetachment =
2745 ( var(Susp) ->
2746 true
2747 ; UnCondSuspDetachment
2748 )
2749 )
2750 ;
2751 SuspDetachment = true
2752 ).
2754 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
2755 ( is_attached(FA) ->
2756 ( may_trigger(FA) ->
2757 make_name('detach_',FA,Fct),
2758 Detach =.. [Fct,Vars,Susp]
2759 ;
2760 Detach = true
2761 ),
2762 ( chr_pp_flag(debugable,on) ->
2763 DebugEvent = 'chr debug_event'(remove(Susp))
2764 ;
2765 DebugEvent = true
2766 ),
2767 generate_delete_constraint_call(FA,Susp,DeleteCall),
2768 SuspDetachment =
2769 (
2770 DebugEvent,
2771 remove_constraint_internal(Susp, Vars, Delete),
2772 ( Delete == yes ->
2773 DeleteCall,
2774 Detach
2775 ;
2776 true
2777 )
2778 )
2779 ;
2780 SuspDetachment = true
2781 ).
2783 gen_uncond_susps_detachments([],[],true).
2784 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
2785 functor(Term,F,A),
2786 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
2787 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
2789 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2791 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2792 %% ____ _ _ _ _
2793 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
2794 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
2795 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
2796 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
2797 %% |_| |___/
2799 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
2800 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
2801 Rule = rule(_Heads,Heads2,Guard,Body),
2803 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
2804 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
2806 build_head(F,A,Id,HeadVars,ClauseHead),
2808 append(RestHeads,Heads2,Heads),
2809 append(OtherIDs,Heads2IDs,IDs),
2810 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
2811 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
2812 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
2814 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2815 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
2817 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
2818 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
2820 ( chr_pp_flag(debugable,on) ->
2821 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2822 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
2823 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
2824 ;
2825 DebugTry = true,
2826 DebugApply = true
2827 ),
2829 Clause = ( ClauseHead :-
2830 FirstMatching,
2831 RescheduledTest,
2832 DebugTry,
2833 !,
2834 DebugApply,
2835 SuspsDetachments,
2836 SuspDetachment,
2837 BodyCopy
2838 ),
2839 L = [Clause | T].
2841 split_by_ids([],[],_,[],[]).
2842 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
2843 ( memberchk_eq(I,I1s) ->
2844 S1s = [S | R1s],
2845 S2s = R2s
2846 ;
2847 S1s = R1s,
2848 S2s = [S | R2s]
2849 ),
2850 split_by_ids(Is,Ss,I1s,R1s,R2s).
2852 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2855 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2856 %% ____ _ _ _ ____
2857 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
2858 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
2859 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
2860 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
2861 %% |_| |___/
2863 %% Genereate prelude + worker predicate
2864 %% prelude calls worker
2865 %% worker iterates over one type of removed constraints
2866 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
2867 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name,RuleNb),
2868 Rule = rule(Heads1,_,Guard,Body),
2869 reorder_heads(RuleNb,Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
2870 % IDs1 = [ID1|RestIDs1],
2871 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
2872 extend_id(Id,Id2),
2873 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,PragmaRule,FA,Id2,L1,T).
2875 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2876 simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
2877 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2878 build_head(F,A,Id1,VarsSusp,ClauseHead),
2879 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
2881 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
2883 gen_allocation(Id1,Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal),
2885 extend_id(Id1,DelegateId),
2886 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2887 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
2888 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
2890 PreludeClause =
2891 ( ClauseHead :-
2892 FirstMatching,
2893 ModConstraintsGoal,
2894 !,
2895 ConstraintAllocationGoal,
2896 Delegate
2897 ),
2898 L = [PreludeClause|T].
2900 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
2901 Term =.. [_|Args],
2902 delegate_variables(Term,Terms,VarDict,Args,Vars).
2904 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
2905 term_variables(PrevTerms,PrevVars),
2906 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
2908 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
2909 term_variables(Term,V1),
2910 term_variables(Terms,V2),
2911 intersect_eq(V1,V2,V3),
2912 list_difference_eq(V3,PrevVars,V4),
2913 translate(V4,VarDict,Vars).
2916 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2917 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L,T) :-
2918 PragmaRule = pragma(Rule,_,_,_,_),
2919 Rule = rule(_,_,Guard,Body),
2920 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
2921 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L1,T).
2923 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2924 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,F/A,Id,L,T) :-
2925 gen_var(OtherSusp),
2926 gen_var(OtherSusps),
2928 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
2929 head_arg_matches(Head2Pairs,[],_,VarDict1),
2931 PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
2932 Rule = rule(_,_,Guard,Body),
2933 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
2934 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
2935 build_head(F,A,Id,HeadVars,ClauseHead),
2937 functor(Head1,_OtherF,OtherA),
2938 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
2939 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
2941 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
2942 create_get_mutable_ref(active,OtherState,GetMutable),
2943 IteratorSuspTest =
2944 ( OtherSusp = OtherSuspension,
2945 GetMutable
2946 ),
2948 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
2949 append(RestHeads1,RestHeads2,RestHeads),
2950 append(IDs1,IDs2,IDs),
2951 reorder_heads(RuleNb,Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
2952 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
2953 split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
2954 ; RestSuspsRetrieval = [],
2955 Susps1 = [],
2956 Susps2 = [],
2957 VarDict = VarDict2
2958 ),
2960 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
2962 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
2963 build_head(F,A,Id,RecursiveVars,RecursiveCall),
2964 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
2965 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
2967 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2968 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
2969 ( BodyCopy \== true ->
2970 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2971 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2972 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
2973 ; Attachment = true,
2974 ConditionalRecursiveCall = RecursiveCall,
2975 ConditionalRecursiveCall2 = RecursiveCall2
2976 ),
2978 ( chr_pp_flag(debugable,on) ->
2979 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2980 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
2981 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
2982 ;
2983 DebugTry = true,
2984 DebugApply = true
2985 ),
2987 ( member(unique(ID1,UniqueKeys), Pragmas),
2988 check_unique_keys(UniqueKeys,VarDict1) ->
2989 Clause =
2990 ( ClauseHead :-
2991 ( IteratorSuspTest,
2992 FirstMatching ->
2993 ( RescheduledTest,
2994 DebugTry ->
2995 DebugApply,
2996 Susps1Detachments,
2997 Attachment,
2998 BodyCopy,
2999 ConditionalRecursiveCall2
3000 ;
3001 RecursiveCall2
3002 )
3003 ;
3004 RecursiveCall
3005 )
3006 )
3007 ;
3008 Clause =
3009 ( ClauseHead :-
3010 ( IteratorSuspTest,
3011 FirstMatching,
3012 RescheduledTest,
3013 DebugTry ->
3014 DebugApply,
3015 Susps1Detachments,
3016 Attachment,
3017 BodyCopy,
3018 ConditionalRecursiveCall
3019 ;
3020 RecursiveCall
3021 )
3022 )
3023 ),
3024 L = [Clause | T].
3026 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
3027 length(Args,N),
3028 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
3029 create_get_mutable_ref(active,State,GetState),
3030 create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
3031 ConditionalCall =
3032 ( Susp = Suspension,
3033 GetState,
3034 GetGeneration ->
3035 'chr update_mutable'(inactive,State),
3036 Call
3037 ; true
3038 ).
3040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3041 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
3042 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
3043 head_arg_matches(Pairs,[],_,VarDict),
3044 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
3045 append([[]|VarsSusp],ExtraVars,HeadVars),
3046 build_head(F,A,Id,HeadVars,ClauseHead),
3047 next_id(Id,ContinuationId),
3048 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
3049 Clause = ( ClauseHead :- ContinuationHead ),
3050 L = [Clause | T].
3052 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3055 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3056 %% ____ _ _
3057 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
3058 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
3059 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
3060 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
3061 %% |_| |___/
3063 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3064 ( RestHeads == [] ->
3065 propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
3066 ;
3067 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
3068 ).
3069 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3070 %% Single headed propagation
3071 %% everything in a single clause
3072 propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
3073 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3074 build_head(F,A,Id,VarsSusp,ClauseHead),
3076 inc_id(Id,NextId),
3077 build_head(F,A,NextId,VarsSusp,NextHead),
3079 NextCall = NextHead,
3081 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
3082 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3083 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,Allocation),
3084 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
3086 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
3088 ( chr_pp_flag(debugable,on) ->
3089 Rule = rule(_,_,Guard,Body),
3090 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3091 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
3092 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
3093 ;
3094 DebugTry = true,
3095 DebugApply = true
3096 ),
3098 Clause = (
3099 ClauseHead :-
3100 HeadMatching,
3101 Allocation,
3102 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
3103 GuardCopy,
3104 DebugTry,
3105 !,
3106 DebugApply,
3107 'chr extend_history'(Susp,RuleNb),
3108 Attachment,
3109 BodyCopy,
3110 ConditionalNextCall
3111 ),
3112 L = [Clause | T].
3114 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3115 %% multi headed propagation
3116 %% prelude + predicates to accumulate the necessary combinations of suspended
3117 %% constraints + predicate to execute the body
3118 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3119 RestHeads = [First|Rest],
3120 propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
3121 extend_id(Id,ExtendedId),
3122 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
3124 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3125 propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
3126 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3127 build_head(F,A,Id,VarsSusp,PreludeHead),
3128 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
3129 Rule = rule(_,_,Guard,Body),
3130 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
3132 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
3134 gen_allocation(Id,Vars,Susp,F/A,VarsSusp,CondAllocation),
3136 extend_id(Id,NestedId),
3137 append([Susps|VarsSusp],ExtraVars,NestedVars),
3138 build_head(F,A,NestedId,NestedVars,NestedHead),
3139 NestedCall = NestedHead,
3141 Prelude = (
3142 PreludeHead :-
3143 FirstMatching,
3144 FirstSuspGoal,
3145 !,
3146 CondAllocation,
3147 NestedCall
3148 ),
3149 L = [Prelude|T].
3151 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3152 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3153 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
3154 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
3156 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
3157 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
3158 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
3159 inc_id(Id,IncId),
3160 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
3162 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
3163 Rule = rule(_,_,Guard,Body),
3164 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
3165 gen_var(OtherSusp),
3166 gen_var(OtherSusps),
3167 functor(CurrentHead,_OtherF,OtherA),
3168 gen_vars(OtherA,OtherVars),
3169 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3170 create_get_mutable_ref(active,State,GetMutable),
3171 CurrentSuspTest = (
3172 OtherSusp = Suspension,
3173 GetMutable
3174 ),
3175 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3176 build_head(F,A,Id,ClauseVars,ClauseHead),
3177 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3178 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3179 RecursiveCall = RecursiveHead,
3180 CurrentHead =.. [_|OtherArgs],
3181 pairup(OtherArgs,OtherVars,OtherPairs),
3182 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
3184 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
3186 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
3187 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
3188 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
3190 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
3191 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
3192 list2conj(NovelProductionsList,NovelProductions),
3193 Tuple =.. [t,RuleNb|HistorySusps],
3195 ( chr_pp_flag(debugable,on) ->
3196 Rule = rule(_,_,Guard,Body),
3197 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
3198 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
3199 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
3200 ;
3201 DebugTry = true,
3202 DebugApply = true
3203 ),
3205 Clause = (
3206 ClauseHead :-
3207 ( CurrentSuspTest,
3208 DiffSuspGoals,
3209 Matching,
3210 TupleVar = Tuple,
3211 NovelProductions,
3212 GuardCopy,
3213 DebugTry ->
3214 DebugApply,
3215 'chr extend_history'(Susp,TupleVar),
3216 Attach,
3217 BodyCopy,
3218 ConditionalRecursiveCall
3219 ; RecursiveCall
3220 )
3221 ),
3222 L = [Clause|T].
3224 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
3225 ( Count == 0 ->
3226 reverse(OtherSusps,ReversedSusps),
3227 append(ReversedSusps,[Susp|Acc],HistorySusps)
3228 ;
3229 OtherSusps = [OtherSusp|RestOtherSusps],
3230 NCount is Count - 1,
3231 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
3232 ).
3234 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
3235 !,
3236 functor(Head,_F,A),
3237 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
3238 head_arg_matches(Pairs,[],_,VarDict),
3239 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3240 append(VarsSusp,ExtraVars,HeadVars).
3241 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
3242 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
3243 functor(Head,_F,A),
3244 gen_var(Susps),
3245 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
3246 head_arg_matches(Pairs,VarDict,_,NVarDict),
3247 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3248 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
3250 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
3251 Rule = rule(_,_,Guard,Body),
3252 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
3254 Vars = [ [] | VarsAndSusps],
3256 build_head(F,A,Id,Vars,Head),
3258 ( Id = [0|_] ->
3259 next_id(Id,PrevId),
3260 PrevVarsAndSusps = AllButFirst
3261 ;
3262 dec_id(Id,PrevId),
3263 PrevVarsAndSusps = [FirstSusp|AllButFirst]
3264 ),
3266 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
3267 PredecessorCall = PrevHead,
3269 Clause = (
3270 Head :-
3271 PredecessorCall
3272 ),
3273 L = [Clause | T].
3275 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
3276 !,
3277 functor(Head,_F,A),
3278 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
3279 head_arg_matches(HeadPairs,[],_,VarDict),
3280 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3281 append(VarsSusp,ExtraVars,HeadVars).
3282 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
3283 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
3284 functor(Head,_F,A),
3285 gen_var(Susps),
3286 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3287 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3288 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3289 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
3291 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
3292 Rule = rule(_,_,Guard,Body),
3293 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
3294 gen_var(OtherSusps),
3295 functor(CurrentHead,_OtherF,OtherA),
3296 gen_vars(OtherA,OtherVars),
3297 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
3298 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
3300 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
3302 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
3303 create_get_mutable_ref(active,State,GetMutable),
3304 CurrentSuspTest = (
3305 OtherSusp = OtherSuspension,
3306 GetMutable,
3307 DiffSuspGoals,
3308 FirstMatching
3309 ),
3310 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
3311 inc_id(Id,NestedId),
3312 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
3313 build_head(F,A,Id,ClauseVars,ClauseHead),
3314 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
3315 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
3316 build_head(F,A,NestedId,NestedVars,NestedHead),
3318 RecursiveVars = [OtherSusps|PreVarsAndSusps],
3319 build_head(F,A,Id,RecursiveVars,RecursiveHead),
3320 Clause = (
3321 ClauseHead :-
3322 ( CurrentSuspTest,
3323 NextSuspGoal
3324 ->
3325 NestedHead
3326 ; RecursiveHead
3327 )
3328 ),
3329 L = [Clause|T].
3331 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
3332 !,
3333 functor(Head,_F,A),
3334 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
3335 head_arg_matches(HeadPairs,[],_,VarDict),
3336 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
3337 append(VarsSusp,ExtraVars,HeadVars).
3338 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
3339 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
3340 functor(Head,_F,A),
3341 gen_var(NextSusps),
3342 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
3343 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
3344 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
3345 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
3347 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3349 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3350 %% ____ _ _ _ _
3351 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
3352 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
3353 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
3354 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
3355 %%
3356 %% ____ _ _ _
3357 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
3358 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
3359 %% | _ < __/ |_| | | | __/\ V / (_| | |
3360 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
3361 %%
3362 %% ____ _ _
3363 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
3364 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
3365 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
3366 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
3367 %% |___/
3369 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3370 ( chr_pp_flag(reorder_heads,on) ->
3371 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
3372 ;
3373 NRestHeads = RestHeads,
3374 NRestIDs = RestIDs
3375 ).
3377 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
3378 term_variables(Head,Vars),
3379 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
3380 a_star(InitialData,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
3381 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
3382 reverse(RNRestHeads,NRestHeads),
3383 reverse(RNRestIDs,NRestIDs).
3385 final_data(Entry) :-
3386 Entry = entry(_,_,_,_,[],_).
3388 expand_data(Entry,NEntry,Cost) :-
3389 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
3390 term_variables(Entry,EVars),
3391 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
3392 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
3393 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost),
3394 term_variables([Head1|Vars],Vars1).
3396 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3397 functor(Head,F,A),
3398 get_store_type(F/A,StoreType),
3399 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
3401 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3402 term_variables(Head,HeadVars),
3403 term_variables(RestHeads,RestVars),
3404 order_score_vars(HeadVars,KnownVars,RestHeads,0,Score).
3405 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
3406 order_score_indexes(Indexes,Head,KnownVars,0,Score).
3407 order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :-
3408 functor(Head,F,A),
3409 ( get_pragma_unique(RuleNb,ID,Vars),
3410 Vars == [] ->
3411 Score = 1 % guaranteed O(1)
3412 ; A == 0 -> % flag constraint
3413 Score = 10 % O(1)? [CHECK: no deleted/triggered/... constraints in store?]
3414 ; A > 0 ->
3415 Score = 100
3416 ).
3418 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
3419 find_with_var_identity(
3420 S,
3421 t(Head,KnownVars,RestHeads),
3422 ( member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
3423 Scores
3424 ),
3425 min_list(Scores,Score).
3428 order_score_indexes([],_,_,Score,Score) :-
3429 Score > 0.
3430 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
3431 multi_hash_key_args(I,Head,Args),
3432 ( forall(Arg,Args,hprolog:memberchk_eq(Arg,KnownVars)) ->
3433 Score1 is Score + 10
3434 ;
3435 Score1 = Score
3436 ),
3437 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
3439 order_score_vars([],_,_,Score,NScore) :-
3440 ( Score == 0 ->
3441 NScore = 0
3442 ;
3443 NScore = Score
3444 ).
3445 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
3446 ( memberchk_eq(V,KnownVars) ->
3447 TScore is Score + 10
3448 ; memberchk_eq(V,RestVars) ->
3449 TScore is Score + 100
3450 ;
3451 TScore = Score
3452 ),
3453 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
3455 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3456 %% ___ _ _ _
3457 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
3458 %% | || '_ \| | | '_ \| | '_ \ / _` |
3459 %% | || | | | | | | | | | | | | (_| |
3460 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
3461 %% |___/
3463 %% SWI begin
3464 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
3465 %% SWI end
3467 %% SICStus begin
3468 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
3469 %% SICStus end
3471 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3473 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3474 %% _ _ _ _ _ _ _
3475 %% | | | | |_(_) (_) |_ _ _
3476 %% | | | | __| | | | __| | | |
3477 %% | |_| | |_| | | | |_| |_| |
3478 %% \___/ \__|_|_|_|\__|\__, |
3479 %% |___/
3481 gen_var(_).
3482 gen_vars(N,Xs) :-
3483 length(Xs,N).
3485 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
3486 vars_susp(A,Vars,Susp,VarsSusp),
3487 Head =.. [_|Args],
3488 pairup(Args,Vars,HeadPairs).
3490 inc_id([N|Ns],[O|Ns]) :-
3491 O is N + 1.
3492 dec_id([N|Ns],[M|Ns]) :-
3493 M is N - 1.
3495 extend_id(Id,[0|Id]).
3497 next_id([_,N|Ns],[O|Ns]) :-
3498 O is N + 1.
3500 build_head(F,A,Id,Args,Head) :-
3501 buildName(F,A,Id,Name),
3502 Head =.. [Name|Args].
3504 buildName(Fct,Aty,List,Result) :-
3505 atom_concat(Fct, (/) ,FctSlash),
3506 atomic_concat(FctSlash,Aty,FctSlashAty),
3507 buildName_(List,FctSlashAty,Result).
3509 buildName_([],Name,Name).
3510 buildName_([N|Ns],Name,Result) :-
3511 buildName_(Ns,Name,Name1),
3512 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
3513 atomic_concat(NameDash,N,Result).
3515 vars_susp(A,Vars,Susp,VarsSusp) :-
3516 length(Vars,A),
3517 append(Vars,[Susp],VarsSusp).
3519 make_attr(N,Mask,SuspsList,Attr) :-
3520 length(SuspsList,N),
3521 Attr =.. [v,Mask|SuspsList].
3523 or_pattern(Pos,Pat) :-
3524 Pow is Pos - 1,
3525 Pat is 1 << Pow. % was 2 ** X
3527 and_pattern(Pos,Pat) :-
3528 X is Pos - 1,
3529 Y is 1 << X, % was 2 ** X
3530 Pat is (-1)*(Y + 1). % because fx (-) is redefined
3532 conj2list(Conj,L) :- %% transform conjunctions to list
3533 conj2list(Conj,L,[]).
3535 conj2list(Conj,L,T) :-
3536 Conj = (G1,G2), !,
3537 conj2list(G1,L,T1),
3538 conj2list(G2,T1,T).
3539 conj2list(G,[G | T],T).
3541 list2conj([],true).
3542 list2conj([G],X) :- !, X = G.
3543 list2conj([G|Gs],C) :-
3544 ( G == true -> %% remove some redundant trues
3545 list2conj(Gs,C)
3546 ;
3547 C = (G,R),
3548 list2conj(Gs,R)
3549 ).
3551 list2disj([],fail).
3552 list2disj([G],X) :- !, X = G.
3553 list2disj([G|Gs],C) :-
3554 ( G == fail -> %% remove some redundant fails
3555 list2disj(Gs,C)
3556 ;
3557 C = (G;R),
3558 list2disj(Gs,R)
3559 ).
3561 atom_concat_list([X],X) :- ! .
3562 atom_concat_list([X|Xs],A) :-
3563 atom_concat_list(Xs,B),
3564 atomic_concat(X,B,A).
3566 atomic_concat(A,B,C) :-
3567 make_atom(A,AA),
3568 make_atom(B,BB),
3569 atom_concat(AA,BB,C).
3571 make_atom(A,AA) :-
3572 (
3573 atom(A) ->
3574 AA = A
3575 ;
3576 number(A) ->
3577 number_codes(A,AL),
3578 atom_codes(AA,AL)
3579 ).
3582 make_name(Prefix,F/A,Name) :-
3583 atom_concat_list([Prefix,F,(/),A],Name).
3585 set_elems([],_).
3586 set_elems([X|Xs],X) :-
3587 set_elems(Xs,X).
3589 member2([X|_],[Y|_],X-Y).
3590 member2([_|Xs],[_|Ys],P) :-
3591 member2(Xs,Ys,P).
3593 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
3594 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
3595 select2(X, Y, Xs, Ys, NXs, NYs).
3597 pair_all_with([],_,[]).
3598 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
3599 pair_all_with(Xs,Y,Rest).
3600 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3602 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
3603 functor(Head,F,A),
3604 get_store_type(F/A,StoreType),
3605 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
3607 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
3608 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
3609 instantiate_pattern_goals(AttrDict),
3610 get_max_constraint_index(N),
3611 ( N == 1 ->
3612 AllSusps = Attr
3613 ;
3614 functor(Head,F,A),
3615 get_constraint_index(F/A,Pos),
3616 make_attr(N,_,SuspsList,Attr),
3617 nth1(Pos,SuspsList,AllSusps)
3618 ).
3619 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
3620 once((
3621 member(Index,Indexes),
3622 multi_hash_key_args(Index,Head,KeyArgs),
3623 translate(KeyArgs,VarDict,KeyArgCopies)
3624 )),
3625 ( KeyArgCopies = [KeyCopy] ->
3626 true
3627 ;
3628 KeyCopy =.. [k|KeyArgCopies]
3629 ),
3630 functor(Head,F,A),
3631 multi_hash_via_lookup_name(F/A,Index,ViaName),
3632 Goal =.. [ViaName,KeyCopy,AllSusps],
3633 update_store_type(F/A,multi_hash([Index])).
3634 lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :-
3635 functor(Head,F,A),
3636 global_ground_store_name(F/A,StoreName),
3637 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
3638 update_store_type(F/A,global_ground).
3639 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
3640 once((
3641 member(ST,StoreTypes),
3642 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
3643 )).
3644 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3645 assume_constraint_stores([]).
3646 assume_constraint_stores([C|Cs]) :-
3647 ( \+ may_trigger(C),
3648 is_attached(C),
3649 get_store_type(C,default) ->
3650 get_indexed_arguments(C,IndexedArgs),
3651 findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes),
3652 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
3653 ;
3654 true
3655 ),
3656 assume_constraint_stores(Cs).
3658 get_indexed_arguments(C,IndexedArgs) :-
3659 C = F/A,
3660 get_indexed_arguments(1,A,C,IndexedArgs).
3662 get_indexed_arguments(I,N,C,L) :-
3663 ( I > N ->
3664 L = []
3665 ; ( is_indexed_argument(C,I) ->
3666 L = [I|T]
3667 ;
3668 L = T
3669 ),
3670 J is I + 1,
3671 get_indexed_arguments(J,N,C,T)
3672 ).
3674 validate_store_type_assumptions([]).
3675 validate_store_type_assumptions([C|Cs]) :-
3676 validate_store_type_assumption(C),
3677 validate_store_type_assumptions(Cs).
3679 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3681 %% SWI begin
3682 verbosity_on :- prolog_flag(verbose,V), V == yes.
3683 %% SWI end
3685 %% SICStus begin
3686 %% verbosity_on. % at the moment
3687 %% SICStus end