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