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