| blob | 18b4486c21bbb29e1394020270d6e88cec208136 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% URGENTLY TODO
52 %%
53 %% * ground matching seems to be not optimized for compound terms
54 %% * add groundness info to a.i.-based observation analysis
55 %% * proper fd/index analysis
56 %% * re-add generation checking
57 %%
58 %% AGGRESSIVE OPTIMISATION IDEAS
59 %%
60 %% * continuation optimization
61 %% * analyze history usage to determine whether/when
62 %% cheaper suspension is possible
63 %% * store constraint unconditionally for unconditional propagation rule,
64 %% if first, i.e. without checking history and set trigger cont to next occ
65 %% * get rid of suspension passing for never triggered constraints,
66 %% up to allocation occurrence
67 %% * get rid of call indirection for never triggered constraints
68 %% up to first allocation occurrence.
69 %% * get rid of unnecessary indirection if last active occurrence
70 %% before unconditional removal is head2, e.g.
71 %% a \ b <=> true.
72 %% a <=> true.
73 %% * Eliminate last clause of never stored constraint, if its body
74 %% is fail.
75 %% * Specialize lookup operations and indexes for functional dependencies.
76 %%
77 %% MORE TODO
78 %%
79 %% * Do not unnecessarily generate store operations.
80 %% * further specialize runtime predicates for special cases where
81 %% - none of the constraints contain any indexing variables, ...
82 %% - just one constraint requires some runtime predicate
83 %% * analysis for storage delaying (see primes for case)
84 %% * internal constraints declaration + analyses?
85 %% * Do not store in global variable store if not necessary
86 %% NOTE: affects show_store/1
87 %% * multi-level store: variable - ground
88 %% * Do not maintain/check unnecessary propagation history
89 %% for rules that cannot be applied more than once
90 %% for reasons of anti-monotony
91 %% * Strengthen storage analysis for propagation rules
92 %% reason about bodies of rules only containing constraints
93 %% -> fixpoint with overservation analysis
94 %% * SICStus compatibility
95 %% - options
96 %% - pragmas
97 %% - tell guard
98 %% * instantiation declarations
99 %% POTENTIAL GAIN:
100 %% VARIABLE (never bound)
101 %%
102 %% * make difference between cheap guards for reordering
103 %% and non-binding guards for lock removal
104 %% * unqiue -> once/[] transformation for propagation
105 %% * cheap guards interleaved with head retrieval + faster
106 %% via-retrieval + non-empty checking for propagation rules
107 %% redo for simpagation_head2 prelude
108 %% * intelligent backtracking for simplification/simpagation rule
109 %% generator_1(X),'_$savecp'(CP_1),
110 %% ...
111 %% if( (
112 %% generator_n(Y),
113 %% test(X,Y)
114 %% ),
115 %% true,
116 %% ('_$cutto'(CP_1), fail)
117 %% ),
118 %% ...
119 %%
120 %% or recently developped cascading-supported approach
121 %% * intelligent backtracking for propagation rule
122 %% use additional boolean argument for each possible smart backtracking
123 %% when boolean at end of list true -> no smart backtracking
124 %% false -> smart backtracking
125 %% only works for rules with at least 3 constraints in the head
126 %% * (set semantics + functional dependency) declaration + resolution
127 %%
128 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
129 :- module(chr_translate,
130 [ chr_translate/2 % +Decls, -TranslatedDecls
131 ]).
132 :- use_module(library(lists)).
133 :- use_module(hprolog).
134 :- use_module(library(assoc)).
135 :- use_module(pairlist).
136 :- use_module(library(ordsets)).
137 :- use_module(a_star).
138 :- use_module(listmap).
139 :- use_module(clean_code).
140 :- use_module(builtins).
141 :- use_module(find).
142 :- use_module(guard_entailment).
143 :- use_module(chr_compiler_options).
144 :- use_module(chr_compiler_utility).
145 :- include(chr_op).
146 :- op(1150, fx, chr_type).
147 :- op(1130, xfx, --->).
148 :- op(1150, fx, (+)).
149 :- op(1150, fx, (-)).
150 :- op(1150, fx, (?)).
152 option(debug,off).
153 option(optimize,full).
155 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
156 :- constraints
158 target_module/1, % target_module(Module)
159 get_target_module/1,
161 indexed_argument/2, % argument instantiation may enable applicability of rule
162 is_indexed_argument/2,
164 constraint_mode/2,
165 get_constraint_mode/2,
167 may_trigger/1,
169 store_type/2,
170 get_store_type/2,
171 update_store_type/2,
172 actual_store_types/2,
173 assumed_store_type/2,
174 validate_store_type_assumption/1,
176 rule_count/1,
177 inc_rule_count/1,
179 passive/2,
180 is_passive/2,
181 any_passive_head/1,
184 new_occurrence/3,
185 occurrence/4,
186 get_occurrence/4,
188 max_occurrence/2,
189 get_max_occurrence/2,
191 allocation_occurrence/2,
192 get_allocation_occurrence/2,
193 rule/2,
194 get_rule/2,
195 least_occurrence/2,
196 is_least_occurrence/1
197 .
199 option(mode,target_module(+)).
200 option(mode,indexed_argument(+,+)).
201 option(mode,constraint_mode(+,+)).
202 option(mode,may_trigger(+)).
203 option(mode,store_type(+,+)).
204 option(mode,actual_store_types(+,+)).
205 option(mode,assumed_store_type(+,+)).
206 option(mode,rule_count(+)).
207 option(mode,passive(+,+)).
208 option(mode,occurrence(+,+,+,+)).
209 option(mode,max_occurrence(+,+)).
210 option(mode,allocation_occurrence(+,+)).
211 option(mode,rule(+,+)).
212 option(mode,least_occurrence(+,+)).
213 option(mode,is_least_occurrence(+)).
215 option(type_definition,type(list,[ [], [any|list] ])).
216 option(type_definition,type(constraint,[ any / any ])).
218 option(type_declaration,constraint_mode(constraint,list)).
220 target_module(_) \ target_module(_) <=> true.
221 target_module(Mod) \ get_target_module(Query)
222 <=> Query = Mod .
223 get_target_module(Query)
224 <=> Query = user.
226 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
227 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
228 is_indexed_argument(_,_) <=> fail.
230 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
232 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
233 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
234 Q = Mode.
235 get_constraint_mode(FA,Q) <=>
236 FA = _ / N,
237 replicate(N,(?),Q).
239 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
241 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
242 nth(I,Mode,M),
243 M \== (+)|
244 is_stored(FA).
245 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
247 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
249 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
250 store_type(FA,Store) \ get_store_type(FA,Query)
251 <=> Query = Store.
252 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
253 <=> Query = Store.
254 get_store_type(_,Query)
255 <=> Query = default.
257 actual_store_types(C,STs) \ update_store_type(C,ST)
258 <=> member(ST,STs) | true.
259 update_store_type(C,ST), actual_store_types(C,STs)
260 <=>
261 actual_store_types(C,[ST|STs]).
262 update_store_type(C,ST)
263 <=>
264 actual_store_types(C,[ST]).
266 % refine store type assumption
267 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
268 <=>
269 store_type(C,multi_store(STs)).
270 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
271 <=>
272 store_type(C,multi_store(STs)).
273 validate_store_type_assumption(_)
274 <=> true.
276 rule_count(C), inc_rule_count(NC)
277 <=> NC is C + 1, rule_count(NC).
278 inc_rule_count(NC)
279 <=> NC = 1, rule_count(NC).
281 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
282 passive(R,ID) \ passive(R,ID) <=> true.
284 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
285 is_passive(_,_) <=> fail.
287 passive(RuleNb,_) \ any_passive_head(RuleNb)
288 <=> true.
289 any_passive_head(_)
290 <=> fail.
291 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
293 max_occurrence(C,N) \ max_occurrence(C,M)
294 <=> N >= M | true.
296 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID) <=>
297 NO is MO + 1,
298 occurrence(C,NO,RuleNb,ID),
299 max_occurrence(C,NO).
300 new_occurrence(C,RuleNb,ID) <=>
301 format('ERROR: new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]),
302 fail.
304 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
305 <=> Q = MON.
306 get_max_occurrence(C,Q)
307 <=> format('WARNING: get_max_occurrence: missing max occurrence for ~w\n',[C]), Q = 0.
309 occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
310 <=> Rule = QRule, ID = QID.
311 get_occurrence(C,O,_,_)
312 <=> format('get_occurrence: missing occurrence ~w:~w\n',[C,O]), fail.
314 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
316 % cannot store constraint at passive occurrence
317 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
318 <=> NO is O + 1, allocation_occurrence(C,NO).
319 % need not store constraint that is removed
320 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
321 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
322 | NO is O + 1, allocation_occurrence(C,NO).
323 % need not store constraint when body is true
324 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
325 <=> Rule = pragma(rule([_|_],_,_,true),_,_,_,_)
326 | NO is O + 1, allocation_occurrence(C,NO).
327 % need not store constraint if does not observe itself
328 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
329 <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
330 | NO is O + 1, allocation_occurrence(C,NO).
331 % need not store constraint if does not observe itself and cannot trigger
332 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_), least_occurrence(RuleNb,[])
333 \ allocation_occurrence(C,O)
334 <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
335 | NO is O + 1, allocation_occurrence(C,NO).
337 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID), allocation_occurrence(C,AO)
338 \ least_occurrence(RuleNb,[ID|IDs])
339 <=> AO >= O, \+ may_trigger(C) |
340 least_occurrence(RuleNb,IDs).
341 rule(RuleNb,Rule), passive(RuleNb,ID)
342 \ least_occurrence(RuleNb,[ID|IDs])
343 <=> least_occurrence(RuleNb,IDs).
345 rule(RuleNb,Rule)
346 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
347 least_occurrence(RuleNb,IDs).
349 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
350 <=> true.
351 is_least_occurrence(_)
352 <=> fail.
354 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
355 <=> Q = O.
356 get_allocation_occurrence(_,Q)
357 <=> chr_pp_flag(late_allocation,off), Q=0.
358 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
360 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
361 <=> Q = Rule.
362 get_rule(_,_)
363 <=> fail.
365 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
367 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
368 constraints
369 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
370 get_constraint_index/2,
371 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
372 get_max_constraint_index/1.
374 option(mode,constraint_index(+,+)).
375 option(mode,max_constraint_index(+)).
377 constraint_index(C,Index) \ get_constraint_index(C,Query)
378 <=> Query = Index.
379 get_constraint_index(C,Query)
380 <=> fail.
382 max_constraint_index(Index) \ get_max_constraint_index(Query)
383 <=> Query = Index.
384 get_max_constraint_index(Query)
385 <=> Query = 0.
387 set_constraint_indices(Constraints) :-
388 set_constraint_indices(Constraints,1).
389 set_constraint_indices([],M) :-
390 N is M - 1,
391 max_constraint_index(N).
392 set_constraint_indices([C|Cs],N) :-
393 ( ( chr_pp_flag(debugable, on) ; may_trigger(C) ; is_stored(C), get_store_type(C,default)) ->
394 constraint_index(C,N),
395 M is N + 1,
396 set_constraint_indices(Cs,M)
397 ;
398 set_constraint_indices(Cs,N)
399 ).
401 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
406 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
407 %%
408 %% Translation
410 chr_translate(Declarations,NewDeclarations) :-
411 init_chr_pp_flags,
412 partition_clauses(Declarations,Constraints,Rules,OtherClauses),
413 ( Constraints == [] ->
414 insert_declarations(OtherClauses, NewDeclarations)
415 ;
416 generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
417 add_constraints(Constraints),
418 add_rules(Rules),
419 % start analysis
420 check_rules(Rules,Constraints),
421 add_occurrences(Rules),
422 functional_dependency_analysis(Rules),
423 set_semantics_rules(Rules),
424 symmetry_analysis(Rules),
425 guard_simplification,
426 storage_analysis(Constraints),
427 observation_analysis(Constraints),
428 ai_observation_analysis(Constraints),
429 late_allocation(Constraints),
430 assume_constraint_stores(Constraints),
431 set_constraint_indices(Constraints),
432 % end analysis
433 constraints_code(Constraints,ConstraintClauses),
434 validate_store_type_assumptions(Constraints),
435 store_management_preds(Constraints,StoreClauses), % depends on actual code used
436 insert_declarations(OtherClauses, Clauses0),
437 chr_module_declaration(CHRModuleDeclaration),
438 append_lists([Clauses0,
439 StoreClauses,
440 ConstraintClauses,
441 CHRModuleDeclaration
442 ],
443 NewDeclarations)
444 ).
446 store_management_preds(Constraints,Clauses) :-
447 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
448 generate_indexed_variables_clauses(Constraints,IndexedClauses),
449 generate_attach_increment(AttachIncrementClauses),
450 generate_attr_unify_hook(AttrUnifyHookClauses),
451 generate_extra_clauses(Constraints,ExtraClauses),
452 generate_insert_delete_constraints(Constraints,DeleteClauses),
453 generate_attach_code(Constraints,StoreClauses),
454 generate_counter_code(CounterClauses),
455 append_lists([AttachAConstraintClauses
456 ,IndexedClauses
457 ,AttachIncrementClauses
458 ,AttrUnifyHookClauses
459 ,ExtraClauses
460 ,DeleteClauses
461 ,StoreClauses
462 ,CounterClauses
463 ]
464 ,Clauses).
466 insert_declarations(Clauses0, Clauses) :-
467 append(Clauses0,
468 [ :- use_module(chr(chr_runtime))
469 , :- use_module(chr(chr_hashtable_store))
470 , :- use_module(library('clp/clp_events'))
471 ],
472 Clauses).
474 generate_counter_code(Clauses) :-
475 ( chr_pp_flag(store_counter,on) ->
476 Clauses = [
477 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
478 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
479 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
480 (:- '$counter_init'('$insert_counter')),
481 (:- '$counter_init'('$delete_counter')),
482 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
483 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
484 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
485 ]
486 ;
487 Clauses = []
488 ).
491 chr_module_declaration(CHRModuleDeclaration) :-
492 get_target_module(Mod),
493 ( Mod \== chr_translate ->
494 CHRModuleDeclaration = [
495 (:- multifile chr:'$chr_module'/1),
496 chr:'$chr_module'(Mod)
497 ]
498 ;
499 CHRModuleDeclaration = []
500 ).
503 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
504 %%
505 %% Partitioning of clauses into constraint declarations, chr rules and other
506 %% clauses
508 partition_clauses([],[],[],[]).
509 partition_clauses([C|Cs],Ds,Rs,OCs) :-
510 ( parse_rule(C,R) ->
511 Ds = RDs,
512 Rs = [R | RRs],
513 OCs = ROCs
514 ; is_declaration(C,D) ->
515 append(D,RDs,Ds),
516 Rs = RRs,
517 OCs = ROCs
518 ; is_module_declaration(C,Mod) ->
519 target_module(Mod),
520 Ds = RDs,
521 Rs = RRs,
522 OCs = [C|ROCs]
523 ; is_type_definition(C) ->
524 Ds = RDs,
525 Rs = RRs,
526 OCs = ROCs
527 ; C = (handler _) ->
528 format('CHR compiler WARNING: ~w.\n',[C]),
529 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
530 Ds = RDs,
531 Rs = RRs,
532 OCs = ROCs
533 ; C = (rules _) ->
534 format('CHR compiler WARNING: ~w.\n',[C]),
535 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
536 Ds = RDs,
537 Rs = RRs,
538 OCs = ROCs
539 ; C = option(OptionName,OptionValue) ->
540 handle_option(OptionName,OptionValue),
541 Ds = RDs,
542 Rs = RRs,
543 OCs = ROCs
544 ; Ds = RDs,
545 Rs = RRs,
546 OCs = [C|ROCs]
547 ),
548 partition_clauses(Cs,RDs,RRs,ROCs).
550 is_declaration(D, Constraints) :- %% constraint declaration
551 ( D = (:- Decl) ->
552 true
553 ;
554 D = Decl
555 ),
556 Decl =.. [constraints,Cs],
557 conj2list(Cs,Constraints0),
558 extract_type_mode(Constraints0,Constraints).
560 extract_type_mode([],[]).
561 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
562 extract_type_mode([C|R],[C2|R2]) :-
563 functor(C,F,A),C2=F/A,
564 C =.. [_|Args],
565 extract_types_and_modes(Args,ArgTypes,ArgModes),
566 constraint_type(F/A,ArgTypes),
567 constraint_mode(F/A,ArgModes),
568 extract_type_mode(R,R2).
570 extract_types_and_modes([],[],[]).
571 extract_types_and_modes([+(T)|R],[T|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
572 extract_types_and_modes([?(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
573 extract_types_and_modes([-(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
574 extract_types_and_modes([Illegal|R],_,_) :-
575 format('CHR compiler ERROR: Illegal mode/type declaration "~w".\n',
576 [Illegal]),
577 format(' `--> correct syntax is +type, -type or ?type.\n',[]),
578 fail.
580 is_type_definition(D) :-
581 ( D = (:- TDef) ->
582 true
583 ;
584 D = TDef
585 ),
586 TDef =.. [chr_type,TypeDef],
587 ( TypeDef = (Name ---> Def) ->
588 tdisj2list(Def,DefList),
589 type_definition(Name,DefList)
590 ;
591 format('CHR compiler WARNING: Illegal type definition "~w".\n',[TypeDef]),
592 format(' `--> Ignoring this malformed type definition.\n',[])
593 ).
595 % no removal of fails, e.g. :- type bool ---> true ; fail.
596 tdisj2list(Conj,L) :-
597 tdisj2list(Conj,L,[]).
598 tdisj2list(Conj,L,T) :-
599 Conj = (G1;G2), !,
600 tdisj2list(G1,L,T1),
601 tdisj2list(G2,T1,T).
602 tdisj2list(G,[G | T],T).
605 %% Data Declaration
606 %%
607 %% pragma_rule
608 %% -> pragma(
609 %% rule,
610 %% ids,
611 %% list(pragma),
612 %% yesno(string), :: maybe rule nane
613 %% int :: rule number
614 %% )
615 %%
616 %% ids -> ids(
617 %% list(int),
618 %% list(int)
619 %% )
620 %%
621 %% rule -> rule(
622 %% list(constraint), :: constraints to be removed
623 %% list(constraint), :: surviving constraints
624 %% goal, :: guard
625 %% goal :: body
626 %% )
628 parse_rule(RI,R) :- %% name @ rule
629 RI = (Name @ RI2), !,
630 rule(RI2,yes(Name),R).
631 parse_rule(RI,R) :-
632 rule(RI,no,R).
634 rule(RI,Name,R) :-
635 RI = (RI2 pragma P), !, %% pragmas
636 is_rule(RI2,R1,IDs),
637 conj2list(P,Ps),
638 inc_rule_count(RuleCount),
639 R = pragma(R1,IDs,Ps,Name,RuleCount).
640 rule(RI,Name,R) :-
641 is_rule(RI,R1,IDs),
642 inc_rule_count(RuleCount),
643 R = pragma(R1,IDs,[],Name,RuleCount).
645 is_rule(RI,R,IDs) :- %% propagation rule
646 RI = (H ==> B), !,
647 conj2list(H,Head2i),
648 get_ids(Head2i,IDs2,Head2),
649 IDs = ids([],IDs2),
650 ( B = (G | RB) ->
651 R = rule([],Head2,G,RB)
652 ;
653 R = rule([],Head2,true,B)
654 ).
655 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
656 RI = (H <=> B), !,
657 ( B = (G | RB) ->
658 Guard = G,
659 Body = RB
660 ; Guard = true,
661 Body = B
662 ),
663 ( H = (H1 \ H2) ->
664 conj2list(H1,Head2i),
665 conj2list(H2,Head1i),
666 get_ids(Head2i,IDs2,Head2,0,N),
667 get_ids(Head1i,IDs1,Head1,N,_),
668 IDs = ids(IDs1,IDs2)
669 ; conj2list(H,Head1i),
670 Head2 = [],
671 get_ids(Head1i,IDs1,Head1),
672 IDs = ids(IDs1,[])
673 ),
674 R = rule(Head1,Head2,Guard,Body).
676 get_ids(Cs,IDs,NCs) :-
677 get_ids(Cs,IDs,NCs,0,_).
679 get_ids([],[],[],N,N).
680 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
681 ( C = (NC # N) ->
682 true
683 ;
684 NC = C
685 ),
686 M is N + 1,
687 get_ids(Cs,IDs,NCs, M,NN).
689 is_module_declaration((:- module(Mod)),Mod).
690 is_module_declaration((:- module(Mod,_)),Mod).
692 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
694 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
695 % Add constraints
696 add_constraints([]).
697 add_constraints([C|Cs]) :-
698 max_occurrence(C,0),
699 C = _/A,
700 length(Mode,A),
701 set_elems(Mode,?),
702 constraint_mode(C,Mode),
703 add_constraints(Cs).
705 % Add rules
706 add_rules([]).
707 add_rules([Rule|Rules]) :-
708 Rule = pragma(_,_,_,_,RuleNb),
709 rule(RuleNb,Rule),
710 add_rules(Rules).
712 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
714 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
715 %% Some input verification:
716 %% - all constraints in heads are declared constraints
717 %% - all passive pragmas refer to actual head constraints
719 check_rules([],_).
720 check_rules([PragmaRule|Rest],Decls) :-
721 check_rule(PragmaRule,Decls),
722 check_rules(Rest,Decls).
724 check_rule(PragmaRule,Decls) :-
725 check_rule_indexing(PragmaRule),
726 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
727 Rule = rule(H1,H2,_,_),
728 append(H1,H2,HeadConstraints),
729 check_head_constraints(HeadConstraints,Decls,PragmaRule),
730 check_pragmas(Pragmas,PragmaRule).
732 check_head_constraints([],_,_).
733 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
734 functor(Constr,F,A),
735 ( member(F/A,Decls) ->
736 check_head_constraints(Rest,Decls,PragmaRule)
737 ;
738 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
739 [F/A,format_rule(PragmaRule)]),
740 format(' `--> Constraint should be one of ~w.\n',[Decls]),
741 fail
742 ).
744 check_pragmas([],_).
745 check_pragmas([Pragma|Pragmas],PragmaRule) :-
746 check_pragma(Pragma,PragmaRule),
747 check_pragmas(Pragmas,PragmaRule).
749 check_pragma(Pragma,PragmaRule) :-
750 var(Pragma), !,
751 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
752 [Pragma,format_rule(PragmaRule)]),
753 format(' `--> Pragma should not be a variable!\n',[]),
754 fail.
755 check_pragma(passive(ID), PragmaRule) :-
756 !,
757 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
758 ( memberchk_eq(ID,IDs1) ->
759 true
760 ; memberchk_eq(ID,IDs2) ->
761 true
762 ;
763 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
764 [ID,format_rule(PragmaRule)]),
765 fail
766 ),
767 passive(RuleNb,ID).
769 check_pragma(Pragma, PragmaRule) :-
770 Pragma = already_in_heads,
771 !,
772 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
773 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
775 check_pragma(Pragma, PragmaRule) :-
776 Pragma = already_in_head(_),
777 !,
778 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
779 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
781 check_pragma(Pragma,PragmaRule) :-
782 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
783 format(' `--> Pragma should be one of passive/1!\n',[]),
784 fail.
786 format_rule(PragmaRule) :-
787 PragmaRule = pragma(_,_,_,MaybeName,N),
788 ( MaybeName = yes(Name) ->
789 write('rule '), write(Name)
790 ;
791 write('rule number '), write(N)
792 ).
794 check_rule_indexing(PragmaRule) :-
795 PragmaRule = pragma(Rule,_,_,_,_),
796 Rule = rule(H1,H2,G,_),
797 term_variables(H1-H2,HeadVars),
798 remove_anti_monotonic_guards(G,HeadVars,NG),
799 check_indexing(H1,NG-H2),
800 check_indexing(H2,NG-H1).
802 remove_anti_monotonic_guards(G,Vars,NG) :-
803 conj2list(G,GL),
804 remove_anti_monotonic_guard_list(GL,Vars,NGL),
805 list2conj(NGL,NG).
807 remove_anti_monotonic_guard_list([],_,[]).
808 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
809 ( G = var(X),
810 memberchk_eq(X,Vars) ->
811 NGs = RGs
812 ;
813 NGs = [G|RGs]
814 ),
815 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
817 check_indexing([],_).
818 check_indexing([Head|Heads],Other) :-
819 functor(Head,F,A),
820 Head =.. [_|Args],
821 term_variables(Heads-Other,OtherVars),
822 check_indexing(Args,1,F/A,OtherVars),
823 check_indexing(Heads,[Head|Other]).
825 check_indexing([],_,_,_).
826 check_indexing([Arg|Args],I,FA,OtherVars) :-
827 ( is_indexed_argument(FA,I) ->
828 true
829 ; nonvar(Arg) ->
830 indexed_argument(FA,I)
831 ; % var(Arg) ->
832 term_variables(Args,ArgsVars),
833 append(ArgsVars,OtherVars,RestVars),
834 ( memberchk_eq(Arg,RestVars) ->
835 indexed_argument(FA,I)
836 ;
837 true
838 )
839 ),
840 J is I + 1,
841 term_variables(Arg,NVars),
842 append(NVars,OtherVars,NOtherVars),
843 check_indexing(Args,J,FA,NOtherVars).
845 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
847 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
848 % Occurrences
850 add_occurrences([]).
851 add_occurrences([Rule|Rules]) :-
852 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
853 add_occurrences(H1,IDs1,Nb),
854 add_occurrences(H2,IDs2,Nb),
855 add_occurrences(Rules).
857 add_occurrences([],[],_).
858 add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
859 functor(H,F,A),
860 FA = F/A,
861 new_occurrence(FA,RuleNb,ID),
862 add_occurrences(Hs,IDs,RuleNb).
864 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
866 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
867 % Observation Analysis
868 %
869 % CLASSIFICATION
870 % Legacy
871 %
872 % - approximative: should make decision in late allocation analysis per body
873 % TODO:
874 % remove
876 is_observed(C,O) :-
877 is_self_observer(C),
878 ai_is_observed(C,O).
880 constraints
881 observes/2,
882 spawns_observer/2,
883 observes_indirectly/2,
884 is_self_observer/1
885 .
887 option(mode,observes(+,+)).
888 option(mode,spawns_observer(+,+)).
889 option(mode,observes_indirectly(+,+)).
891 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
892 observes(C1,C2) \ observes(C1,C2) <=> true.
894 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
896 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
897 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
899 observes_indirectly(C,C) \ is_self_observer(C) <=> true.
900 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off).
901 % fails if analysis has not been run
903 observation_analysis(Cs) :-
904 ( chr_pp_flag(observation,on) ->
905 observation_analysis(Cs,Cs)
906 ;
907 true
908 ).
910 observation_analysis([],_).
911 observation_analysis([C|Cs],Constraints) :-
912 get_max_occurrence(C,MO),
913 observation_analysis_occurrences(C,1,MO,Constraints),
914 observation_analysis(Cs,Constraints).
916 observation_analysis_occurrences(C,O,MO,Cs) :-
917 ( O > MO ->
918 true
919 ;
920 observation_analysis_occurrence(C,O,Cs),
921 NO is O + 1,
922 observation_analysis_occurrences(C,NO,MO,Cs)
923 ).
925 observation_analysis_occurrence(C,O,Cs) :-
926 get_occurrence(C,O,RuleNb,ID),
927 ( is_passive(RuleNb,ID) ->
928 true
929 ;
930 get_rule(RuleNb,PragmaRule),
931 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),
932 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
933 append(RHeads1,Heads2,OtherHeads)
934 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
935 append(RHeads2,Heads1,OtherHeads)
936 ),
937 observe_heads(C,OtherHeads),
938 observe_body(C,Body,Cs)
939 ).
941 observe_heads(C,Heads) :-
942 findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
943 observe_all(C,Cs).
945 observe_all(C,Cs) :-
946 ( Cs = [C1|Cr] ->
947 observes(C,C1),
948 observe_all(C,Cr)
949 ;
950 true
951 ).
953 spawn_all(C,Cs) :-
954 ( Cs = [C1|Cr] ->
955 spawns_observer(C,C1),
956 spawn_all(C,Cr)
957 ;
958 true
959 ).
960 spawn_all_triggers(C,Cs) :-
961 ( Cs = [C1|Cr] ->
962 ( may_trigger(C1) ->
963 spawns_observer(C,C1)
964 ;
965 true
966 ),
967 spawn_all_triggers(C,Cr)
968 ;
969 true
970 ).
972 observe_body(C,Body,Cs) :-
973 ( var(Body) ->
974 spawn_all(C,Cs)
975 ; Body = true ->
976 true
977 ; Body = fail ->
978 true
979 ; Body = (B1,B2) ->
980 observe_body(C,B1,Cs),
981 observe_body(C,B2,Cs)
982 ; Body = (B1;B2) ->
983 observe_body(C,B1,Cs),
984 observe_body(C,B2,Cs)
985 ; Body = (B1->B2) ->
986 observe_body(C,B1,Cs),
987 observe_body(C,B2,Cs)
988 ; functor(Body,F,A), member(F/A,Cs) ->
989 spawns_observer(C,F/A)
990 ; Body = (_ = _) ->
991 spawn_all_triggers(C,Cs)
992 ; Body = (_ is _) ->
993 spawn_all_triggers(C,Cs)
994 ; binds_b(Body,Vars) ->
995 ( Vars == [] ->
996 true
997 ;
998 spawn_all_triggers(C,Cs)
999 )
1000 ;
1001 spawn_all(C,Cs)
1002 ).
1004 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1006 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1007 % Late allocation
1009 late_allocation_analysis(Cs) :-
1010 ( chr_pp_flag(late_allocation,on) ->
1011 late_allocation(Cs)
1012 ;
1013 true
1014 ).
1016 late_allocation([]).
1017 late_allocation([C|Cs]) :-
1018 allocation_occurrence(C,1),
1019 late_allocation(Cs).
1020 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1023 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1024 %%
1025 %% Generated predicates
1026 %% attach_$CONSTRAINT
1027 %% attach_increment
1028 %% detach_$CONSTRAINT
1029 %% attr_unify_hook
1031 %% attach_$CONSTRAINT
1032 generate_attach_detach_a_constraint_all([],[]).
1033 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1034 ( ( chr_pp_flag(debugable,on) ; may_trigger(Constraint)) ->
1035 generate_attach_a_constraint(Constraint,Clauses1),
1036 generate_detach_a_constraint(Constraint,Clauses2)
1037 ;
1038 Clauses1 = [],
1039 Clauses2 = []
1040 ),
1041 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1042 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
1044 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1045 generate_attach_a_constraint_empty_list(Constraint,Clause1),
1046 get_max_constraint_index(N),
1047 ( N == 1 ->
1048 generate_attach_a_constraint_1_1(Constraint,Clause2)
1049 ;
1050 generate_attach_a_constraint_t_p(Constraint,Clause2)
1051 ).
1053 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
1054 make_name('attach_',FA,Fct),
1055 Head =.. [Fct | Args],
1056 Clause = ( Head :- Body).
1058 generate_attach_a_constraint_empty_list(FA,Clause) :-
1059 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
1061 generate_attach_a_constraint_1_1(FA,Clause) :-
1062 Args = [[Var|Vars],Susp],
1063 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1064 generate_attach_body_1(FA,Var,Susp,AttachBody),
1065 make_name('attach_',FA,Fct),
1066 RecursiveCall =.. [Fct,Vars,Susp],
1067 chr_pp_flag(solver_events,NMod),
1068 ( NMod \== none ->
1069 Args = [[Var|_],Susp],
1070 get_target_module(Mod),
1071 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1072 ;
1073 Subscribe = true
1074 ),
1075 Body =
1076 (
1077 AttachBody,
1078 Subscribe,
1079 RecursiveCall
1080 ).
1082 generate_attach_body_1(FA,Var,Susp,Body) :-
1083 get_target_module(Mod),
1084 Body =
1085 ( get_attr(Var, Mod, Susps) ->
1086 NewSusps=[Susp|Susps],
1087 put_attr(Var, Mod, NewSusps)
1088 ;
1089 put_attr(Var, Mod, [Susp])
1090 ).
1092 generate_attach_a_constraint_t_p(FA,Clause) :-
1093 Args = [[Var|Vars],Susp],
1094 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1095 make_name('attach_',FA,Fct),
1096 RecursiveCall =.. [Fct,Vars,Susp],
1097 generate_attach_body_n(FA,Var,Susp,AttachBody),
1098 chr_pp_flag(solver_events,NMod),
1099 ( NMod \== none ->
1100 Args = [[Var|_],Susp],
1101 get_target_module(Mod),
1102 Subscribe = clp_events:subscribe(Var,NMod,Mod,chr_runtime:'chr run_suspensions'([Susp]))
1103 ;
1104 Subscribe = true
1105 ),
1106 Body =
1107 (
1108 AttachBody,
1109 Subscribe,
1110 RecursiveCall
1111 ).
1113 generate_attach_body_n(F/A,Var,Susp,Body) :-
1114 get_constraint_index(F/A,Position),
1115 or_pattern(Position,Pattern),
1116 get_max_constraint_index(Total),
1117 make_attr(Total,Mask,SuspsList,Attr),
1118 nth(Position,SuspsList,Susps),
1119 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1120 make_attr(Total,Mask,SuspsList1,NewAttr1),
1121 substitute(Susps,SuspsList,[Susp],SuspsList2),
1122 make_attr(Total,NewMask,SuspsList2,NewAttr2),
1123 copy_term(SuspsList,SuspsList3),
1124 nth(Position,SuspsList3,[Susp]),
1125 chr_delete(SuspsList3,[Susp],RestSuspsList),
1126 set_elems(RestSuspsList,[]),
1127 make_attr(Total,Pattern,SuspsList3,NewAttr3),
1128 get_target_module(Mod),
1129 Body =
1130 ( get_attr(Var,Mod,TAttr) ->
1131 TAttr = Attr,
1132 ( Mask /\ Pattern =:= Pattern ->
1133 put_attr(Var, Mod, NewAttr1)
1134 ;
1135 NewMask is Mask \/ Pattern,
1136 put_attr(Var, Mod, NewAttr2)
1137 )
1138 ;
1139 put_attr(Var,Mod,NewAttr3)
1140 ).
1142 %% detach_$CONSTRAINT
1143 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1144 generate_detach_a_constraint_empty_list(Constraint,Clause1),
1145 get_max_constraint_index(N),
1146 ( N == 1 ->
1147 generate_detach_a_constraint_1_1(Constraint,Clause2)
1148 ;
1149 generate_detach_a_constraint_t_p(Constraint,Clause2)
1150 ).
1152 generate_detach_a_constraint_empty_list(FA,Clause) :-
1153 make_name('detach_',FA,Fct),
1154 Args = [[],_],
1155 Head =.. [Fct | Args],
1156 Clause = ( Head :- true).
1158 generate_detach_a_constraint_1_1(FA,Clause) :-
1159 make_name('detach_',FA,Fct),
1160 Args = [[Var|Vars],Susp],
1161 Head =.. [Fct | Args],
1162 RecursiveCall =.. [Fct,Vars,Susp],
1163 generate_detach_body_1(FA,Var,Susp,DetachBody),
1164 Body =
1165 (
1166 DetachBody,
1167 RecursiveCall
1168 ),
1169 Clause = (Head :- Body).
1171 generate_detach_body_1(FA,Var,Susp,Body) :-
1172 get_target_module(Mod),
1173 Body =
1174 ( get_attr(Var,Mod,Susps) ->
1175 'chr sbag_del_element'(Susps,Susp,NewSusps),
1176 ( NewSusps == [] ->
1177 del_attr(Var,Mod)
1178 ;
1179 put_attr(Var,Mod,NewSusps)
1180 )
1181 ;
1182 true
1183 ).
1185 generate_detach_a_constraint_t_p(FA,Clause) :-
1186 make_name('detach_',FA,Fct),
1187 Args = [[Var|Vars],Susp],
1188 Head =.. [Fct | Args],
1189 RecursiveCall =.. [Fct,Vars,Susp],
1190 generate_detach_body_n(FA,Var,Susp,DetachBody),
1191 Body =
1192 (
1193 DetachBody,
1194 RecursiveCall
1195 ),
1196 Clause = (Head :- Body).
1198 generate_detach_body_n(F/A,Var,Susp,Body) :-
1199 get_constraint_index(F/A,Position),
1200 or_pattern(Position,Pattern),
1201 and_pattern(Position,DelPattern),
1202 get_max_constraint_index(Total),
1203 make_attr(Total,Mask,SuspsList,Attr),
1204 nth(Position,SuspsList,Susps),
1205 substitute(Susps,SuspsList,[],SuspsList1),
1206 make_attr(Total,NewMask,SuspsList1,Attr1),
1207 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1208 make_attr(Total,Mask,SuspsList2,Attr2),
1209 get_target_module(Mod),
1210 Body =
1211 ( get_attr(Var,Mod,TAttr) ->
1212 TAttr = Attr,
1213 ( Mask /\ Pattern =:= Pattern ->
1214 'chr sbag_del_element'(Susps,Susp,NewSusps),
1215 ( NewSusps == [] ->
1216 NewMask is Mask /\ DelPattern,
1217 ( NewMask == 0 ->
1218 del_attr(Var,Mod)
1219 ;
1220 put_attr(Var,Mod,Attr1)
1221 )
1222 ;
1223 put_attr(Var,Mod,Attr2)
1224 )
1225 ;
1226 true
1227 )
1228 ;
1229 true
1230 ).
1232 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1233 generate_indexed_variables_clauses(Constraints,Clauses) :-
1234 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1235 generate_indexed_variables_clauses_(Constraints,Clauses)
1236 ;
1237 Clauses = []
1238 ).
1240 generate_indexed_variables_clauses_([],[]).
1241 generate_indexed_variables_clauses_([C|Cs],Clauses) :-
1242 ( is_stored(C) ->
1243 Clauses = [Clause|RestClauses],
1244 generate_indexed_variables_clause(C,Clause)
1245 ;
1246 Clauses = RestClauses
1247 ),
1248 generate_indexed_variables_clauses_(Cs,RestClauses).
1250 %===============================================================================
1251 constraints generate_indexed_variables_clause/2.
1252 option(mode,generate_indexed_variables_clause(+,+)).
1253 %-------------------------------------------------------------------------------
1254 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_clause(F/A,Clause) <=>
1255 functor(Term,F,A),
1256 Term =.. [_|Args],
1257 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1258 ( MaybeBody == empty ->
1260 Body = (Vars = [])
1261 ; N == 0 ->
1262 Body = term_variables(Susp,Vars)
1263 ;
1264 MaybeBody = Body
1265 ),
1266 Clause =
1267 ( '$indexed_variables'(Susp,Vars) :-
1268 Susp = Term,
1269 Body
1270 ).
1271 generate_indexed_variables_clause(FA,_) <=>
1272 format('ERROR: generate_indexed_variables_clause: missing mode info for ~w\n',[FA]),
1273 fail.
1274 %===============================================================================
1276 create_indexed_variables_body([],[],_,_,_,empty,0).
1277 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1278 J is I + 1,
1279 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1280 ( Mode \== (+),
1281 is_indexed_argument(FA,I) ->
1282 ( RBody == empty ->
1283 Body = term_variables(V,Vars)
1284 ;
1285 Body = (term_variables(V,Vars,Tail),RBody)
1286 ),
1287 N = M
1288 ;
1289 Vars = Tail,
1290 Body = RBody,
1291 N is M + 1
1292 ).
1294 generate_extra_clauses(Constraints,List) :-
1295 generate_activate_clause(List,Tail0),
1296 generate_remove_clause(Tail0,Tail1),
1297 generate_allocate_clause(Tail1,Tail2),
1298 generate_insert_constraint_internal(Tail2,Tail3),
1299 global_indexed_variables_clause(Constraints,Tail3,[]).
1301 generate_remove_clause(List,Tail) :-
1302 ( is_used_auxiliary_predicate(remove_constraint_internal) ->
1303 List = [RemoveClause|Tail],
1304 use_auxiliary_predicate(chr_indexed_variables),
1305 RemoveClause =
1306 (
1307 remove_constraint_internal(Susp, Agenda, Delete) :-
1308 arg( 2, Susp, Mref),
1309 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1310 'chr update_mutable'( removed, Mref), % mark in any case
1311 ( compound(State) -> % passive/1
1312 Agenda = [],
1313 Delete = no
1314 ; State==removed ->
1315 Agenda = [],
1316 Delete = no
1317 %; State==triggered ->
1318 % Agenda = []
1319 ;
1320 Delete = yes,
1321 chr_indexed_variables(Susp,Agenda)
1322 )
1323 )
1324 ;
1325 List = Tail
1326 ).
1328 generate_activate_clause(List,Tail) :-
1329 ( is_used_auxiliary_predicate(activate_constraint) ->
1330 List = [ActivateClause|Tail],
1331 use_auxiliary_predicate(chr_indexed_variables),
1332 ActivateClause =
1333 (
1334 activate_constraint(Store, Vars, Susp, Generation) :-
1335 arg( 2, Susp, Mref),
1336 Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
1337 'chr update_mutable'( active, Mref),
1338 ( nonvar(Generation) -> % aih
1339 true
1340 ;
1341 arg( 4, Susp, Gref),
1342 Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
1343 Generation is Gen+1,
1344 'chr update_mutable'( Generation, Gref)
1345 ),
1346 ( compound(State) -> % passive/1
1347 term_variables( State, Vars),
1348 'chr none_locked'( Vars),
1349 Store = yes
1350 ; State == removed -> % the price for eager removal ...
1351 chr_indexed_variables(Susp,Vars),
1352 Store = yes
1353 ;
1354 Vars = [],
1355 Store = no
1356 )
1357 )
1358 ;
1359 List = Tail
1360 ).
1362 generate_allocate_clause(List,Tail) :-
1363 ( is_used_auxiliary_predicate(allocate_constraint) ->
1364 List = [AllocateClause|Tail],
1365 use_auxiliary_predicate(chr_indexed_variables),
1366 AllocateClause =
1367 (
1368 allocate_constraint( Closure, Self, F, Args) :-
1369 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1370 Gref = mutable(0),
1371 'chr empty_history'(History),
1372 Href = mutable(History),
1373 chr_indexed_variables(Self,Vars),
1374 Mref = mutable(passive(Vars)),
1375 'chr gen_id'( Id)
1376 )
1377 ;
1378 List = Tail
1379 ).
1381 generate_insert_constraint_internal(List,Tail) :-
1382 ( is_used_auxiliary_predicate(insert_constraint_internal) ->
1383 List = [Clause|Tail],
1384 use_auxiliary_predicate(chr_indexed_variables),
1385 Clause =
1386 (
1387 insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
1388 Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1389 chr_indexed_variables(Self,Vars),
1390 'chr none_locked'(Vars),
1391 Mref = mutable(active),
1392 Gref = mutable(0),
1393 Href = mutable(History),
1394 'chr empty_history'(History),
1395 'chr gen_id'(Id)
1396 )
1397 ;
1398 List = Tail
1399 ).
1401 global_indexed_variables_clause(Constraints,List,Tail) :-
1402 ( is_used_auxiliary_predicate(chr_indexed_variables) ->
1403 List = [Clause|Tail],
1404 ( chr_pp_flag(reduced_indexing,on) ->
1405 ( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
1406 Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
1407 ;
1408 Body = true,
1409 Vars = []
1410 ),
1411 Clause = ( chr_indexed_variables(Susp,Vars) :- Body )
1412 ;
1413 Clause =
1414 ( chr_indexed_variables(Susp,Vars) :-
1415 'chr chr_indexed_variables'(Susp,Vars)
1416 )
1417 )
1418 ;
1419 List = Tail
1420 ).
1422 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1423 generate_attach_increment(Clauses) :-
1424 get_max_constraint_index(N),
1425 ( N > 0 ->
1426 Clauses = [Clause1,Clause2],
1427 generate_attach_increment_empty(Clause1),
1428 ( N == 1 ->
1429 generate_attach_increment_one(Clause2)
1430 ;
1431 generate_attach_increment_many(N,Clause2)
1432 )
1433 ;
1434 Clauses = []
1435 ).
1437 generate_attach_increment_empty((attach_increment([],_) :- true)).
1439 generate_attach_increment_one(Clause) :-
1440 Head = attach_increment([Var|Vars],Susps),
1441 get_target_module(Mod),
1442 Body =
1443 (
1444 'chr not_locked'(Var),
1445 ( get_attr(Var,Mod,VarSusps) ->
1446 sort(VarSusps,SortedVarSusps),
1447 merge(Susps,SortedVarSusps,MergedSusps),
1448 put_attr(Var,Mod,MergedSusps)
1449 ;
1450 put_attr(Var,Mod,Susps)
1451 ),
1452 attach_increment(Vars,Susps)
1453 ),
1454 Clause = (Head :- Body).
1456 generate_attach_increment_many(N,Clause) :-
1457 make_attr(N,Mask,SuspsList,Attr),
1458 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1459 Head = attach_increment([Var|Vars],Attr),
1460 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
1461 list2conj(Gs,SortGoals),
1462 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
1463 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
1464 get_target_module(Mod),
1465 Body =
1466 (
1467 'chr not_locked'(Var),
1468 ( get_attr(Var,Mod,TOtherAttr) ->
1469 TOtherAttr = OtherAttr,
1470 SortGoals,
1471 MergedMask is Mask \/ OtherMask,
1472 put_attr(Var,Mod,NewAttr)
1473 ;
1474 put_attr(Var,Mod,Attr)
1475 ),
1476 attach_increment(Vars,Attr)
1477 ),
1478 Clause = (Head :- Body).
1480 %% attr_unify_hook
1481 generate_attr_unify_hook(Clauses) :-
1482 get_max_constraint_index(N),
1483 ( N == 0 ->
1484 Clauses = []
1485 ;
1486 Clauses = [Clause],
1487 ( N == 1 ->
1488 generate_attr_unify_hook_one(Clause)
1489 ;
1490 generate_attr_unify_hook_many(N,Clause)
1491 )
1492 ).
1494 generate_attr_unify_hook_one(Clause) :-
1495 Head = attr_unify_hook(Susps,Other),
1496 get_target_module(Mod),
1497 make_run_suspensions(NewSusps,WakeNewSusps),
1498 make_run_suspensions(Susps,WakeSusps),
1499 Body =
1500 (
1501 sort(Susps, SortedSusps),
1502 ( var(Other) ->
1503 ( get_attr(Other,Mod,OtherSusps) ->
1504 true
1505 ;
1506 OtherSusps = []
1507 ),
1508 sort(OtherSusps,SortedOtherSusps),
1509 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
1510 put_attr(Other,Mod,NewSusps),
1511 WakeNewSusps
1512 ;
1513 ( compound(Other) ->
1514 term_variables(Other,OtherVars),
1515 attach_increment(OtherVars, SortedSusps)
1516 ;
1517 true
1518 ),
1519 WakeSusps
1520 )
1521 ),
1522 Clause = (Head :- Body).
1524 generate_attr_unify_hook_many(N,Clause) :-
1525 make_attr(N,Mask,SuspsList,Attr),
1526 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
1527 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
1528 list2conj(SortGoalList,SortGoals),
1529 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
1530 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
1531 C = (sort(E,F),
1532 'chr merge_attributes'(D,F,G)) ),
1533 SortMergeGoalList),
1534 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
1535 list2conj(SortMergeGoalList,SortMergeGoals),
1536 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
1537 make_attr(N,Mask,SortedSuspsList,SortedAttr),
1538 Head = attr_unify_hook(Attr,Other),
1539 get_target_module(Mod),
1540 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
1541 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
1542 Body =
1543 (
1544 SortGoals,
1545 ( var(Other) ->
1546 ( get_attr(Other,Mod,TOtherAttr) ->
1547 TOtherAttr = OtherAttr,
1548 SortMergeGoals,
1549 MergedMask is Mask \/ OtherMask,
1550 put_attr(Other,Mod,MergedAttr),
1551 WakeMergedSusps
1552 ;
1553 put_attr(Other,Mod,SortedAttr),
1554 WakeSortedSusps
1555 )
1556 ;
1557 ( compound(Other) ->
1558 term_variables(Other,OtherVars),
1559 attach_increment(OtherVars,SortedAttr)
1560 ;
1561 true
1562 ),
1563 WakeSortedSusps
1564 )
1565 ),
1566 Clause = (Head :- Body).
1568 make_run_suspensions(Susps,Goal) :-
1569 ( chr_pp_flag(debugable,on) ->
1570 Goal = 'chr run_suspensions_d'(Susps)
1571 ;
1572 Goal = 'chr run_suspensions'(Susps)
1573 ).
1575 make_run_suspensions_loop(SuspsList,Goal) :-
1576 ( chr_pp_flag(debugable,on) ->
1577 Goal = 'chr run_suspensions_loop_d'(SuspsList)
1578 ;
1579 Goal = 'chr run_suspensions_loop'(SuspsList)
1580 ).
1582 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1583 % $insert_in_store_F/A
1584 % $delete_from_store_F/A
1586 generate_insert_delete_constraints([],[]).
1587 generate_insert_delete_constraints([FA|Rest],Clauses) :-
1588 ( is_stored(FA) ->
1589 Clauses = [IClause,DClause|RestClauses],
1590 generate_insert_delete_constraint(FA,IClause,DClause)
1591 ;
1592 Clauses = RestClauses
1593 ),
1594 generate_insert_delete_constraints(Rest,RestClauses).
1596 generate_insert_delete_constraint(FA,IClause,DClause) :-
1597 get_store_type(FA,StoreType),
1598 generate_insert_constraint(StoreType,FA,IClause),
1599 generate_delete_constraint(StoreType,FA,DClause).
1601 generate_insert_constraint(StoreType,C,Clause) :-
1602 make_name('$insert_in_store_',C,ClauseName),
1603 Head =.. [ClauseName,Susp],
1604 generate_insert_constraint_body(StoreType,C,Susp,Body),
1605 ( chr_pp_flag(store_counter,on) ->
1606 InsertCounterInc = '$insert_counter_inc'
1607 ;
1608 InsertCounterInc = true
1609 ),
1610 Clause = (Head :- InsertCounterInc,Body).
1612 generate_insert_constraint_body(default,C,Susp,Body) :-
1613 get_target_module(Mod),
1614 get_max_constraint_index(Total),
1615 ( Total == 1 ->
1616 generate_attach_body_1(C,Store,Susp,AttachBody)
1617 ;
1618 generate_attach_body_n(C,Store,Susp,AttachBody)
1619 ),
1620 Body =
1621 (
1622 'chr global_term_ref_1'(Store),
1623 AttachBody
1624 ).
1625 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1626 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
1627 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
1628 global_ground_store_name(C,StoreName),
1629 Body =
1630 (
1631 nb_getval(StoreName,Store),
1632 b_setval(StoreName,[Susp|Store])
1633 ).
1634 generate_insert_constraint_body(global_singleton,C,Susp,Body) :-
1635 global_singleton_store_name(C,StoreName),
1636 Body =
1637 (
1638 b_setval(StoreName,Susp)
1639 ).
1640 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1641 find_with_var_identity(
1642 B,
1643 [Susp],
1644 (
1645 member(ST,StoreTypes),
1646 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
1647 ),
1648 Bodies
1649 ),
1650 list2conj(Bodies,Body).
1652 generate_multi_hash_insert_constraint_bodies([],_,_,true).
1653 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1654 multi_hash_store_name(FA,Index,StoreName),
1655 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1656 Body =
1657 (
1658 KeyBody,
1659 nb_getval(StoreName,Store),
1660 insert_ht(Store,Key,Susp)
1661 ),
1662 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
1664 generate_delete_constraint(StoreType,FA,Clause) :-
1665 make_name('$delete_from_store_',FA,ClauseName),
1666 Head =.. [ClauseName,Susp],
1667 generate_delete_constraint_body(StoreType,FA,Susp,Body),
1668 ( chr_pp_flag(store_counter,on) ->
1669 DeleteCounterInc = '$delete_counter_inc'
1670 ;
1671 DeleteCounterInc = true
1672 ),
1673 Clause = (Head :- DeleteCounterInc, Body).
1675 generate_delete_constraint_body(default,C,Susp,Body) :-
1676 get_target_module(Mod),
1677 get_max_constraint_index(Total),
1678 ( Total == 1 ->
1679 generate_detach_body_1(C,Store,Susp,DetachBody),
1680 Body =
1681 (
1682 'chr global_term_ref_1'(Store),
1683 DetachBody
1684 )
1685 ;
1686 generate_detach_body_n(C,Store,Susp,DetachBody),
1687 Body =
1688 (
1689 'chr global_term_ref_1'(Store),
1690 DetachBody
1691 )
1692 ).
1693 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
1694 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
1695 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
1696 global_ground_store_name(C,StoreName),
1697 Body =
1698 (
1699 nb_getval(StoreName,Store),
1700 'chr sbag_del_element'(Store,Susp,NStore),
1701 b_setval(StoreName,NStore)
1702 ).
1703 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
1704 global_singleton_store_name(C,StoreName),
1705 Body =
1706 (
1707 b_setval(StoreName,[])
1708 ).
1709 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
1710 find_with_var_identity(
1711 B,
1712 [Susp],
1713 (
1714 member(ST,StoreTypes),
1715 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
1716 ),
1717 Bodies
1718 ),
1719 list2conj(Bodies,Body).
1721 generate_multi_hash_delete_constraint_bodies([],_,_,true).
1722 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
1723 multi_hash_store_name(FA,Index,StoreName),
1724 multi_hash_key(FA,Index,Susp,KeyBody,Key),
1725 Body =
1726 (
1727 KeyBody,
1728 nb_getval(StoreName,Store),
1729 delete_ht(Store,Key,Susp)
1730 ),
1731 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
1733 generate_delete_constraint_call(FA,Susp,Call) :-
1734 make_name('$delete_from_store_',FA,Functor),
1735 Call =.. [Functor,Susp].
1737 generate_insert_constraint_call(FA,Susp,Call) :-
1738 make_name('$insert_in_store_',FA,Functor),
1739 Call =.. [Functor,Susp].
1741 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1743 generate_attach_code(Constraints,[Enumerate|L]) :-
1744 enumerate_stores_code(Constraints,Enumerate),
1745 generate_attach_code(Constraints,L,[]).
1747 generate_attach_code([],L,L).
1748 generate_attach_code([C|Cs],L,T) :-
1749 get_store_type(C,StoreType),
1750 generate_attach_code(StoreType,C,L,L1),
1751 generate_attach_code(Cs,L1,T).
1753 generate_attach_code(default,_,L,L).
1754 generate_attach_code(multi_hash(Indexes),C,L,T) :-
1755 multi_hash_store_initialisations(Indexes,C,L,L1),
1756 multi_hash_via_lookups(Indexes,C,L1,T).
1757 generate_attach_code(global_ground,C,L,T) :-
1758 global_ground_store_initialisation(C,L,T).
1759 generate_attach_code(global_singleton,C,L,T) :-
1760 global_singleton_store_initialisation(C,L,T).
1761 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
1762 multi_store_generate_attach_code(StoreTypes,C,L,T).
1764 multi_store_generate_attach_code([],_,L,L).
1765 multi_store_generate_attach_code([ST|STs],C,L,T) :-
1766 generate_attach_code(ST,C,L,L1),
1767 multi_store_generate_attach_code(STs,C,L1,T).
1769 multi_hash_store_initialisations([],_,L,L).
1770 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
1771 multi_hash_store_name(FA,Index,StoreName),
1772 L = [(:- (new_ht(HT),nb_setval(StoreName,HT)) )|L1],
1773 multi_hash_store_initialisations(Indexes,FA,L1,T).
1775 global_ground_store_initialisation(C,L,T) :-
1776 global_ground_store_name(C,StoreName),
1777 L = [(:- nb_setval(StoreName,[]))|T].
1778 global_singleton_store_initialisation(C,L,T) :-
1779 global_singleton_store_name(C,StoreName),
1780 L = [(:- nb_setval(StoreName,[]))|T].
1782 multi_hash_via_lookups([],_,L,L).
1783 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
1784 multi_hash_via_lookup_name(C,Index,PredName),
1785 Head =.. [PredName,Key,SuspsList],
1786 multi_hash_store_name(C,Index,StoreName),
1787 Body =
1788 (
1789 nb_getval(StoreName,HT),
1790 lookup_ht(HT,Key,SuspsList)
1791 ),
1792 L = [(Head :- Body)|L1],
1793 multi_hash_via_lookups(Indexes,C,L1,T).
1795 multi_hash_via_lookup_name(F/A,Index,Name) :-
1796 ( integer(Index) ->
1797 IndexName = Index
1798 ; is_list(Index) ->
1799 atom_concat_list(Index,IndexName)
1800 ),
1801 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
1803 multi_hash_store_name(F/A,Index,Name) :-
1804 get_target_module(Mod),
1805 ( integer(Index) ->
1806 IndexName = Index
1807 ; is_list(Index) ->
1808 atom_concat_list(Index,IndexName)
1809 ),
1810 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
1812 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
1813 ( ( integer(Index) ->
1814 I = Index
1815 ;
1816 Index = [I]
1817 ) ->
1818 SuspIndex is I + 6,
1819 KeyBody = arg(SuspIndex,Susp,Key)
1820 ; is_list(Index) ->
1821 sort(Index,Indexes),
1822 find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
1823 pairup(Bodies,Keys,ArgKeyPairs),
1824 Key =.. [k|Keys],
1825 list2conj(Bodies,KeyBody)
1826 ).
1828 multi_hash_key_args(Index,Head,KeyArgs) :-
1829 ( integer(Index) ->
1830 arg(Index,Head,Arg),
1831 KeyArgs = [Arg]
1832 ; is_list(Index) ->
1833 sort(Index,Indexes),
1834 term_variables(Head,Vars),
1835 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
1836 ).
1838 global_ground_store_name(F/A,Name) :-
1839 get_target_module(Mod),
1840 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
1841 global_singleton_store_name(F/A,Name) :-
1842 get_target_module(Mod),
1843 atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
1844 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1845 enumerate_stores_code(Constraints,Clause) :-
1846 Head = '$enumerate_suspensions'(Susp),
1847 enumerate_store_bodies(Constraints,Susp,Bodies),
1848 list2disj(Bodies,Body),
1849 Clause = (Head :- Body).
1851 enumerate_store_bodies([],_,[]).
1852 enumerate_store_bodies([C|Cs],Susp,L) :-
1853 ( is_stored(C) ->
1854 get_store_type(C,StoreType),
1855 enumerate_store_body(StoreType,C,Susp,B),
1856 L = [B|T]
1857 ;
1858 L = T
1859 ),
1860 enumerate_store_bodies(Cs,Susp,T).
1862 enumerate_store_body(default,C,Susp,Body) :-
1863 get_constraint_index(C,Index),
1864 get_target_module(Mod),
1865 get_max_constraint_index(MaxIndex),
1866 Body1 =
1867 (
1868 'chr global_term_ref_1'(GlobalStore),
1869 get_attr(GlobalStore,Mod,Attr)
1870 ),
1871 ( MaxIndex > 1 ->
1872 NIndex is Index + 1,
1873 Body2 =
1874 (
1875 arg(NIndex,Attr,List),
1876 'chr sbag_member'(Susp,List)
1877 )
1878 ;
1879 Body2 = 'chr sbag_member'(Susp,Attr)
1880 ),
1881 Body = (Body1,Body2).
1882 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
1883 multi_hash_enumerate_store_body(Index,C,Susp,Body).
1884 enumerate_store_body(global_ground,C,Susp,Body) :-
1885 global_ground_store_name(C,StoreName),
1886 Body =
1887 (
1888 nb_getval(StoreName,List),
1889 'chr sbag_member'(Susp,List)
1890 ).
1891 enumerate_store_body(global_singleton,C,Susp,Body) :-
1892 global_singleton_store_name(C,StoreName),
1893 Body =
1894 (
1895 nb_getval(StoreName,Susp),
1896 Susp \== []
1897 ).
1898 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
1899 once((
1900 member(ST,STs),
1901 enumerate_store_body(ST,C,Susp,Body)
1902 )).
1904 multi_hash_enumerate_store_body(I,C,Susp,B) :-
1905 multi_hash_store_name(C,I,StoreName),
1906 B =
1907 (
1908 nb_getval(StoreName,HT),
1909 value_ht(HT,Susp)
1910 ).
1912 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1915 :- constraints
1916 prev_guard_list/7,
1917 simplify_guards/1,
1918 set_all_passive/1.
1920 option(mode,prev_guard_list(+,+,+,+,+,+,+)).
1921 option(mode,simplify_guards(+)).
1922 option(mode,set_all_passive(+)).
1924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1925 % GUARD SIMPLIFICATION
1926 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1927 % If the negation of the guards of earlier rules entails (part of)
1928 % the current guard, the current guard can be simplified. We can only
1929 % use earlier rules with a head that matches if the head of the current
1930 % rule does, and which make it impossible for the current rule to match
1931 % if they fire (i.e. they shouldn't be propagation rules and their
1932 % head constraints must be subsets of those of the current rule).
1933 % At this point, we know for sure that the negation of the guard
1934 % of such a rule has to be true (otherwise the earlier rule would have
1935 % fired, because of the refined operational semantics), so we can use
1936 % that information to simplify the guard by replacing all entailed
1937 % conditions by true/0. As a consequence, the never-stored analysis
1938 % (in a further phase) will detect more cases of never-stored constraints.
1939 %
1940 % e.g. c(X),d(Y) <=> X > 0 | ...
1941 % e(X) <=> X < 0 | ...
1942 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
1943 % \____________/
1944 % true
1946 guard_simplification :-
1947 ( chr_pp_flag(guard_simplification,on) ->
1948 multiple_occ_constraints_checked([]),
1949 simplify_guards(1)
1950 ;
1951 true
1952 ).
1954 % for every rule, we create a prev_guard_list where the last argument
1955 % eventually is a list of the negations of earlier guards
1956 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=>
1957 Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
1958 append(Head1,Head2,Heads),
1959 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
1960 add_guard_to_head(Heads,G,GHeads),
1961 PrevRule is RuleNb-1,
1962 prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
1963 multiple_occ_constraints_checked([]),
1964 NextRule is RuleNb+1, simplify_guards(NextRule).
1966 simplify_guards(_) <=> true.
1968 % the negation of the guard of a non-propagation rule is added
1969 % if its kept head constraints are a subset of the kept constraints of
1970 % the rule we're working on, and its removed head constraints (at least one)
1971 % are a subset of the removed constraints
1972 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
1973 Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
1974 H1 \== [],
1975 append(H1,H2,Heads),
1976 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
1977 term_variables(UniqueVarsHeads+H,HVars),
1978 strip_attributes(HVars,HVarAttrs), % this seems to be necessairy to get past the setof
1979 setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
1980 restore_attributes(HVars,HVarAttrs),
1981 Renamings \= []
1982 |
1983 compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
1984 append(GuardList,DerivedInfo,GL1),
1985 list2conj(GL1,GL_),
1986 conj2list(GL_,GL),
1987 append(GH_New1,GH,GH1),
1988 list2conj(GH1,GH_),
1989 conj2list(GH_,GH_New),
1990 N1 is N-1,
1991 prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
1994 % if this isn't the case, we skip this one and try the next rule
1995 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
1996 N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
1998 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
1999 GH \== [] |
2000 add_type_information_(H,GH,TypeInfo),
2001 conj2list(TypeInfo,TI),
2002 term_variables(H,HeadVars),
2003 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
2004 list2conj(Info,InfoC),
2005 conj2list(InfoC,InfoL),
2006 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
2008 add_type_information_(H,[],true) :- !.
2009 add_type_information_(H,[GH|GHs],TI) :- !,
2010 add_type_information(H,GH,TI1),
2011 TI = (TI1, TI2),
2012 add_type_information_(H,GHs,TI2).
2014 % when all earlier guards are added or skipped, we simplify the guard.
2015 % if it's different from the original one, we change the rule
2016 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=>
2017 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2018 G \== true, % let's not try to simplify this ;)
2019 append(M,GuardList,Info),
2020 simplify_guard(G,B,Info,SimpleGuard,NB),
2021 G \== SimpleGuard |
2022 % ( prolog_flag(verbose,V), V == yes ->
2023 % format(' * Guard simplification in ~@\n',[format_rule(Rule)]),
2024 % format(' was: ~w\n',[G]),
2025 % format(' now: ~w\n',[SimpleGuard]),
2026 % (NB\==B -> format(' new body: ~w\n',[NB]) ; true)
2027 % ;
2028 % true
2029 % ),
2030 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
2031 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
2034 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2035 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
2036 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2038 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
2040 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
2041 copy_term(Matchings-G2,FreshMatchings),
2042 variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
2043 append(Renaming1,ExtraRenaming,Renaming2),
2044 list2conj(Matchings,Match),
2045 negate_b(Match,HeadsDontMatch),
2046 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
2047 list2conj(HeadsMatch,HeadsMatchBut),
2048 term_variables(Renaming2,RenVars),
2049 term_variables(Matchings-G2-HeadsMatch,MGVars),
2050 new_vars(MGVars,RenVars,ExtraRenaming2),
2051 append(Renaming2,ExtraRenaming2,Renaming),
2052 negate_b(G2,TheGuardFailed),
2053 ( G2 == true -> % true can't fail
2054 Info_ = HeadsDontMatch
2055 ;
2056 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
2057 ),
2058 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
2059 copy_with_variable_replacement(G2,RenamedG2,Renaming),
2060 copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
2061 list2conj(RenamedMatchings_,RenamedMatchings),
2062 add_guard_to_head(H,RenamedG2,GH2),
2063 add_guard_to_head(GH2,RenamedMatchings,GH3),
2064 compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
2065 append([DerivedInfo1],DerivedInfo2,DerivedInfo),
2066 append([GH3],GH_New2,GH_New).
2069 simplify_guard(G,B,Info,SG,NB) :-
2070 conj2list(G,LG),
2071 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
2072 list2conj(SGL,SG).
2075 new_vars([],_,[]).
2076 new_vars([A|As],RV,ER) :-
2077 ( memberchk_eq(A,RV) ->
2078 new_vars(As,RV,ER)
2079 ;
2080 ER = [A-NewA,NewA-A|ER2],
2081 new_vars(As,RV,ER2)
2082 ).
2084 % check if a list of constraints is a subset of another list of constraints
2085 % (multiset-subset), meanwhile computing a variable renaming to convert
2086 % one into the other.
2087 head_subset(H,Head,Renaming) :-
2088 head_subset(H,Head,Renaming,[],_).
2090 % empty list is a subset of everything
2091 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
2092 Renaming = Cumul,
2093 Headleft = Head.
2095 % first constraint has to be in the list, the rest has to be a subset
2096 % of the list with one occurrence of the first constraint removed
2097 % (has to be multiset-subset)
2098 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
2099 head_subset(A,Head,R1,Cumul,Headleft1),
2100 head_subset(B,Headleft1,R2,R1,Headleft2),
2101 Renaming = R2,
2102 Headleft = Headleft2.
2104 % check if A is in the list, remove it from Headleft
2105 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
2106 ( head_subset(A,X,R1,Cumul,HL1),
2107 Renaming = R1,
2108 Headleft = Y
2109 ;
2110 head_subset(A,Y,R2,Cumul,HL2),
2111 Renaming = R2,
2112 Headleft = [X|HL2]
2113 ).
2115 % A is X if there's a variable renaming to make them identical
2116 head_subset(A,X,Renaming,Cumul,Headleft) :-
2117 variable_replacement(A,X,Cumul,Renaming),
2118 Headleft = [].
2120 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
2121 extract_variables(Heads,VH1),
2122 make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
2123 insert_variables(H1_,Heads,UniqueVarsHeads).
2125 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
2126 extract_variables(Heads,VH1),
2127 make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
2128 insert_variables(H1_,Heads,UniqueVarsHeads).
2130 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
2131 extract_variables(Heads,VH1),
2132 extract_variables(UniqueVarsHeads,UV),
2133 make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
2136 extract_variables([],[]).
2137 extract_variables([X|R],V) :-
2138 X =.. [_|Args],
2139 extract_variables(R,V2),
2140 append(Args,V2,V).
2142 insert_variables([],[],[]) :- !.
2143 insert_variables(Vars,[C|R],[C2|R2]) :-
2144 C =.. [F | Args],
2145 length(Args,N),
2146 take_first_N(Vars,N,Args2,RestVars),
2147 C2 =.. [F | Args2],
2148 insert_variables(RestVars,R,R2).
2150 take_first_N(Vars,0,[],Vars) :- !.
2151 take_first_N([X|R],N,[X|R2],RestVars) :-
2152 N1 is N-1,
2153 take_first_N(R,N1,R2,RestVars).
2155 make_matchings_explicit([],[],_,MC,MC,[]).
2156 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
2157 ( var(X) ->
2158 ( memberchk_eq(X,C) ->
2159 list2disj(MC,MC_disj),
2160 M = [(MC_disj ; NewVar == X)|M2], % or only = ??
2161 C2 = C
2162 ;
2163 M = M2,
2164 NewVar = X,
2165 C2 = [X|C]
2166 ),
2167 MC2 = MC
2168 ;
2169 functor(X,F,A),
2170 X =.. [F|Args],
2171 make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
2172 X_ =.. [F|NewArgs],
2173 (ArgM == [] ->
2174 M = [functor(NewVar,F,A) |M2]
2175 ;
2176 list2conj(ArgM,ArgM_conj),
2177 list2disj(MC,MC_disj),
2178 ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
2179 M = [ functor(NewVar,F,A) , ArgM_|M2]
2180 ),
2181 MC2 = [ NewVar \= X_ |MC_],
2182 term_variables(Args,ArgVars),
2183 append(C,ArgVars,C2)
2184 ),
2185 make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
2188 make_matchings_explicit_not_negated([],[],_,[]).
2189 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
2190 M = [NewVar = X|M2],
2191 C2 = C,
2192 make_matchings_explicit_not_negated(R,R2,C2,M2).
2195 add_guard_to_head([],G,[]).
2196 add_guard_to_head([H|RH],G,[GH|RGH]) :-
2197 (var(H) ->
2198 find_guard_info_for_var(H,G,GH)
2199 ;
2200 functor(H,F,A),
2201 H =.. [F|HArgs],
2202 add_guard_to_head(HArgs,G,NewHArgs),
2203 GH =.. [F|NewHArgs]
2204 ),
2205 add_guard_to_head(RH,G,RGH).
2207 find_guard_info_for_var(H,(G1,G2),GH) :- !,
2208 find_guard_info_for_var(H,G1,GH1),
2209 find_guard_info_for_var(GH1,G2,GH).
2211 find_guard_info_for_var(H,G,GH) :-
2212 (G = (H1 = A), H == H1 ->
2213 GH = A
2214 ;
2215 (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
2216 length(GHArg,HA),
2217 GH =.. [HF|GHArg]
2218 ;
2219 GH = H
2220 )
2221 ).
2223 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2224 % ALWAYS FAILING HEADS
2225 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2227 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=>
2228 chr_pp_flag(check_impossible_rules,on),
2229 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2230 append(M,GuardList,Info),
2231 guard_entailment:entails_guard(Info,fail) |
2232 format('CHR compiler WARNING: heads will never match in ~@.\n',[format_rule(Rule)]),
2233 format(' `--> In the refined operational semantics (rules applied in textual order)\n',[]),
2234 format(' this rule will never fire! (given the declared types/modes)\n',[]),
2235 format(' Removing this redundant rule by making all its heads passive...\n',[]),
2236 format(' ... next warning is caused by this ...\n',[]),
2237 set_all_passive(RuleNb).
2239 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2240 % HEAD SIMPLIFICATION
2241 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2243 % now we check the head matchings (guard may have been simplified meanwhile)
2244 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=>
2245 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2246 simplify_heads(M,GuardList,G,B,NewM,NewB),
2247 NewM \== [],
2248 extract_variables(Head1,VH1),
2249 extract_variables(Head2,VH2),
2250 extract_variables(H,VH),
2251 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
2252 insert_variables(H1,Head1,NewH1),
2253 insert_variables(H2,Head2,NewH2),
2254 append(NewB,NewB_,NewBody),
2255 list2conj(NewBody,BodyMatchings),
2256 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
2257 (Head1 \== NewH1 ; Head2 \== NewH2 )
2258 |
2259 % ( prolog_flag(verbose,V), V == yes ->
2260 % format(' * Head simplification in ~@\n',[format_rule(Rule)]),
2261 % format(' was: ~w \\ ~w \n',[Head2,Head1]),
2262 % format(' now: ~w \\ ~w \n',[NewH2,NewH1]),
2263 % format(' extra body: ~w \n',[BodyMatchings])
2264 % ;
2265 % true
2266 % ),
2267 rule(RuleNb,NewRule).
2271 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2272 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
2273 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2275 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
2276 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
2277 ( NH == M ->
2278 H2_ = M,
2279 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
2280 ;
2281 (M = functor(X,F,A), NH == X ->
2282 length(A_args,A),
2283 (var(H2) ->
2284 NewB1 = [],
2285 H2_ =.. [F|A_args]
2286 ;
2287 H2 =.. [F|OrigArgs],
2288 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2289 H2_ =.. [F|A_args_]
2290 ),
2291 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
2292 append(NewB1,NewB2,NewB)
2293 ;
2294 H2_ = H2,
2295 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
2296 )
2297 ).
2299 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
2300 ( NH == M ->
2301 H1_ = M,
2302 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
2303 ;
2304 (M = functor(X,F,A), NH == X ->
2305 length(A_args,A),
2306 (var(H1) ->
2307 NewB1 = [],
2308 H1_ =.. [F|A_args]
2309 ;
2310 H1 =.. [F|OrigArgs],
2311 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
2312 H1_ =.. [F|A_args_]
2313 ),
2314 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
2315 append(NewB1,NewB2,NewB)
2316 ;
2317 H1_ = H1,
2318 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
2319 )
2320 ).
2322 use_same_args([],[],[],_,_,[]).
2323 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2324 var(OA),!,
2325 Out = OA,
2326 use_same_args(ROA,RNA,ROut,G,Body,NewB).
2327 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
2328 nonvar(OA),!,
2329 ( vars_occur_in(OA,Body) ->
2330 NewB = [NA = OA|NextB]
2331 ;
2332 NewB = NextB
2333 ),
2334 Out = NA,
2335 use_same_args(ROA,RNA,ROut,G,Body,NextB).
2338 simplify_heads([],_GuardList,_G,_Body,[],[]).
2339 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
2340 M = (A = B),
2341 ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),guard_entailment:entails_guard(GuardList,(A=B)) ->
2342 ( vars_occur_in(B,G-RM-GuardList) ->
2343 NewB = NextB,
2344 NewM = NextM
2345 ;
2346 ( vars_occur_in(B,Body) ->
2347 NewB = [A = B|NextB]
2348 ;
2349 NewB = NextB
2350 ),
2351 NewM = [A|NextM]
2352 )
2353 ;
2354 ( nonvar(B), functor(B,BFu,BAr),
2355 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
2356 NewB = NextB,
2357 ( vars_occur_in(B,G-RM-GuardList) ->
2358 NewM = NextM
2359 ;
2360 NewM = [functor(A,BFu,BAr)|NextM]
2361 )
2362 ;
2363 NewM = NextM,
2364 NewB = NextB
2365 )
2366 ),
2367 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
2369 vars_occur_in(B,G) :-
2370 term_variables(B,BVars),
2371 term_variables(G,GVars),
2372 intersect_eq(BVars,GVars,L),
2373 L \== [].
2376 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2377 % ALWAYS FAILING GUARDS
2378 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2380 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID) ==> passive(RuleNb,ID).
2381 set_all_passive(_) <=> true.
2383 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==>
2384 chr_pp_flag(check_impossible_rules,on),
2385 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
2386 conj2list(G,GL),
2387 guard_entailment:entails_guard(GL,fail) |
2388 format('CHR compiler WARNING: guard will always fail in ~@.\n',[format_rule(Rule)]),
2389 format(' Removing this redundant rule by making all its heads passive...\n',[]),
2390 format(' ... next warning is caused by this ...\n',[]),
2391 set_all_passive(RuleNb).
2395 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2396 % OCCURRENCE SUBSUMPTION
2397 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2399 :- constraints
2400 first_occ_in_rule/4,
2401 next_occ_in_rule/6,
2402 multiple_occ_constraints_checked/1.
2404 option(mode,first_occ_in_rule(+,+,+,+)).
2405 option(mode,next_occ_in_rule(+,+,+,+,+,+)).
2406 option(mode,multiple_occ_constraints_checked(+)).
2410 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2411 occurrence(C,O,RuleNb,ID), occurrence(C,O2,RuleNb,ID2), rule(RuleNb,Rule)
2412 \ multiple_occ_constraints_checked(Done) <=>
2413 O < O2,
2414 chr_pp_flag(occurrence_subsumption,on),
2415 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
2416 H1 \== [],
2417 \+ memberchk_eq(C,Done) |
2418 first_occ_in_rule(RuleNb,C,O,ID),
2419 multiple_occ_constraints_checked([C|Done]).
2422 occurrence(C,O,RuleNb,ID) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 |
2423 first_occ_in_rule(RuleNb,C,O,ID).
2425 first_occ_in_rule(RuleNb,C,O,ID_o1) <=>
2426 C = F/A,
2427 functor(FreshHead,F,A),
2428 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
2430 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2)
2431 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
2432 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
2435 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2436 occurrence(C,O2,RuleNb,ID_o2), rule(RuleNb,Rule) \
2437 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
2438 O2 is O+1,
2439 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
2440 |
2441 append(H1,H2,Heads),
2442 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
2443 ( ExtraCond == [chr_pp_void_info] ->
2444 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
2445 ;
2446 append(ExtraCond,Cond,NewCond),
2447 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
2448 copy_term(GuardList,FGuardList),
2449 variable_replacement(GuardList,FGuardList,GLRepl),
2450 copy_with_variable_replacement(GuardList,GuardList2,Repl),
2451 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
2452 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
2453 append(NewCond,GuardList2,BigCond),
2454 append(BigCond,GuardList3,BigCond2),
2455 copy_with_variable_replacement(M,M2,Repl),
2456 copy_with_variable_replacement(M,M3,Repl2),
2457 append(M3,BigCond2,BigCond3),
2458 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
2459 list2conj(CheckCond,OccSubsum),
2460 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
2461 term_variables(NewCond2-FH2,InfoVars),
2462 flatten_stuff(Info2,Info3),
2463 flatten_stuff(OccSubsum2,OccSubsum3),
2464 ( OccSubsum \= chr_pp_void_info,
2465 unify_stuff(InfoVars,Info3,OccSubsum3), !,
2466 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
2467 % ( prolog_flag(verbose,V), V == yes ->
2468 % format(' * Occurrence subsumption detected in ~@\n',[format_rule(Rule)]),
2469 % format(' passive: constraint ~w, occurrence number ~w (id ~w)\n',[C,O2,ID_o2]),
2470 % ;
2471 % true
2472 % ),
2473 passive(RuleNb,ID_o2)
2474 ;
2475 true
2476 )
2477 ; true
2478 ),!,
2479 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
2480 ).
2483 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
2484 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
2485 multiple_occ_constraints_checked(Done) <=> true.
2487 flatten_stuff([A|B],C) :- !,
2488 flatten_stuff(A,C1),
2489 flatten_stuff(B,C2),
2490 append(C1,C2,C).
2491 flatten_stuff((A;B),C) :- !,
2492 flatten_stuff(A,C1),
2493 flatten_stuff(B,C2),
2494 append(C1,C2,C).
2495 flatten_stuff((A,B),C) :- !,
2496 flatten_stuff(A,C1),
2497 flatten_stuff(B,C2),
2498 append(C1,C2,C).
2500 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
2501 flatten_stuff(X,[]).
2503 unify_stuff(AllInfo,[],[]).
2505 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
2506 H \== I,
2507 term_variables(H,HVars),
2508 term_variables(I,IVars),
2509 intersect_eq(HVars,IVars,SharedVars),
2510 check_safe_unif(H,I,SharedVars),
2511 variable_replacement(H,I,Repl),
2512 check_replacement(Repl),
2513 term_variables(Repl,ReplVars),
2514 list_difference_eq(ReplVars,HVars,LDiff),
2515 intersect_eq(AllInfo,LDiff,LDiff2),
2516 LDiff2 == [],
2517 H = I,
2518 unify_stuff(AllInfo,RInfo,ROS),!.
2520 unify_stuff(AllInfo,X,[Y|ROS]) :-
2521 unify_stuff(AllInfo,X,ROS).
2523 unify_stuff(AllInfo,[Y|RInfo],X) :-
2524 unify_stuff(AllInfo,RInfo,X).
2526 check_safe_unif(H,I,SV) :- var(H), !, var(I),
2527 ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
2528 H == I
2529 ;
2530 true
2531 ).
2533 check_safe_unif([],[],SV) :- !.
2534 check_safe_unif([H|Hs],[I|Is],SV) :- !,
2535 check_safe_unif(H,I,SV),!,
2536 check_safe_unif(Hs,Is,SV).
2538 check_safe_unif(H,I,SV) :-
2539 nonvar(H),!,nonvar(I),
2540 H =.. [F|HA],
2541 I =.. [F|IA],
2542 check_safe_unif(HA,IA,SV).
2544 check_safe_unif2(H,I) :- var(H), !.
2546 check_safe_unif2([],[]) :- !.
2547 check_safe_unif2([H|Hs],[I|Is]) :- !,
2548 check_safe_unif2(H,I),!,
2549 check_safe_unif2(Hs,Is).
2551 check_safe_unif2(H,I) :-
2552 nonvar(H),!,nonvar(I),
2553 H =.. [F|HA],
2554 I =.. [F|IA],
2555 check_safe_unif2(HA,IA).
2558 check_replacement(Repl) :-
2559 check_replacement(Repl,FirstVars),
2560 sort(FirstVars,Sorted),
2561 length(Sorted,L),!,
2562 length(FirstVars,L).
2564 check_replacement([],[]).
2565 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
2568 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
2569 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
2570 append(ID2,ID1,IDs),
2571 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
2572 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
2573 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
2574 copy_with_variable_replacement(G,FG,Repl),
2575 extract_explicit_matchings(FG,FG2),
2576 negate_b(FG2,NotFG),
2577 copy_with_variable_replacement(MPCond,FMPCond,Repl),
2578 ( check_safe_unif2(FH,FH2), FH=FH2 ->
2579 FailCond = [(NotFG;FMPCond)]
2580 ;
2581 % in this case, not much can be done
2582 % e.g. c(f(...)), c(g(...)) <=> ...
2583 FailCond = [chr_pp_void_info]
2584 ).
2588 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
2589 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
2590 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
2591 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
2592 Cond = (chr_pp_not_in_store(H);Cond1),
2593 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
2596 extract_explicit_matchings(A=B) :-
2597 var(A), var(B), !, A=B.
2598 extract_explicit_matchings(A==B) :-
2599 var(A), var(B), !, A=B.
2601 extract_explicit_matchings((A,B),D) :- !,
2602 ( extract_explicit_matchings(A) ->
2603 extract_explicit_matchings(B,D)
2604 ;
2605 D = (A,E),
2606 extract_explicit_matchings(B,E)
2607 ).
2608 extract_explicit_matchings(A,D) :- !,
2609 ( extract_explicit_matchings(A) ->
2610 D = true
2611 ;
2612 D = A
2613 ).
2618 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2619 % TYPE INFORMATION
2620 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2622 :- constraints
2623 type_definition/2,
2624 constraint_type/2,
2625 get_type_definition/2,
2626 get_constraint_type/2,
2627 add_type_information/3.
2630 option(mode,type_definition(?,?)).
2631 option(mode,constraint_type(+,+)).
2632 option(mode,add_type_information(+,+,?)).
2633 option(type_declaration,add_type_information(list,list,any)).
2635 type_definition(T,D) \ get_type_definition(T2,Def) <=>
2636 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A) |
2637 copy_term((T,D),(T1,D1)),T1=T2,Def = D1.
2638 get_type_definition(_,_) <=> fail.
2639 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
2640 get_constraint_type(_,_) <=> fail.
2642 add_type_information([],[],T) <=> T=true.
2644 constraint_mode(F/A,Modes)
2645 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
2646 functor(Head,F,A) |
2647 Head =.. [_|Args],
2648 RealHead =.. [_|RealArgs],
2649 add_mode_info(Modes,Args,ModeInfo),
2650 TypeInfo = (ModeInfo, TI),
2651 (get_constraint_type(F/A,Types) ->
2652 types2condition(Types,Args,RealArgs,Modes,TI2),
2653 list2conj(TI2,ConjTI),
2654 TI = (ConjTI,RTI),
2655 add_type_information(R,RRH,RTI)
2656 ;
2657 add_type_information(R,RRH,TI)
2658 ).
2661 add_type_information([Head|R],_,TypeInfo) <=>
2662 functor(Head,F,A),
2663 format('CHR compiler ERROR: mode information missing for ~w.\n',[F/A]),
2664 format(' `--> Most likely this is a bug in the compiler itself.\n',[]),
2665 format(' Please contact the maintainers.\n',[]),
2666 fail.
2669 add_mode_info([],[],true).
2670 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
2671 MI = (ground(A), ModeInfo),
2672 add_mode_info(Modes,Args,ModeInfo).
2673 add_mode_info([M|Modes],[A|Args],MI) :-
2674 add_mode_info(Modes,Args,MI).
2677 types2condition([],[],[],[],[]).
2678 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
2679 (get_type_definition(Type,Def) ->
2680 type2condition(Def,Arg,RealArg,TC),
2681 (Mode \== (+) ->
2682 TC_ = [(\+ ground(Arg))|TC]
2683 ;
2684 TC_ = TC
2685 ),
2686 list2disj(TC_,DisjTC),
2687 TI = [DisjTC|RTI],
2688 types2condition(Types,Args,RAs,Modes,RTI)
2689 ;
2690 ( builtin_type(Type,Arg,C) ->
2691 TI = [C|RTI],
2692 types2condition(Types,Args,RAs,Modes,RTI)
2693 ;
2694 format('CHR compiler ERROR: Undefined type ~w.\n',[Type]),
2695 fail
2696 )
2697 ).
2699 type2condition([],Arg,_,[]).
2700 type2condition([Def|Defs],Arg,RealArg,TC) :-
2701 ( builtin_type(Def,Arg,C) ->
2702 true
2703 ;
2704 real_type(Def,Arg,RealArg,C)
2705 ),
2706 item2list(C,LC),
2707 type2condition(Defs,Arg,RealArg,RTC),
2708 append(LC,RTC,TC).
2710 item2list([],[]) :- !.
2711 item2list([X|Y],[X|Y]) :- !.
2712 item2list(N,L) :- L = [N].
2714 builtin_type(X,Arg,true) :- var(X),!.
2715 builtin_type(any,Arg,true).
2716 builtin_type(int,Arg,integer(Arg)).
2717 builtin_type(number,Arg,number(Arg)).
2718 builtin_type(float,Arg,float(Arg)).
2719 builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
2721 real_type(Def,Arg,RealArg,C) :-
2722 ( nonvar(Def) ->
2723 functor(Def,F,A),
2724 ( A == 0 ->
2725 C = (Arg = F)
2726 ;
2727 Def =.. [_|TArgs],
2728 length(AA,A),
2729 Def2 =.. [F|AA],
2730 ( var(RealArg) ->
2731 C = functor(Arg,F,A)
2732 ;
2733 ( functor(RealArg,F,A) ->
2734 RealArg =.. [_|RAArgs],
2735 nested_types(TArgs,AA,RAArgs,ACond),
2736 C = (functor(Arg,F,A),Arg=Def2,ACond)
2737 ;
2738 C = functor(Arg,F,A)
2739 )
2740 )
2741 )
2742 ;
2743 format('CHR compiler ERROR: Illegal type definition (must be nonvar).\n',[]),
2744 fail
2745 ).
2746 nested_types([],[],[],true).
2747 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
2748 (get_type_definition(T,Def) ->
2749 type2condition(Def,A,RealA,TC),
2750 list2disj(TC,DisjTC),
2751 C = (DisjTC, RC),
2752 nested_types(RT,RA,RRA,RC)
2753 ;
2754 ( builtin_type(T,A,Cond) ->
2755 C = (Cond, RC),
2756 nested_types(RT,RA,RRA,RC)
2757 ;
2758 format('CHR compiler ERROR: Undefined type ~w inside type definition.\n',[T]),
2759 fail
2760 )
2761 ).
2764 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2766 :- constraints
2767 stored/3, % constraint,occurrence,(yes/no/maybe)
2768 stored_completing/3,
2769 stored_complete/3,
2770 is_stored/1,
2771 is_finally_stored/1,
2772 check_all_passive/2.
2774 option(mode,stored(+,+,+)).
2775 option(type_declaration,stored(any,int,storedinfo)).
2776 option(type_definition,type(storedinfo,[yes,no,maybe])).
2777 option(mode,stored_complete(+,+,+)).
2778 option(mode,maybe_complementary_guards(+,+,?,?)).
2779 option(mode,guard_list(+,+,+,+)).
2780 option(mode,check_all_passive(+,+)).
2782 % change yes in maybe when yes becomes passive
2783 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID) \
2784 stored(C,O,yes), stored_complete(C,RO,Yesses)
2785 <=> O < RO | NYesses is Yesses - 1,
2786 stored(C,O,maybe), stored_complete(C,RO,NYesses).
2787 % change yes in maybe when not observed
2788 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
2789 <=> O < RO |
2790 NYesses is Yesses - 1,
2791 stored(C,O,maybe), stored_complete(C,RO,NYesses).
2793 occurrence(_,_,RuleNb,ID), occurrence(C2,_,RuleNb,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
2794 ==> RO =< MO2 | % C2 is never stored
2795 passive(RuleNb,ID).
2800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2802 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
2803 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
2804 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
2806 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
2807 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
2808 check_all_passive(RuleNb,IDs2).
2810 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
2811 check_all_passive(RuleNb,IDs).
2813 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
2814 format('CHR compiler WARNING: all heads passive in ~@.\n',[format_rule(Rule)]),
2815 format(' `--> Rule never fires. Check your program, this might be a bug!\n',[]).
2817 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2819 % collect the storage information
2820 stored(C,O,yes) \ stored_completing(C,O,Yesses)
2821 <=> NO is O + 1, NYesses is Yesses + 1,
2822 stored_completing(C,NO,NYesses).
2823 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
2824 <=> NO is O + 1,
2825 stored_completing(C,NO,Yesses).
2827 stored(C,O,no) \ stored_completing(C,O,Yesses)
2828 <=> stored_complete(C,O,Yesses).
2829 stored_completing(C,O,Yesses)
2830 <=> stored_complete(C,O,Yesses).
2832 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id) ==>
2833 O2 > O | passive(RuleNb,Id).
2835 % decide whether a constraint is stored
2836 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
2837 <=> RO =< MO | fail.
2838 is_stored(C) <=> true.
2840 % decide whether a constraint is suspends after occurrences
2841 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
2842 <=> RO =< MO | fail.
2843 is_finally_stored(C) <=> true.
2845 storage_analysis(Constraints) :-
2846 ( chr_pp_flag(storage_analysis,on) ->
2847 check_constraint_storages(Constraints)
2848 ;
2849 true
2850 ).
2852 check_constraint_storages([]).
2853 check_constraint_storages([C|Cs]) :-
2854 check_constraint_storage(C),
2855 check_constraint_storages(Cs).
2857 check_constraint_storage(C) :-
2858 get_max_occurrence(C,MO),
2859 check_occurrences_storage(C,1,MO).
2861 check_occurrences_storage(C,O,MO) :-
2862 ( O > MO ->
2863 stored_completing(C,1,0)
2864 ;
2865 check_occurrence_storage(C,O),
2866 NO is O + 1,
2867 check_occurrences_storage(C,NO,MO)
2868 ).
2870 check_occurrence_storage(C,O) :-
2871 get_occurrence(C,O,RuleNb,ID),
2872 ( is_passive(RuleNb,ID) ->
2873 stored(C,O,maybe)
2874 ;
2875 get_rule(RuleNb,PragmaRule),
2876 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
2877 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
2878 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
2879 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
2880 check_storage_head2(Head2,O,Heads1,Body)
2881 )
2882 ).
2884 check_storage_head1(Head,O,H1,H2,G) :-
2885 functor(Head,F,A),
2886 C = F/A,
2887 ( H1 == [Head],
2888 H2 == [],
2889 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
2890 Head =.. [_|L],
2891 no_matching(L,[]) ->
2892 stored(C,O,no)
2893 ;
2894 stored(C,O,maybe)
2895 ).
2897 no_matching([],_).
2898 no_matching([X|Xs],Prev) :-
2899 var(X),
2900 \+ memberchk_eq(X,Prev),
2901 no_matching(Xs,[X|Prev]).
2903 check_storage_head2(Head,O,H1,B) :-
2904 functor(Head,F,A),
2905 C = F/A,
2906 ( ( (H1 \== [], B == true ) ;
2907 \+ is_observed(F/A,O) ) ->
2908 stored(C,O,maybe)
2909 ;
2910 stored(C,O,yes)
2911 ).
2913 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2915 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2916 %% ____ _ ____ _ _ _ _
2917 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
2918 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
2919 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
2920 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
2921 %% |_|
2923 constraints_code(Constraints,Clauses) :-
2924 constraints_code1(Constraints,L,[]),
2925 clean_clauses(L,Clauses).
2927 %===============================================================================
2928 constraints constraints_code1/3.
2929 option(mode,constraints_code1(+,+,+)).
2930 %-------------------------------------------------------------------------------
2931 constraints_code1([],L,T) <=> L = T.
2932 constraints_code1([C|RCs],L,T)
2933 <=>
2934 constraint_code(C,L,T1),
2935 constraints_code1(RCs,T1,T).
2936 %===============================================================================
2937 constraints constraint_code/3.
2938 option(mode,constraint_code(+,+,+)).
2939 %-------------------------------------------------------------------------------
2940 %% Generate code for a single CHR constraint
2941 constraint_code(Constraint, L, T)
2942 <=> true
2943 | ( (chr_pp_flag(debugable,on) ;
2944 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
2945 ( may_trigger(Constraint) ;
2946 get_allocation_occurrence(Constraint,AO),
2947 get_max_occurrence(Constraint,MO), MO >= AO ) )
2948 ->
2949 constraint_prelude(Constraint,Clause),
2950 L = [Clause | L1]
2951 ;
2952 L = L1
2953 ),
2954 Id = [0],
2955 occurrences_code(Constraint,1,Id,NId,L1,L2),
2956 gen_cond_attach_clause(Constraint,NId,L2,T).
2957 %===============================================================================
2958 %% Generate prelude predicate for a constraint.
2959 %% f(...) :- f/a_0(...,Susp).
2960 constraint_prelude(F/A, Clause) :-
2961 vars_susp(A,Vars,Susp,VarsSusp),
2962 Head =.. [ F | Vars],
2963 build_head(F,A,[0],VarsSusp,Delegate),
2964 get_target_module(Mod),
2965 FTerm =.. [F|Vars],
2966 ( chr_pp_flag(debugable,on) ->
2967 use_auxiliary_predicate(insert_constraint_internal),
2968 generate_insert_constraint_call(F/A,Susp,InsertCall),
2969 make_name('attach_',F/A,AttachF),
2970 AttachCall =.. [AttachF,Vars2,Susp],
2971 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
2972 Clause =
2973 ( Head :-
2974 insert_constraint_internal(Stored,Vars2,Susp,Mod:Delegate,FTerm,Vars),
2975 InsertCall,
2976 AttachCall,
2977 Inactive,
2978 (
2979 'chr debug_event'(call(Susp)),
2980 Delegate
2981 ;
2982 'chr debug_event'(fail(Susp)), !,
2983 fail
2984 ),
2985 (
2986 'chr debug_event'(exit(Susp))
2987 ;
2988 'chr debug_event'(redo(Susp)),
2989 fail
2990 )
2991 )
2992 ; get_allocation_occurrence(F/A,0) ->
2993 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
2994 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
2995 Clause = ( Head :- Goal, Inactive, Delegate )
2996 ;
2997 Clause = ( Head :- Delegate )
2998 ).
3000 %===============================================================================
3001 constraints has_active_occurrence/1, has_active_occurrence/2.
3002 %-------------------------------------------------------------------------------
3003 has_active_occurrence(C) <=> has_active_occurrence(C,1).
3005 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
3006 O > MO | fail.
3007 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID) \
3008 has_active_occurrence(C,O) <=>
3009 NO is O + 1,
3010 has_active_occurrence(C,NO).
3011 has_active_occurrence(C,O) <=> true.
3012 %===============================================================================
3014 gen_cond_attach_clause(F/A,Id,L,T) :-
3015 ( is_finally_stored(F/A) ->
3016 get_allocation_occurrence(F/A,AllocationOccurrence),
3017 get_max_occurrence(F/A,MaxOccurrence),
3018 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
3019 ( may_trigger(F/A) ->
3020 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
3021 ;
3022 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
3023 )
3024 ; vars_susp(A,Args,Susp,AllArgs),
3025 gen_uncond_attach_goal(F/A,Susp,Body,_)
3026 ),
3027 ( chr_pp_flag(debugable,on) ->
3028 Constraint =.. [F|Args],
3029 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
3030 ;
3031 DebugEvent = true
3032 ),
3033 build_head(F,A,Id,AllArgs,Head),
3034 Clause = ( Head :- DebugEvent,Body ),
3035 L = [Clause | T]
3036 ;
3037 L = T
3038 ).
3040 constraints
3041 use_auxiliary_predicate/1,
3042 is_used_auxiliary_predicate/1.
3044 option(mode,use_auxiliary_predicate(+)).
3046 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
3048 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
3050 is_used_auxiliary_predicate(P) <=> fail.
3052 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
3053 vars_susp(A,Args,Susp,AllArgs),
3054 build_head(F,A,[0],AllArgs,Closure),
3055 ( may_trigger(F/A) ->
3056 make_name('attach_',F/A,AttachF),
3057 Attach =.. [AttachF,Vars,Susp]
3058 ;
3059 Attach = true
3060 ),
3061 get_target_module(Mod),
3062 FTerm =.. [F|Args],
3063 generate_insert_constraint_call(F/A,Susp,InsertCall),
3064 use_auxiliary_predicate(insert_constraint_internal),
3065 use_auxiliary_predicate(activate_constraint),
3066 Goal =
3067 (
3068 ( var(Susp) ->
3069 insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args)
3070 ;
3071 activate_constraint(Stored,Vars,Susp,_)
3072 ),
3073 ( Stored == yes ->
3074 InsertCall,
3075 Attach
3076 ;
3077 true
3078 )
3079 ).
3081 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
3082 vars_susp(A,Args,Susp,AllArgs),
3083 ( may_trigger(F/A) ->
3084 make_name('attach_',F/A,AttachF),
3085 Attach =.. [AttachF,Vars,Susp],
3086 build_head(F,A,[0],AllArgs,Closure),
3087 get_target_module(Mod),
3088 Cont = Mod : Closure
3089 ;
3090 Attach = true,
3091 Cont = true
3092 ),
3093 FTerm =.. [F|Args],
3094 generate_insert_constraint_call(F/A,Susp,InsertCall),
3095 use_auxiliary_predicate(insert_constraint_internal),
3096 Goal =
3097 (
3098 insert_constraint_internal(_,Vars,Susp,Cont,FTerm,Args),
3099 InsertCall,
3100 Attach
3101 ).
3103 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
3104 ( may_trigger(FA) ->
3105 make_name('attach_',FA,AttachF),
3106 Attach =.. [AttachF,Vars,Susp]
3107 ;
3108 Attach = true
3109 ),
3110 generate_insert_constraint_call(FA,Susp,InsertCall),
3111 ( chr_pp_flag(late_allocation,on) ->
3112 use_auxiliary_predicate(activate_constraint),
3113 AttachGoal =
3114 (
3115 activate_constraint(Stored,Vars, Susp, Generation),
3116 ( Stored == yes ->
3117 InsertCall,
3118 Attach
3119 ;
3120 true
3121 )
3122 )
3123 ;
3124 use_auxiliary_predicate(activate_constraint),
3125 AttachGoal =
3126 (
3127 activate_constraint(Stored,Vars, Susp, Generation)
3128 )
3129 ).
3131 %-------------------------------------------------------------------------------
3132 constraints occurrences_code/6.
3133 option(mode,occurrences_code(+,+,+,+,+,+)).
3134 %-------------------------------------------------------------------------------
3135 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
3136 <=> O > MO
3137 | NId = Id, L = T.
3138 occurrences_code(C,O,Id,NId,L,T)
3139 <=> occurrence_code(C,O,Id,Id1,L,L1),
3140 NO is O + 1,
3141 occurrences_code(C,NO,Id1,NId,L1,T).
3142 %-------------------------------------------------------------------------------
3143 constraints occurrence_code/6.
3144 option(mode,occurrence_code(+,+,+,+,+,+)).
3145 %-------------------------------------------------------------------------------
3146 occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
3147 <=> NId = Id, L = T.
3148 occurrence(C,O,RuleNb,ID), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
3149 <=> true |
3150 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
3151 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
3152 NId = Id,
3153 head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
3154 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
3155 head2_code(Head2,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
3156 inc_id(Id,NId),
3157 ( unconditional_occurrence(C,O) ->
3158 L1 = T
3159 ;
3160 gen_alloc_inc_clause(C,O,Id,L1,T)
3161 )
3162 ).
3163 occurrence_code(C,O,_,_,_,_)
3164 <=>
3165 format('occurrence_code/6: missing information to compile ~w:~w\n',[C,O]),fail.
3166 %-------------------------------------------------------------------------------
3168 %% Generate code based on one removed head of a CHR rule
3169 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3170 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3171 Rule = rule(_,Head2,_,_),
3172 ( Head2 == [] ->
3173 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3174 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
3175 ;
3176 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
3177 ).
3179 %% Generate code based on one persistent head of a CHR rule
3180 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
3181 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
3182 Rule = rule(Head1,_,_,_),
3183 ( Head1 == [] ->
3184 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
3185 propagation_code(Head,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
3186 ;
3187 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
3188 ).
3190 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
3191 vars_susp(A,Vars,Susp,VarsSusp),
3192 build_head(F,A,Id,VarsSusp,Head),
3193 inc_id(Id,IncId),
3194 build_head(F,A,IncId,VarsSusp,CallHead),
3195 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConditionalAlloc),
3196 Clause =
3197 (
3198 Head :-
3199 ConditionalAlloc,
3200 CallHead
3201 ),
3202 L = [Clause|T].
3204 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
3205 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
3206 ConstraintAllocationGoal =
3207 ( var(Susp) ->
3208 UncondConstraintAllocationGoal
3209 ;
3210 true
3211 ).
3212 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
3213 ( may_trigger(F/A) ->
3214 build_head(F,A,[0],VarsSusp,Term),
3215 get_target_module(Mod),
3216 Cont = Mod : Term
3217 ;
3218 Cont = true
3219 ),
3220 FTerm =.. [F|Vars],
3221 use_auxiliary_predicate(allocate_constraint),
3222 ConstraintAllocationGoal = allocate_constraint(Cont, Susp, FTerm, Vars).
3224 gen_occ_allocation(FA,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal) :-
3225 get_allocation_occurrence(FA,AO),
3226 ( chr_pp_flag(debugable,off), O == AO ->
3227 ( may_trigger(FA) ->
3228 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3229 ;
3230 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
3231 )
3232 ;
3233 ConstraintAllocationGoal = true
3234 ).
3235 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3240 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
3241 ( chr_pp_flag(guard_via_reschedule,on) ->
3242 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
3243 ;
3244 append(Retrievals,GuardList,GoalList),
3245 list2conj(GoalList,Goal)
3246 ).
3248 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
3249 initialize_unit_dictionary(Prelude,Dict),
3250 build_units(Retrievals,GuardList,Dict,Units),
3251 dependency_reorder(Units,NUnits),
3252 units2goal(NUnits,Goal).
3254 units2goal([],true).
3255 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
3256 units2goal(Units,Goals).
3258 dependency_reorder(Units,NUnits) :-
3259 dependency_reorder(Units,[],NUnits).
3261 dependency_reorder([],Acc,Result) :-
3262 reverse(Acc,Result).
3264 dependency_reorder([Unit|Units],Acc,Result) :-
3265 Unit = unit(_GID,_Goal,Type,GIDs),
3266 ( Type == fixed ->
3267 NAcc = [Unit|Acc]
3268 ;
3269 dependency_insert(Acc,Unit,GIDs,NAcc)
3270 ),
3271 dependency_reorder(Units,NAcc,Result).
3273 dependency_insert([],Unit,_,[Unit]).
3274 dependency_insert([X|Xs],Unit,GIDs,L) :-
3275 X = unit(GID,_,_,_),
3276 ( memberchk(GID,GIDs) ->
3277 L = [Unit,X|Xs]
3278 ;
3279 L = [X | T],
3280 dependency_insert(Xs,Unit,GIDs,T)
3281 ).
3283 build_units(Retrievals,Guard,InitialDict,Units) :-
3284 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
3285 build_guard_units(Guard,N,Dict,Tail).
3287 build_retrieval_units([],N,N,Dict,Dict,L,L).
3288 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
3289 term_variables(U,Vs),
3290 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3291 L = [unit(N,U,movable,GIDs)|L1],
3292 N1 is N + 1,
3293 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
3295 build_retrieval_units2([],N,N,Dict,Dict,L,L).
3296 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
3297 term_variables(U,Vs),
3298 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
3299 L = [unit(N,U,fixed,GIDs)|L1],
3300 N1 is N + 1,
3301 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
3303 initialize_unit_dictionary(Term,Dict) :-
3304 term_variables(Term,Vars),
3305 pair_all_with(Vars,0,Dict).
3307 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
3308 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3309 ( lookup_eq(Dict,V,GID) ->
3310 ( (GID == This ; memberchk(GID,GIDs) ) ->
3311 GIDs1 = GIDs
3312 ;
3313 GIDs1 = [GID|GIDs]
3314 ),
3315 Dict1 = Dict
3316 ;
3317 Dict1 = [V - This|Dict],
3318 GIDs1 = GIDs
3319 ),
3320 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3322 build_guard_units(Guard,N,Dict,Units) :-
3323 ( Guard = [Goal] ->
3324 Units = [unit(N,Goal,fixed,[])]
3325 ; Guard = [Goal|Goals] ->
3326 term_variables(Goal,Vs),
3327 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
3328 Units = [unit(N,Goal,movable,GIDs)|RUnits],
3329 N1 is N + 1,
3330 build_guard_units(Goals,N1,NDict,RUnits)
3331 ).
3333 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
3334 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
3335 ( lookup_eq(Dict,V,GID) ->
3336 ( (GID == This ; memberchk(GID,GIDs) ) ->
3337 GIDs1 = GIDs
3338 ;
3339 GIDs1 = [GID|GIDs]
3340 ),
3341 Dict1 = [V - This|Dict]
3342 ;
3343 Dict1 = [V - This|Dict],
3344 GIDs1 = GIDs
3345 ),
3346 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
3348 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3350 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3351 %% ____ _ ____ _ _
3352 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
3353 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
3354 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
3355 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
3356 %%
3357 %% _ _ _ ___ __
3358 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
3359 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
3360 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
3361 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
3362 %% |_|
3363 constraints
3364 functional_dependency/4,
3365 get_functional_dependency/4.
3367 option(mode,functional_dependency(+,+,?,?)).
3369 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_) \ functional_dependency(C,RuleNb,Pattern,Key)
3370 <=>
3371 RuleNb > 1, AO > O
3372 |
3373 functional_dependency(C,1,Pattern,Key).
3375 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
3376 <=>
3377 RuleNb2 >= RuleNb1
3378 |
3379 QPattern = Pattern, QKey = Key.
3380 get_functional_dependency(_,_,_,_)
3381 <=>
3382 fail.
3384 functional_dependency_analysis(Rules) :-
3385 ( chr_pp_flag(functional_dependency_analysis,on) ->
3386 functional_dependency_analysis_main(Rules)
3387 ;
3388 true
3389 ).
3391 functional_dependency_analysis_main([]).
3392 functional_dependency_analysis_main([PRule|PRules]) :-
3393 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
3394 functional_dependency(C,RuleNb,Pattern,Key)
3395 ;
3396 true
3397 ),
3398 functional_dependency_analysis_main(PRules).
3400 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
3401 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
3402 Rule = rule(H1,H2,Guard,_),
3403 ( H1 = [C1],
3404 H2 = [C2] ->
3405 true
3406 ; H1 = [C1,C2],
3407 H2 == [] ->
3408 true
3409 ),
3410 check_unique_constraints(C1,C2,Guard,RuleNb,List),
3411 term_variables(C1,Vs),
3412 select_pragma_unique_variables(Vs,List,Key1),
3413 copy_term_nat(C1-Key1,Pattern-Key),
3414 functor(C1,F,A).
3416 select_pragma_unique_variables([],_,[]).
3417 select_pragma_unique_variables([V|Vs],List,L) :-
3418 ( lookup_eq(List,V,_) ->
3419 L = T
3420 ;
3421 L = [V|T]
3422 ),
3423 select_pragma_unique_variables(Vs,List,T).
3425 % depends on functional dependency analysis
3426 % and shape of rule: C1 \ C2 <=> true.
3427 set_semantics_rules(Rules) :-
3428 ( chr_pp_flag(set_semantics_rule,on) ->
3429 set_semantics_rules_main(Rules)
3430 ;
3431 true
3432 ).
3434 set_semantics_rules_main([]).
3435 set_semantics_rules_main([R|Rs]) :-
3436 set_semantics_rule_main(R),
3437 set_semantics_rules_main(Rs).
3439 set_semantics_rule_main(PragmaRule) :-
3440 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
3441 ( Rule = rule([C1],[C2],true,_),
3442 IDs = ids([ID1],[ID2]),
3443 \+ is_passive(RuleNb,ID1),
3444 functor(C1,F,A),
3445 get_functional_dependency(F/A,RuleNb,Pattern,Key),
3446 copy_term_nat(Pattern-Key,C1-Key1),
3447 copy_term_nat(Pattern-Key,C2-Key2),
3448 Key1 == Key2 ->
3449 passive(RuleNb,ID2)
3450 ;
3451 true
3452 ).
3454 check_unique_constraints(C1,C2,G,RuleNb,List) :-
3455 \+ any_passive_head(RuleNb),
3456 variable_replacement(C1-C2,C2-C1,List),
3457 copy_with_variable_replacement(G,OtherG,List),
3458 negate_b(G,NotG),
3459 once(entails_b(NotG,OtherG)).
3461 % checks for rules of the shape ...,C1,C2... (<|=)==> ...
3462 % where C1 and C2 are symmteric constraints
3463 symmetry_analysis(Rules) :-
3464 ( chr_pp_flag(check_unnecessary_active,off) ->
3465 true
3466 ;
3467 symmetry_analysis_main(Rules)
3468 ).
3470 symmetry_analysis_main([]).
3471 symmetry_analysis_main([R|Rs]) :-
3472 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
3473 Rule = rule(H1,H2,_,_),
3474 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
3475 ; H2 == [] ), H1 \== [] ->
3476 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
3477 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
3478 ;
3479 true
3480 ),
3481 symmetry_analysis_main(Rs).
3483 symmetry_analysis_heads([],[],_,_,_,_).
3484 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
3485 ( \+ is_passive(RuleNb,ID),
3486 member2(PreHs,PreIDs,PreH-PreID),
3487 \+ is_passive(RuleNb,PreID),
3488 variable_replacement(PreH,H,List),
3489 copy_with_variable_replacement(Rule,Rule2,List),
3490 identical_rules(Rule,Rule2) ->
3491 passive(RuleNb,ID)
3492 ;
3493 true
3494 ),
3495 symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
3497 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3499 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3500 %% ____ _ _ _ __ _ _ _
3501 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
3502 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
3503 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
3504 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
3505 %% |_|
3507 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
3508 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
3509 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
3510 build_head(F,A,Id,HeadVars,ClauseHead),
3511 get_constraint_mode(F/A,Mode),
3512 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1),
3514 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict),
3516 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3517 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
3519 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
3520 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
3522 ( chr_pp_flag(debugable,on) ->
3523 Rule = rule(_,_,Guard,Body),
3524 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
3525 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
3526 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody)),
3527 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
3528 ;
3529 Cut = ActualCut
3530 ),
3531 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
3532 Clause = ( ClauseHead :-
3533 FirstMatching,
3534 RescheduledTest,
3535 Cut,
3536 SuspsDetachments,
3537 SuspDetachment,
3538 BodyCopy
3539 ),
3540 L = [Clause | T].
3542 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
3543 head_arg_matches_(Pairs,Modes,VarDict,[],GoalList,NVarDict),
3544 list2conj(GoalList,Goal).
3546 head_arg_matches_([],[],VarDict,_,[],VarDict).
3547 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundArgs,GoalList,NVarDict) :-
3548 ( var(Arg) ->
3549 ( lookup_eq(VarDict,Arg,OtherVar) ->
3550 ( Mode = (+) ->
3551 ( memberchk_eq(Arg,GroundArgs) ->
3552 GoalList = [Var = OtherVar | RestGoalList],
3553 NGroundArgs = GroundArgs
3554 ;
3555 GoalList = [Var == OtherVar | RestGoalList],
3556 NGroundArgs = [Arg|GroundArgs]
3557 )
3558 ;
3559 GoalList = [Var == OtherVar | RestGoalList],
3560 NGroundArgs = GroundArgs
3561 ),
3562 VarDict1 = VarDict
3563 ; VarDict1 = [Arg-Var | VarDict],
3564 GoalList = RestGoalList,
3565 ( Mode = (+) ->
3566 NGroundArgs = [Arg|GroundArgs]
3567 ;
3568 NGroundArgs = GroundArgs
3569 )
3570 ),
3571 Pairs = Rest,
3572 RestModes = Modes
3573 ; atomic(Arg) ->
3574 ( Mode = (+) ->
3575 GoalList = [ Var = Arg | RestGoalList]
3576 ;
3577 GoalList = [ Var == Arg | RestGoalList]
3578 ),
3579 VarDict = VarDict1,
3580 NGroundArgs = GroundArgs,
3581 Pairs = Rest,
3582 RestModes = Modes
3583 ; Arg =.. [_|Args],
3584 functor(Arg,Fct,N),
3585 functor(Term,Fct,N),
3586 Term =.. [_|Vars],
3587 ( Mode = (+) ->
3588 GoalList = [ Var = Term | RestGoalList ]
3589 ;
3590 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
3591 ),
3592 pairup(Args,Vars,NewPairs),
3593 append(NewPairs,Rest,Pairs),
3594 replicate(N,Mode,NewModes),
3595 append(NewModes,Modes,RestModes),
3596 VarDict1 = VarDict,
3597 NGroundArgs = GroundArgs
3598 ),
3599 head_arg_matches_(Pairs,RestModes,VarDict1,NGroundArgs,RestGoalList,NVarDict).
3601 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
3602 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
3604 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
3605 ( Heads = [_|_] ->
3606 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
3607 ;
3608 GoalList = [],
3609 Susps = [],
3610 VarDict = NVarDict
3611 ).
3613 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
3614 instantiate_pattern_goals(AttrDict).
3615 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,[Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
3616 functor(H,F,A),
3617 head_info(H,A,Vars,_,_,Pairs),
3618 get_store_type(F/A,StoreType),
3619 ( StoreType == default ->
3620 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
3621 get_max_constraint_index(N),
3622 ( N == 1 ->
3623 VarSusps = Attr
3624 ;
3625 get_constraint_index(F/A,Pos),
3626 make_attr(N,_Mask,SuspsList,Attr),
3627 nth(Pos,SuspsList,VarSusps)
3628 ),
3629 create_get_mutable(active,State,GetMutable),
3630 get_constraint_mode(F/A,Mode),
3631 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1),
3632 ExistentialLookup = (
3633 ViaGoal,
3634 'chr sbag_member'(Susp,VarSusps),
3635 Susp = Suspension,
3636 GetMutable
3637 )
3638 ;
3639 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,State,ExistentialLookup,Susp,Pairs,NPairs),
3640 get_constraint_mode(F/A,Mode),
3641 filter_mode(NPairs,Pairs,Mode,NMode),
3642 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1),
3643 NewAttrDict = AttrDict
3644 ),
3645 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
3646 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
3647 Goal =
3648 (
3649 ExistentialLookup,
3650 DiffSuspGoals,
3651 MatchingGoal
3652 ),
3653 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
3655 filter_mode([],_,_,[]).
3656 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
3657 ( Var == V ->
3658 Modes = [M|MT],
3659 filter_mode(Rest,R,Ms,MT)
3660 ;
3661 filter_mode([Arg-Var|Rest],R,Ms,Modes)
3662 ).
3664 instantiate_pattern_goals([]).
3665 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
3666 get_max_constraint_index(N),
3667 ( N == 1 ->
3668 Goal = true
3669 ;
3670 make_attr(N,Mask,_,Attr),
3671 or_list(Bits,Pattern), !,
3672 Goal = (Mask /\ Pattern =:= Pattern)
3673 ),
3674 instantiate_pattern_goals(Rest).
3677 check_unique_keys([],_).
3678 check_unique_keys([V|Vs],Dict) :-
3679 lookup_eq(Dict,V,_),
3680 check_unique_keys(Vs,Dict).
3682 % Generates tests to ensure the found constraint differs from previously found constraints
3683 % TODO: detect more cases where constraints need be different
3684 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
3685 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
3686 list2conj(DiffSuspGoalList,DiffSuspGoals).
3687 % ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
3688 % list2conj(DiffSuspGoalList,DiffSuspGoals)
3689 % ;
3690 % DiffSuspGoals = true
3691 % ).
3693 different_from_other_susps_(_,[],_,_,[]) :- !.
3694 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
3695 ( functor(Head,F,A), functor(PreHead,F,A),
3696 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
3697 \+ \+ PreHeadCopy = HeadCopy ->
3699 List = [Susp \== PreSusp | Tail]
3700 ;
3701 List = Tail
3702 ),
3703 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
3705 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
3706 functor(Head,F,A),
3707 get_constraint_index(F/A,Pos),
3708 common_variables(Head,PrevHeads,CommonVars),
3709 translate(CommonVars,VarDict,Vars),
3710 or_pattern(Pos,Bit),
3711 ( permutation(Vars,PermutedVars),
3712 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
3713 member(Bit,Positions), !,
3714 NewAttrDict = AttrDict,
3715 Goal = true
3716 ;
3717 Goal = (Goal1, PatternGoal),
3718 gen_get_mod_constraints(Vars,Goal1,Attr),
3719 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
3720 ).
3722 common_variables(T,Ts,Vs) :-
3723 term_variables(T,V1),
3724 term_variables(Ts,V2),
3725 intersect_eq(V1,V2,Vs).
3727 gen_get_mod_constraints(L,Goal,Susps) :-
3728 get_target_module(Mod),
3729 ( L == [] ->
3730 Goal =
3731 ( 'chr global_term_ref_1'(Global),
3732 get_attr(Global,Mod,TSusps),
3733 TSusps = Susps
3734 )
3735 ;
3736 ( L = [A] ->
3737 VIA = 'chr via_1'(A,V)
3738 ; ( L = [A,B] ->
3739 VIA = 'chr via_2'(A,B,V)
3740 ; VIA = 'chr via'(L,V)
3741 )
3742 ),
3743 Goal =
3744 ( VIA,
3745 get_attr(V,Mod,TSusps),
3746 TSusps = Susps
3747 )
3748 ).
3750 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
3751 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3752 list2conj(GuardCopyList,GuardCopy).
3754 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
3755 Rule = rule(_,_,Guard,Body),
3756 conj2list(Guard,GuardList),
3757 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
3758 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
3760 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
3761 term_variables(RestGuardList,GuardVars),
3762 term_variables(RestGuardListCopyCore,GuardCopyVars),
3763 ( chr_pp_flag(guard_locks,on),
3764 bagof(('chr lock'(Y)) - (chr_runtime:unlock(Y)),
3765 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
3766 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
3767 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
3768 ),
3769 LocksUnlocks) ->
3770 once(pairup(Locks,Unlocks,LocksUnlocks))
3771 ;
3772 Locks = [],
3773 Unlocks = []
3774 ),
3775 list2conj(Locks,LockPhase),
3776 list2conj(Unlocks,UnlockPhase),
3777 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
3778 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
3779 my_term_copy(Body,VarDict2,BodyCopy).
3782 split_off_simple_guard([],_,[],[]).
3783 split_off_simple_guard([G|Gs],VarDict,S,C) :-
3784 ( simple_guard(G,VarDict) ->
3785 S = [G|Ss],
3786 split_off_simple_guard(Gs,VarDict,Ss,C)
3787 ;
3788 S = [],
3789 C = [G|Gs]
3790 ).
3792 % simple guard: cheap and benign (does not bind variables)
3793 simple_guard(G,VarDict) :-
3794 binds_b(G,Vars),
3795 \+ (( member(V,Vars),
3796 lookup_eq(VarDict,V,_)
3797 )).
3799 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
3800 ( is_stored(FA) ->
3801 ( (Id == [0];
3802 (get_allocation_occurrence(FA,AO),
3803 get_max_occurrence(FA,MO),
3804 MO < AO )),
3805 \+ may_trigger(FA), chr_pp_flag(late_allocation,on) ->
3806 SuspDetachment = true
3807 ;
3808 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
3809 ( chr_pp_flag(late_allocation,on) ->
3810 SuspDetachment =
3811 ( var(Susp) ->
3812 true
3813 ; UnCondSuspDetachment
3814 )
3815 ;
3816 SuspDetachment = UnCondSuspDetachment
3817 )
3818 )
3819 ;
3820 SuspDetachment = true
3821 ).
3823 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
3824 ( is_stored(FA) ->
3825 ( may_trigger(FA) ->
3826 make_name('detach_',FA,Fct),
3827 Detach =.. [Fct,Vars,Susp]
3828 ;
3829 Detach = true
3830 ),
3831 ( chr_pp_flag(debugable,on) ->
3832 DebugEvent = 'chr debug_event'(remove(Susp))
3833 ;
3834 DebugEvent = true
3835 ),
3836 generate_delete_constraint_call(FA,Susp,DeleteCall),
3837 use_auxiliary_predicate(remove_constraint_internal),
3838 SuspDetachment =
3839 (
3840 DebugEvent,
3841 remove_constraint_internal(Susp, Vars, Delete),
3842 ( Delete == yes ->
3843 DeleteCall,
3844 Detach
3845 ;
3846 true
3847 )
3848 )
3849 ;
3850 SuspDetachment = true
3851 ).
3853 gen_uncond_susps_detachments([],[],true).
3854 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
3855 functor(Term,F,A),
3856 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
3857 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
3859 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3861 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3862 %% ____ _ _ _ _
3863 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
3864 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
3865 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
3866 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
3867 %% |_| |___/
3869 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
3870 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
3871 Rule = rule(_Heads,Heads2,Guard,Body),
3873 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
3874 get_constraint_mode(F/A,Mode),
3875 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1),
3877 build_head(F,A,Id,HeadVars,ClauseHead),
3879 append(RestHeads,Heads2,Heads),
3880 append(OtherIDs,Heads2IDs,IDs),
3881 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
3882 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict),
3883 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
3885 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
3886 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
3888 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
3889 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
3891 ( chr_pp_flag(debugable,on) ->
3892 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
3893 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
3894 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
3895 instrument_goal((!),DebugTry,DebugApply,Cut)
3896 ;
3897 Cut = (!)
3898 ),
3900 Clause = ( ClauseHead :-
3901 FirstMatching,
3902 RescheduledTest,
3903 Cut,
3904 SuspsDetachments,
3905 SuspDetachment,
3906 BodyCopy
3907 ),
3908 L = [Clause | T].
3910 split_by_ids([],[],_,[],[]).
3911 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
3912 ( memberchk_eq(I,I1s) ->
3913 S1s = [S | R1s],
3914 S2s = R2s
3915 ;
3916 S1s = R1s,
3917 S2s = [S | R2s]
3918 ),
3919 split_by_ids(Is,Ss,I1s,R1s,R2s).
3921 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3925 %% ____ _ _ _ ____
3926 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
3927 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
3928 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
3929 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
3930 %% |_| |___/
3932 %% Genereate prelude + worker predicate
3933 %% prelude calls worker
3934 %% worker iterates over one type of removed constraints
3935 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
3936 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
3937 Rule = rule(Heads1,_,Guard,Body),
3938 append(Heads1,RestHeads2,Heads),
3939 append(IDs1,RestIDs,IDs),
3940 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
3941 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
3942 extend_id(Id,Id1),
3943 ( memberchk_eq(NID,IDs2) ->
3944 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
3945 ;
3946 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
3947 ),
3948 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
3949 simpagation_head2_new_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
3951 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
3952 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
3953 Heads = [Head|RHeads],
3954 inc_id(Id,Id1),
3955 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
3956 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
3957 ( memberchk_eq(ID,IDs2) ->
3958 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
3959 ;
3960 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
3961 ).
3963 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3964 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
3965 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
3966 build_head(F,A,Id1,VarsSusp,ClauseHead),
3967 get_constraint_mode(F/A,Mode),
3968 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
3970 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
3972 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal),
3974 extend_id(Id1,DelegateId),
3975 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
3976 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
3977 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
3979 PreludeClause =
3980 ( ClauseHead :-
3981 FirstMatching,
3982 ModConstraintsGoal,
3983 !,
3984 ConstraintAllocationGoal,
3985 Delegate
3986 ),
3987 L = [PreludeClause|T].
3989 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
3990 Term =.. [_|Args],
3991 delegate_variables(Term,Terms,VarDict,Args,Vars).
3993 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
3994 term_variables(PrevTerms,PrevVars),
3995 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
3997 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
3998 term_variables(Term,V1),
3999 term_variables(Terms,V2),
4000 intersect_eq(V1,V2,V3),
4001 list_difference_eq(V3,PrevVars,V4),
4002 translate(V4,VarDict,Vars).
4005 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4006 simpagation_head2_new_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
4008 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
4009 Rule = rule(_,_,Guard,Body),
4010 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,PreSusps),
4012 gen_var(OtherSusp),
4013 gen_var(OtherSusps),
4015 functor(CurrentHead,OtherF,OtherA),
4016 gen_vars(OtherA,OtherVars),
4017 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
4018 get_constraint_mode(OtherF/OtherA,Mode),
4019 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
4021 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4022 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
4023 create_get_mutable(active,State,GetMutable),
4024 CurrentSuspTest = (
4025 OtherSusp = OtherSuspension,
4026 GetMutable,
4027 DiffSuspGoals,
4028 FirstMatching
4029 ),
4031 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4032 build_head(F,A,Id,ClauseVars,ClauseHead),
4034 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
4035 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
4036 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
4038 gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
4040 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4041 build_head(F,A,Id,RecursiveVars,RecursiveCall),
4042 RecursiveVars2 = [[]|PreVarsAndSusps],
4043 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
4045 guard_body_copies2(Rule,VarDict2,GuardCopyList,BodyCopy),
4046 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,CurrentSuspTest),RescheduledTest),
4047 ( BodyCopy \== true, is_observed(F/A,O) ->
4048 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4049 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
4050 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
4051 ; Attachment = true,
4052 ConditionalRecursiveCall = RecursiveCall,
4053 ConditionalRecursiveCall2 = RecursiveCall2
4054 ),
4056 ( chr_pp_flag(debugable,on) ->
4057 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4058 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
4059 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
4060 ;
4061 DebugTry = true,
4062 DebugApply = true
4063 ),
4065 ( member(unique(ID1,UniqueKeys), Pragmas),
4066 check_unique_keys(UniqueKeys,VarDict) ->
4067 Clause =
4068 ( ClauseHead :-
4069 ( CurrentSuspTest ->
4070 ( RescheduledTest,
4071 DebugTry ->
4072 DebugApply,
4073 Susps1Detachments,
4074 Attachment,
4075 BodyCopy,
4076 ConditionalRecursiveCall2
4077 ;
4078 RecursiveCall2
4079 )
4080 ;
4081 RecursiveCall
4082 )
4083 )
4084 ;
4085 Clause =
4086 ( ClauseHead :-
4087 ( CurrentSuspTest,
4088 RescheduledTest,
4089 DebugTry ->
4090 DebugApply,
4091 Susps1Detachments,
4092 Attachment,
4093 BodyCopy,
4094 ConditionalRecursiveCall
4095 ;
4096 RecursiveCall
4097 )
4098 )
4099 ),
4100 L = [Clause | T].
4102 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
4103 length(Args,N),
4104 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
4105 create_get_mutable(active,State,GetState),
4106 create_get_mutable(Generation,NewGeneration,GetGeneration),
4107 ConditionalCall =
4108 ( Susp = Suspension,
4109 GetState,
4110 GetGeneration ->
4111 'chr update_mutable'(inactive,State),
4112 Call
4113 ; true
4114 ).
4116 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4119 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4120 %% ____ _ _
4121 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
4122 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
4123 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
4124 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
4125 %% |_| |___/
4127 propagation_code(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4128 ( RestHeads == [] ->
4129 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
4130 ;
4131 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
4132 ).
4133 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4134 %% Single headed propagation
4135 %% everything in a single clause
4136 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
4137 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4138 build_head(F,A,Id,VarsSusp,ClauseHead),
4140 inc_id(Id,NextId),
4141 build_head(F,A,NextId,VarsSusp,NextHead),
4143 get_constraint_mode(F/A,Mode),
4144 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict),
4145 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4146 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,Allocation),
4148 % - recursive call -
4149 RecursiveCall = NextHead,
4150 ( BodyCopy \== true, is_observed(F/A,O) ->
4151 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
4152 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4153 ; Attachment = true,
4154 ConditionalRecursiveCall = RecursiveCall
4155 ),
4157 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
4158 ActualCut = true
4159 ;
4160 ActualCut = !
4161 ),
4163 ( chr_pp_flag(debugable,on) ->
4164 Rule = rule(_,_,Guard,Body),
4165 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4166 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
4167 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
4168 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4169 ;
4170 Cut = ActualCut
4171 ),
4173 ( may_trigger(F/A) ->
4174 NovelProduction = 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
4175 ExtendHistory = 'chr extend_history'(Susp,RuleNb)
4176 ;
4177 NovelProduction = true,
4178 ExtendHistory = true
4179 ),
4181 Clause = (
4182 ClauseHead :-
4183 HeadMatching,
4184 Allocation,
4185 NovelProduction,
4186 GuardCopy,
4187 Cut,
4188 ExtendHistory,
4189 Attachment,
4190 BodyCopy,
4191 ConditionalRecursiveCall
4192 ),
4193 ProgramList = [Clause | ProgramTail].
4195 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4196 %% multi headed propagation
4197 %% prelude + predicates to accumulate the necessary combinations of suspended
4198 %% constraints + predicate to execute the body
4199 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4200 RestHeads = [First|Rest],
4201 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
4202 extend_id(Id,ExtendedId),
4203 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
4205 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4206 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
4207 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
4208 build_head(F,A,Id,VarsSusp,PreludeHead),
4209 get_constraint_mode(F/A,Mode),
4210 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
4211 Rule = rule(_,_,Guard,Body),
4212 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
4214 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
4216 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,CondAllocation),
4218 extend_id(Id,NestedId),
4219 append([Susps|VarsSusp],ExtraVars,NestedVars),
4220 build_head(F,A,NestedId,NestedVars,NestedHead),
4221 NestedCall = NestedHead,
4223 Prelude = (
4224 PreludeHead :-
4225 FirstMatching,
4226 FirstSuspGoal,
4227 !,
4228 CondAllocation,
4229 NestedCall
4230 ),
4231 L = [Prelude|T].
4233 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4234 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4235 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
4236 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
4238 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
4239 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
4240 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
4241 inc_id(Id,IncId),
4242 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
4244 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
4245 Rule = rule(_,_,Guard,Body),
4246 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
4247 gen_var(OtherSusp),
4248 gen_var(OtherSusps),
4249 functor(CurrentHead,OtherF,OtherA),
4250 gen_vars(OtherA,OtherVars),
4251 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4252 create_get_mutable(active,State,GetMutable),
4253 CurrentSuspTest = (
4254 OtherSusp = Suspension,
4255 GetMutable
4256 ),
4257 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4258 build_head(F,A,Id,ClauseVars,ClauseHead),
4259 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4260 build_head(F,A,Id,RecursiveVars,RecursiveHead),
4261 RecursiveCall = RecursiveHead,
4262 CurrentHead =.. [_|OtherArgs],
4263 pairup(OtherArgs,OtherVars,OtherPairs),
4264 get_constraint_mode(OtherF/OtherA,Mode),
4265 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
4267 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
4268 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
4270 ( BodyCopy \== true, is_observed(F/A,O) ->
4271 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
4272 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall)
4273 ; Attach = true,
4274 ConditionalRecursiveCall = RecursiveCall
4275 ),
4277 ( is_least_occurrence(RuleNb) ->
4278 NovelProduction = true,
4279 ExtendHistory = true
4280 ;
4281 get_occurrence(F/A,O,_,ID),
4282 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
4283 Tuple =.. [t,RuleNb|HistorySusps],
4284 bagof('chr novel_production'(X,Y),( lists:member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
4285 list2conj(NovelProductionsList,NovelProductions),
4286 NovelProduction = ( TupleVar = Tuple, NovelProductions),
4287 ExtendHistory = 'chr extend_history'(Susp,TupleVar)
4288 ),
4291 ( chr_pp_flag(debugable,on) ->
4292 Rule = rule(_,_,Guard,Body),
4293 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4294 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
4295 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
4296 ;
4297 DebugTry = true,
4298 DebugApply = true
4299 ),
4301 Clause = (
4302 ClauseHead :-
4303 ( CurrentSuspTest,
4304 DiffSuspGoals,
4305 Matching,
4306 NovelProduction,
4307 GuardCopy,
4308 DebugTry ->
4309 DebugApply,
4310 ExtendHistory,
4311 Attach,
4312 BodyCopy,
4313 ConditionalRecursiveCall
4314 ; RecursiveCall
4315 )
4316 ),
4317 L = [Clause|T].
4319 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
4320 reverse(ReversedRestSusps,RestSusps),
4321 pairup([ID|RestIDs],[Susp|RestSusps],IDSusps),
4322 sort(IDSusps,SortedIDSusps),
4323 pairup(_,HistorySusps,SortedIDSusps).
4325 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
4326 !,
4327 functor(Head,F,A),
4328 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
4329 get_constraint_mode(F/A,Mode),
4330 head_arg_matches(Pairs,Mode,[],_,VarDict),
4331 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4332 append(VarsSusp,ExtraVars,HeadVars).
4333 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
4334 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
4335 functor(Head,F,A),
4336 gen_var(Susps),
4337 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
4338 get_constraint_mode(F/A,Mode),
4339 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
4340 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4341 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
4343 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
4344 !,
4345 functor(Head,F,A),
4346 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
4347 get_constraint_mode(F/A,Mode),
4348 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
4349 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4350 append(VarsSusp,ExtraVars,HeadVars).
4351 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
4352 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
4353 functor(Head,F,A),
4354 gen_var(Susps),
4355 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4356 get_constraint_mode(F/A,Mode),
4357 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4358 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4359 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
4361 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
4362 !,
4363 functor(Head,F,A),
4364 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
4365 get_constraint_mode(F/A,Mode),
4366 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
4367 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
4368 append(VarsSusp,ExtraVars,HeadVars).
4369 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
4370 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
4371 functor(Head,F,A),
4372 gen_var(NextSusps),
4373 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
4374 get_constraint_mode(F/A,Mode),
4375 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
4376 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
4377 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
4379 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4381 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4382 %% ____ _ _ _ _
4383 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
4384 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
4385 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
4386 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
4387 %%
4388 %% ____ _ _ _
4389 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
4390 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
4391 %% | _ < __/ |_| | | | __/\ V / (_| | |
4392 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
4393 %%
4394 %% ____ _ _
4395 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
4396 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
4397 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
4398 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
4399 %% |___/
4401 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4402 ( chr_pp_flag(reorder_heads,on) ->
4403 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
4404 ;
4405 NRestHeads = RestHeads,
4406 NRestIDs = RestIDs
4407 ).
4409 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
4410 term_variables(Head,Vars),
4411 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
4412 copy_term_nat(InitialData,InitialDataCopy),
4413 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
4414 InitialDataCopy = InitialData,
4415 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
4416 reverse(RNRestHeads,NRestHeads),
4417 reverse(RNRestIDs,NRestIDs).
4419 final_data(Entry) :-
4420 Entry = entry(_,_,_,_,[],_).
4422 expand_data(Entry,NEntry,Cost) :-
4423 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
4424 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
4425 term_variables([Head1|Vars],Vars1),
4426 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
4427 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
4429 % Assigns score to head based on known variables and heads to lookup
4430 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4431 functor(Head,F,A),
4432 get_store_type(F/A,StoreType),
4433 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
4435 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4436 term_variables(Head,HeadVars),
4437 term_variables(RestHeads,RestVars),
4438 order_score_vars(HeadVars,KnownVars,RestVars,Score).
4439 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
4440 order_score_indexes(Indexes,Head,KnownVars,0,Score).
4441 order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :-
4442 functor(Head,F,A),
4443 ( Vars == [] ->
4444 Score = 10 % guaranteed O(1)
4445 ; A == 0 -> % flag constraint
4446 Score = 1000 % O(1)? [CHECK: no deleted/triggered/... constraints in store?]
4447 ; A > 0 ->
4448 Score = 10000
4449 ).
4450 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
4451 Score = 1. % guaranteed O(1)
4453 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
4454 find_with_var_identity(
4455 S,
4456 t(Head,KnownVars,RestHeads),
4457 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
4458 Scores
4459 ),
4460 min_list(Scores,Score).
4463 order_score_indexes([],_,_,Score,NScore) :-
4464 Score > 0, NScore = 100.
4465 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
4466 multi_hash_key_args(I,Head,Args),
4467 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
4468 Score1 is Score + 1
4469 ;
4470 Score1 = Score
4471 ),
4472 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
4474 order_score_vars(Vars,KnownVars,RestVars,Score) :-
4475 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
4476 ( K-R-O == 0-0-0 ->
4477 Score = 0
4478 ; K > 0 ->
4479 Score is max(10 - K,0)
4480 ; R > 0 ->
4481 Score is max(10 - R,1) * 10
4482 ;
4483 Score is max(10-O,1) * 100
4484 ).
4485 order_score_count_vars([],_,_,0-0-0).
4486 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
4487 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
4488 ( memberchk_eq(V,KnownVars) ->
4489 NK is K + 1,
4490 NR = R, NO = O
4491 ; memberchk_eq(V,RestVars) ->
4492 NR is R + 1,
4493 NK = K, NO = O
4494 ;
4495 NO is O + 1,
4496 NK = K, NR = R
4497 ).
4499 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4500 %% ___ _ _ _
4501 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
4502 %% | || '_ \| | | '_ \| | '_ \ / _` |
4503 %% | || | | | | | | | | | | | | (_| |
4504 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
4505 %% |___/
4507 create_get_mutable(V,M,GM) :-
4508 GM = (M = mutable(V)).
4510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4512 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4513 %% _ _ _ _ _ _ _
4514 %% | | | | |_(_) (_) |_ _ _
4515 %% | | | | __| | | | __| | | |
4516 %% | |_| | |_| | | | |_| |_| |
4517 %% \___/ \__|_|_|_|\__|\__, |
4518 %% |___/
4520 gen_var(_).
4521 gen_vars(N,Xs) :-
4522 length(Xs,N).
4524 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
4525 vars_susp(A,Vars,Susp,VarsSusp),
4526 Head =.. [_|Args],
4527 pairup(Args,Vars,HeadPairs).
4529 inc_id([N|Ns],[O|Ns]) :-
4530 O is N + 1.
4531 dec_id([N|Ns],[M|Ns]) :-
4532 M is N - 1.
4534 extend_id(Id,[0|Id]).
4536 next_id([_,N|Ns],[O|Ns]) :-
4537 O is N + 1.
4539 build_head(F,A,Id,Args,Head) :-
4540 buildName(F,A,Id,Name),
4541 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
4542 ( may_trigger(F/A) ;
4543 get_allocation_occurrence(F/A,AO),
4544 get_max_occurrence(F/A,MO),
4545 MO >= AO ) ) ->
4546 Head =.. [Name|Args]
4547 ;
4548 init(Args,ArgsWOSusp), % XXX not entirely correct!
4549 Head =.. [Name|ArgsWOSusp]
4550 ).
4552 buildName(Fct,Aty,List,Result) :-
4553 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
4554 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
4555 MO >= AO ) ; List \= [0])) ) ) ->
4556 atom_concat(Fct, (/) ,FctSlash),
4557 atom_concat(FctSlash,Aty,FctSlashAty),
4558 buildName_(List,FctSlashAty,Result)
4559 ;
4560 Result = Fct
4561 ).
4563 buildName_([],Name,Name).
4564 buildName_([N|Ns],Name,Result) :-
4565 buildName_(Ns,Name,Name1),
4566 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
4567 atom_concat(NameDash,N,Result).
4569 vars_susp(A,Vars,Susp,VarsSusp) :-
4570 length(Vars,A),
4571 append(Vars,[Susp],VarsSusp).
4573 make_attr(N,Mask,SuspsList,Attr) :-
4574 length(SuspsList,N),
4575 Attr =.. [v,Mask|SuspsList].
4577 or_pattern(Pos,Pat) :-
4578 Pow is Pos - 1,
4579 Pat is 1 << Pow. % was 2 ** X
4581 and_pattern(Pos,Pat) :-
4582 X is Pos - 1,
4583 Y is 1 << X, % was 2 ** X
4584 Pat is (-1)*(Y + 1). % because fx (-) is redefined
4586 make_name(Prefix,F/A,Name) :-
4587 atom_concat_list([Prefix,F,(/),A],Name).
4589 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4590 % Storetype dependent lookup
4591 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
4592 functor(Head,F,A),
4593 get_store_type(F/A,StoreType),
4594 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
4596 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
4597 passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
4598 instantiate_pattern_goals(AttrDict),
4599 get_max_constraint_index(N),
4600 ( N == 1 ->
4601 AllSusps = Attr
4602 ;
4603 functor(Head,F,A),
4604 get_constraint_index(F/A,Pos),
4605 make_attr(N,_,SuspsList,Attr),
4606 nth(Pos,SuspsList,AllSusps)
4607 ).
4608 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
4609 once((
4610 member(Index,Indexes),
4611 multi_hash_key_args(Index,Head,KeyArgs),
4612 translate(KeyArgs,VarDict,KeyArgCopies)
4613 )),
4614 ( KeyArgCopies = [KeyCopy] ->
4615 true
4616 ;
4617 KeyCopy =.. [k|KeyArgCopies]
4618 ),
4619 functor(Head,F,A),
4620 multi_hash_via_lookup_name(F/A,Index,ViaName),
4621 Goal =.. [ViaName,KeyCopy,AllSusps],
4622 update_store_type(F/A,multi_hash([Index])).
4623 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
4624 functor(Head,F,A),
4625 global_ground_store_name(F/A,StoreName),
4626 Goal = nb_getval(StoreName,AllSusps),
4627 update_store_type(F/A,global_ground).
4628 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
4629 functor(Head,F,A),
4630 global_singleton_store_name(F/A,StoreName),
4631 Goal = (nb_getval(StoreName,Susp),Susp \== [],AllSusps = [Susp]),
4632 update_store_type(F/A,global_singleton).
4633 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
4634 once((
4635 member(ST,StoreTypes),
4636 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
4637 )).
4639 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :- !,
4640 functor(Head,F,A),
4641 global_singleton_store_name(F/A,StoreName),
4642 Goal = (
4643 nb_getval(StoreName,Susp),
4644 Susp \== [],
4645 Susp = SuspTerm
4646 ),
4647 update_store_type(F/A,global_singleton).
4648 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
4649 once((
4650 member(ST,StoreTypes),
4651 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs)
4652 )).
4653 existential_lookup(multi_hash(Indexes),Head,_PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
4654 once((
4655 member(Index,Indexes),
4656 multi_hash_key_args(Index,Head,KeyArgs),
4657 translate(KeyArgs,VarDict,KeyArgCopies)
4658 )),
4659 ( KeyArgCopies = [KeyCopy] ->
4660 true
4661 ;
4662 KeyCopy =.. [k|KeyArgCopies]
4663 ),
4664 functor(Head,F,A),
4665 multi_hash_via_lookup_name(F/A,Index,ViaName),
4666 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
4667 create_get_mutable(active,State,GetMutable),
4668 Goal = (
4669 LookupGoal,
4670 'chr sbag_member'(Susp,AllSusps),
4671 Susp = SuspTerm,
4672 GetMutable
4673 ),
4674 hash_index_filter(Pairs,Index,NPairs),
4675 update_store_type(F/A,multi_hash([Index])).
4676 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :-
4677 lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),
4678 create_get_mutable(active,State,GetMutable),
4679 Goal = (
4680 UGoal,
4681 'chr sbag_member'(Susp,Susps),
4682 Susp = SuspTerm,
4683 GetMutable
4684 ).
4686 hash_index_filter(Pairs,Index,NPairs) :-
4687 ( integer(Index) ->
4688 NIndex = [Index]
4689 ;
4690 NIndex = Index
4691 ),
4692 hash_index_filter(Pairs,NIndex,1,NPairs).
4694 hash_index_filter([],_,_,[]).
4695 hash_index_filter([P|Ps],Index,N,NPairs) :-
4696 ( Index = [I|Is] ->
4697 NN is N + 1,
4698 ( I > N ->
4699 NPairs = [P|NPs],
4700 hash_index_filter(Ps,[I|Is],NN,NPs)
4701 ; I == N ->
4702 NPairs = NPs,
4703 hash_index_filter(Ps,Is,NN,NPs)
4704 )
4705 ;
4706 NPairs = [P|Ps]
4707 ).
4709 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4710 assume_constraint_stores([]).
4711 assume_constraint_stores([C|Cs]) :-
4712 ( \+ may_trigger(C),
4713 is_stored(C),
4714 get_store_type(C,default) ->
4715 get_indexed_arguments(C,IndexedArgs),
4716 findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes),
4717 ( get_functional_dependency(C,1,Pattern,Key),
4718 all_distinct_var_args(Pattern), Key == [] ->
4719 assumed_store_type(C,global_singleton)
4720 ;
4721 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
4722 )
4723 ;
4724 true
4725 ),
4726 assume_constraint_stores(Cs).
4728 all_distinct_var_args(Term) :-
4729 Term =.. [_|Args],
4730 copy_term_nat(Args,NArgs),
4731 all_distinct_var_args_(NArgs).
4733 all_distinct_var_args_([]).
4734 all_distinct_var_args_([X|Xs]) :-
4735 var(X),
4736 X = t,
4737 all_distinct_var_args_(Xs).
4739 get_indexed_arguments(C,IndexedArgs) :-
4740 C = F/A,
4741 get_indexed_arguments(1,A,C,IndexedArgs).
4743 get_indexed_arguments(I,N,C,L) :-
4744 ( I > N ->
4745 L = []
4746 ; ( is_indexed_argument(C,I) ->
4747 L = [I|T]
4748 ;
4749 L = T
4750 ),
4751 J is I + 1,
4752 get_indexed_arguments(J,N,C,T)
4753 ).
4755 validate_store_type_assumptions([]).
4756 validate_store_type_assumptions([C|Cs]) :-
4757 validate_store_type_assumption(C),
4758 validate_store_type_assumptions(Cs).
4760 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4761 % new code generation
4762 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
4763 Rule = rule(_,_,Guard,Body),
4764 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
4765 Vars = [ [] | VarsAndSusps],
4766 build_head(F,A,Id,Vars,Head),
4767 ( Id = [0|_] ->
4768 next_id(Id,PrevId),
4769 PrevVarsAndSusps = AllButFirst
4770 ;
4771 dec_id(Id,PrevId),
4772 PrevVarsAndSusps = [FirstSusp|AllButFirst]
4773 ),
4774 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
4775 Clause = ( Head :- PredecessorCall),
4776 L = [Clause | T].
4778 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
4779 Rule = rule(_,_,Guard,Body),
4780 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
4781 gen_var(OtherSusps),
4782 functor(CurrentHead,OtherF,OtherA),
4783 gen_vars(OtherA,OtherVars),
4784 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
4785 get_constraint_mode(OtherF/OtherA,Mode),
4786 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
4788 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
4790 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
4791 create_get_mutable(active,State,GetMutable),
4792 CurrentSuspTest = (
4793 OtherSusp = OtherSuspension,
4794 GetMutable,
4795 DiffSuspGoals,
4796 FirstMatching
4797 ),
4798 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
4799 inc_id(Id,NestedId),
4800 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
4801 build_head(F,A,Id,ClauseVars,ClauseHead),
4802 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
4803 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
4804 build_head(F,A,NestedId,NestedVars,NestedHead),
4806 RecursiveVars = [OtherSusps|PreVarsAndSusps],
4807 build_head(F,A,Id,RecursiveVars,RecursiveHead),
4808 Clause = (
4809 ClauseHead :-
4810 ( CurrentSuspTest,
4811 NextSuspGoal
4812 ->
4813 NestedHead
4814 ; RecursiveHead
4815 )
4816 ),
4817 L = [Clause|T].
4818 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4821 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4822 % Observation Analysis
4823 %
4824 % CLASSIFICATION
4825 % Enabled
4826 %
4827 % Analysis based on Abstract Interpretation paper.
4828 %
4829 % TODO:
4830 % stronger analysis domain [research]
4832 constraints
4833 initial_call_pattern/1,
4834 call_pattern/1,
4835 final_answer_pattern/2,
4836 abstract_constraints/1,
4837 depends_on/2,
4838 depends_on_ap/4,
4839 depends_on_goal/2,
4840 ai_observed/2,
4841 ai_not_observed/2,
4842 ai_is_observed/2,
4843 depends_on_as/3.
4845 option(mode,initial_call_pattern(+)).
4846 option(mode,call_pattern(+)).
4847 option(mode,final_answer_pattern(+,+)).
4848 option(mode,abstract_constraints(+)).
4849 option(mode,depends_on(+,+)).
4850 option(mode,depends_on_as(+,+,+)).
4851 option(mode,depends_on_ap(+,+,+,+)).
4852 option(mode,depends_on_goal(+,+)).
4853 option(mode,ai_observed(+,+)).
4854 option(mode,ai_is_observed(+,+)).
4855 option(mode,ai_not_observed(+,+)).
4857 ai_observed(C,O) \ ai_not_observed(C,O) <=> true.
4858 ai_not_observed(C,O) \ ai_not_observed(C,O) <=> true.
4859 ai_observed(C,O) \ ai_observed(C,O) <=> true.
4861 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
4862 ai_is_observed(_,_) <=> true.
4864 ai_observation_analysis(ACs) :-
4865 ( chr_pp_flag(ai_observation_analysis,on) ->
4866 list_to_ord_set(ACs,ACSet),
4867 abstract_constraints(ACs),
4868 ai_observation_schedule_initial_calls(ACs)
4869 ;
4870 true
4871 ).
4873 ai_observation_schedule_initial_calls([]).
4874 ai_observation_schedule_initial_calls([AC|ACs]) :-
4875 ai_observation_schedule_initial_call(AC),
4876 ai_observation_schedule_initial_calls(ACs).
4878 ai_observation_schedule_initial_call(AC) :-
4879 ai_observation_top(AC,CallPattern),
4880 initial_call_pattern(CallPattern).
4882 ai_observation_schedule_new_calls([],AP).
4883 ai_observation_schedule_new_calls([AC|ACs],AP) :-
4884 AP = odom(_,Set),
4885 initial_call_pattern(odom(AC,Set)),
4886 ai_observation_schedule_new_calls(ACs,AP).
4888 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
4889 <=>
4890 ai_observation_leq(AP2,AP1)
4891 |
4892 true.
4894 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
4896 initial_call_pattern(CP) ==> call_pattern(CP).
4898 initial_call_pattern(CP), final_answer_pattern(CP,AP),
4899 abstract_constraints(ACs) ==>
4900 ai_observation_schedule_new_calls(ACs,AP).
4902 call_pattern(CP) \ call_pattern(CP) <=> true.
4904 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
4905 final_answer_pattern(CP1,AP).
4907 % AbstractGoala
4908 call_pattern(odom([],Set)) ==>
4909 final_answer_pattern(odom([],Set),odom([],Set)).
4911 % AbstractGoalb
4912 call_pattern(odom([G|Gs],Set)) ==>
4913 CP1 = odom(G,Set),
4914 depends_on_goal(odom([G|Gs],Set),CP1),
4915 call_pattern(CP1).
4917 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_)
4918 <=> true.
4919 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
4920 ==>
4921 CP1 = odom([_|Gs],_),
4922 AP2 = odom([],Set),
4923 CCP = odom(Gs,Set),
4924 call_pattern(CCP),
4925 depends_on(CP1,CCP).
4927 % AbstractSolve
4928 call_pattern(odom(builtin,Set)) ==>
4929 % writeln(' - AbstractSolve'),
4930 ord_empty(EmptySet),
4931 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
4933 % AbstractDrop
4934 call_pattern(odom(occ(C,O),Set)), max_occurrence(C,MO) ==>
4935 O > MO |
4936 % writeln(' - AbstractDrop'),
4937 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)).
4939 % AbstractActivate
4940 call_pattern(odom(AC,Set)), abstract_constraints(ACs)
4941 ==>
4942 memberchk_eq(AC,ACs)
4943 |
4944 % writeln(' - AbstractActivate'),
4945 CP = odom(occ(AC,1),Set),
4946 call_pattern(CP),
4947 depends_on(odom(AC,Set),CP).
4949 % AbstractSimplify
4950 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
4951 Rule = pragma(rule(H1,H2,G,Body),ids(IDs1,_),_,_,_),
4952 memberchk_eq(ID,IDs1) |
4953 % writeln(' - AbstractSimplify'),
4954 % SIMPLIFICATION
4955 select2(ID,_,IDs1,H1,_,RestH1),
4956 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
4957 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
4958 ai_observation_abstract_constraints(H2,ACs,AH2),
4959 ai_observation_observe_list(odom([],Set1),AH2,odom([],Set2)),
4960 ai_observation_abstract_goal(Body,ACs,AG),
4961 call_pattern(odom(AG,Set2)),
4962 % DEFAULT
4963 NO is O + 1,
4964 DCP = odom(occ(C,NO),Set),
4965 call_pattern(DCP),
4966 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP).
4968 depends_on_as(CP,CPS,CPD),
4969 final_answer_pattern(CPS,APS),
4970 final_answer_pattern(CPD,APD) ==>
4971 ai_observation_lub(APS,APD,AP),
4972 final_answer_pattern(CP,AP).
4974 % AbstractPropagate
4975 call_pattern(odom(occ(C,O),Set)), abstract_constraints(ACs), occurrence(C,O,RuleNb,ID), rule(RuleNb,Rule) ==>
4976 Rule = pragma(rule(H1,H2,G,Body),ids(_,IDs2),_,_,_),
4977 memberchk_eq(ID,IDs2)
4978 |
4979 % writeln(' - AbstractPropagate'),
4980 % observe partners
4981 select2(ID,_,IDs2,H2,_,RestH2),
4982 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
4983 ai_observation_observe_list(odom([],Set),ARestHeads,odom([],Set1)),
4984 ai_observation_abstract_constraints(H1,ACs,AH1),
4985 ai_observation_observe_list(odom([],Set1),AH1,odom([],Set2)),
4986 ord_add_element(Set2,C,Set3),
4987 ai_observation_abstract_goal(Body,ACs,AG),
4988 call_pattern(odom(AG,Set3)),
4989 ( ord_memberchk(C,Set2) ->
4990 Delete = no
4991 ;
4992 Delete = yes
4993 ),
4994 % DEFAULT
4995 NO is O + 1,
4996 DCP = odom(occ(C,NO),Set),
4997 call_pattern(DCP),
4998 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete).
5001 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
5002 true |
5003 final_answer_pattern(CP,APD).
5004 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
5005 final_answer_pattern(CPD,APD) ==>
5006 true |
5007 CP = odom(occ(C,O),_),
5008 ( ai_observation_is_observed(APP,C) ->
5009 ai_observed(C,O)
5010 ;
5011 ai_not_observed(C,O)
5012 ),
5013 ( Delete == yes ->
5014 APP = odom([],Set0),
5015 ord_del_element(Set0,C,Set),
5016 NAPP = odom([],Set)
5017 ;
5018 NAPP = APP
5019 ),
5020 ai_observation_lub(NAPP,APD,AP),
5021 final_answer_pattern(CP,AP).
5023 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
5024 ord_intersect(S1,S2,S3).
5026 ai_observation_top(AG,odom(AG,EmptyS)) :-
5027 ord_empty(EmptyS).
5029 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
5030 ord_subset(S2,S1).
5032 ai_observation_observe(odom(AG,S),AC,odom(AG,NS)) :-
5033 ord_del_element(S,AC,NS).
5035 ai_observation_observe_list(odom(AG,S),ACs,odom(AG,NS)) :-
5036 list_to_ord_set(ACs,ACSet),
5037 ord_subtract(S,ACSet,NS).
5039 ai_observation_abstract_constraint(C,ACs,AC) :-
5040 functor(C,F,A),
5041 AC = F / A,
5042 member(AC,ACs).
5044 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
5045 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
5047 ai_observation_abstract_goal(G,ACs,AG) :-
5048 ai_observation_abstract_goal(G,ACs,AG,[]).
5050 ai_observation_abstract_goal((G1,G2),ACs,List,Tail) :- !, % conjunction
5051 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5052 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5053 ai_observation_abstract_goal((G1;G2),ACs,List,Tail) :- !, % disjunction
5054 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5055 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5056 ai_observation_abstract_goal((G1->G2),ACs,List,Tail) :- !, % if-then
5057 ai_observation_abstract_goal(G1,ACs,List,IntermediateList),
5058 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail).
5059 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail) :-
5060 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
5061 ai_observation_abstract_goal(true,_,Tail,Tail) :- !.
5062 ai_observation_abstract_goal(writeln(_),_,Tail,Tail) :- !.
5063 ai_observation_abstract_goal(G,_,[AG|Tail],Tail) :-
5064 AG = builtin. % default case if goal is not recognized
5066 ai_observation_is_observed(odom(_,ACSet),AC) :-
5067 \+ ord_memberchk(AC,ACSet).
5069 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5070 unconditional_occurrence(C,O) :-
5071 get_occurrence(C,O,RuleNb,ID),
5072 get_rule(RuleNb,PRule),
5073 PRule = pragma(ORule,_,_,_,_),
5074 copy_term_nat(ORule,Rule),
5075 Rule = rule(H1,H2,Guard,_),
5076 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
5077 once((
5078 H1 = [Head], H2 == []
5079 ;
5080 H2 = [Head], H1 == [], \+ may_trigger(C)
5081 )),
5082 functor(Head,F,A),
5083 Head =.. [_|Args],
5084 unconditional_occurrence_args(Args).
5086 unconditional_occurrence_args([]).
5087 unconditional_occurrence_args([X|Xs]) :-
5088 var(X),
5089 X = x,
5090 unconditional_occurrence_args(Xs).
5092 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5093 % Generate rules that implement chr_show_store/1 functionality.
5094 %
5095 % CLASSIFICATION
5096 % Experimental
5097 % Unused
5098 %
5099 % Generates additional rules:
5100 %
5101 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
5102 % ...
5103 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
5104 % $show <=> true.
5106 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
5107 ( chr_pp_flag(show,on) ->
5108 Constraints = ['$show'/0|Constraints0],
5109 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
5110 inc_rule_count(RuleNb),
5111 Rule = pragma(
5112 rule(['$show'],[],true,true),
5113 ids([0],[]),
5114 [],
5115 no,
5116 RuleNb
5117 )
5118 ;
5119 Constraints = Constraints0,
5120 Rules = Rules0
5121 ).
5123 generate_show_rules([],Rules,Rules).
5124 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
5125 functor(C,F,A),
5126 inc_rule_count(RuleNb),
5127 Rule = pragma(
5128 rule([],['$show',C],true,writeln(C)),
5129 ids([],[0,1]),
5130 [passive(1)],
5131 no,
5132 RuleNb
5133 ),
5134 generate_show_rules(Rest,Tail,Rules).