| blob | 3d9cd849c0b44e390c3f57ec79decb0252e91cf9 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %%
51 %% URGENTLY TODO
52 %%
53 %% * add groundness info to a.i.-based observation analysis
54 %% * proper fd/index analysis
55 %% * re-add generation checking
56 %% * untangle CHR-level and traget source-level generation & optimization
57 %%
58 %% AGGRESSIVE OPTIMISATION IDEAS
59 %%
60 %% * success continuation optimization
61 %% * analyze history usage to determine whether/when
62 %% cheaper suspension is possible:
63 %% don't use history when all partners are passive and self never triggers
64 %% * store constraint unconditionally for unconditional propagation rule,
65 %% if first, i.e. without checking history and set trigger cont to next occ
66 %% * get rid of suspension passing for never triggered constraints,
67 %% up to allocation occurrence
68 %% * get rid of call indirection for never triggered constraints
69 %% up to first allocation occurrence.
70 %% * get rid of unnecessary indirection if last active occurrence
71 %% before unconditional removal is head2, e.g.
72 %% a \ b <=> true.
73 %% a <=> true.
74 %% * Eliminate last clause of never stored constraint, if its body
75 %% is fail.
76 %% * Specialize lookup operations and indexes for functional dependencies.
77 %%
78 %% MORE TODO
79 %%
80 %% * generate code to empty all constraint stores of a module (Bart Demoen)
81 %% * map A \ B <=> true | true rules
82 %% onto efficient code that empties the constraint stores of B
83 %% in O(1) time for ground constraints where A and B do not share
84 %% any variables
85 %% * ground matching seems to be not optimized for compound terms
86 %% in case of simpagation_head2 and propagation occurrences
87 %% * Do not unnecessarily generate store operations.
88 %% * analysis for storage delaying (see primes for case)
89 %% * internal constraints declaration + analyses?
90 %% * Do not store in global variable store if not necessary
91 %% NOTE: affects show_store/1
92 %% * multi-level store: variable - ground
93 %% * Do not maintain/check unnecessary propagation history
94 %% for reasons of anti-monotony
95 %% * Strengthen storage analysis for propagation rules
96 %% reason about bodies of rules only containing constraints
97 %% -> fixpoint with observation analysis
98 %% * instantiation declarations
99 %% VARIABLE (never bound) (-)
100 %% specialize via_1 and others to a compile time unification
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
103 %%
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * unqiue -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
112 %% ...
113 %% if( (
114 %% generator_n(Y),
115 %% test(X,Y)
116 %% ),
117 %% true,
118 %% ('_$cutto'(CP_1), fail)
119 %% ),
120 %% ...
121 %%
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
129 %%
130 %%
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %% merged
133 %%
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
137 ]).
138 %% SWI begin
139 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
140 :- use_module(library(ordsets)).
141 %% SWI end
143 :- use_module(hprolog).
144 :- use_module(pairlist).
145 :- use_module(a_star).
146 :- use_module(listmap).
147 :- use_module(clean_code).
148 :- use_module(builtins).
149 :- use_module(find).
150 :- use_module(guard_entailment).
151 :- use_module(chr_compiler_options).
152 :- use_module(chr_compiler_utility).
153 :- use_module(chr_compiler_errors).
154 :- include(chr_op).
155 :- op(1150, fx, chr_type).
156 :- op(1130, xfx, --->).
157 :- op(980, fx, (+)).
158 :- op(980, fx, (-)).
159 :- op(980, fx, (?)).
160 :- op(1150, fx, constraints).
161 :- op(1150, fx, chr_constraint).
163 :- chr_option(debug,off).
164 :- chr_option(optimize,full).
166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
167 :- chr_constraint
168 target_module/1, % target_module(Module)
169 get_target_module/1,
171 indexed_argument/2, % argument instantiation may enable applicability of rule
172 is_indexed_argument/2,
174 constraint_mode/2,
175 get_constraint_mode/2,
177 may_trigger/1,
178 only_ground_indexed_arguments/1,
179 none_suspended_on_variables/0,
180 are_none_suspended_on_variables/0,
182 store_type/2,
183 get_store_type/2,
184 update_store_type/2,
185 actual_store_types/2,
186 assumed_store_type/2,
187 validate_store_type_assumption/1,
189 rule_count/1,
190 inc_rule_count/1,
192 passive/2,
193 is_passive/2,
194 any_passive_head/1,
196 new_occurrence/4,
197 occurrence/5,
198 get_occurrence/4,
199 get_occurrence_from_id/4,
201 max_occurrence/2,
202 get_max_occurrence/2,
204 allocation_occurrence/2,
205 get_allocation_occurrence/2,
206 rule/2,
207 get_rule/2,
208 least_occurrence/2,
209 is_least_occurrence/1
210 .
212 :- chr_option(check_guard_bindings,off).
214 :- chr_option(mode,target_module(+)).
215 :- chr_option(mode,indexed_argument(+,+)).
216 :- chr_option(mode,constraint_mode(+,+)).
217 :- chr_option(mode,may_trigger(+)).
218 :- chr_option(mode,store_type(+,+)).
219 :- chr_option(mode,actual_store_types(+,+)).
220 :- chr_option(mode,assumed_store_type(+,+)).
221 :- chr_option(mode,rule_count(+)).
222 :- chr_option(mode,passive(+,+)).
223 :- chr_option(mode,occurrence(+,+,+,+,+)).
224 :- chr_option(mode,max_occurrence(+,+)).
225 :- chr_option(mode,allocation_occurrence(+,+)).
226 :- chr_option(mode,rule(+,+)).
227 :- chr_option(mode,least_occurrence(+,+)).
228 :- chr_option(mode,is_least_occurrence(+)).
230 :- chr_option(type_definition,type(list,[ [], [any|list] ])).
231 :- chr_option(type_definition,type(constraint,[ any / any ])).
233 :- chr_option(type_declaration,constraint_mode(constraint,list)).
235 target_module(_) \ target_module(_) <=> true.
236 target_module(Mod) \ get_target_module(Query)
237 <=> Query = Mod .
238 get_target_module(Query)
239 <=> Query = user.
241 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
242 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
243 is_indexed_argument(_,_) <=> fail.
245 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
247 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
248 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
249 Q = Mode.
250 get_constraint_mode(FA,Q) <=>
251 FA = _ / N,
252 replicate(N,(?),Q).
254 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
256 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
257 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
258 nth1(I,Mode,M),
259 M \== (+) |
260 is_stored(FA).
261 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
263 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
264 <=>
265 nth1(I,Mode,M),
266 M \== (+)
267 |
268 fail.
269 only_ground_indexed_arguments(_) <=>
270 true.
272 none_suspended_on_variables \ none_suspended_on_variables <=> true.
273 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
274 are_none_suspended_on_variables <=> fail.
275 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
277 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
278 store_type(FA,Store) \ get_store_type(FA,Query)
279 <=> Query = Store.
280 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
281 <=> Query = Store.
282 get_store_type(_,Query)
283 <=> Query = default.
285 actual_store_types(C,STs) \ update_store_type(C,ST)
286 <=> member(ST,STs) | true.
287 update_store_type(C,ST), actual_store_types(C,STs)
288 <=>
289 actual_store_types(C,[ST|STs]).
290 update_store_type(C,ST)
291 <=>
292 actual_store_types(C,[ST]).
294 % refine store type assumption
295 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
296 <=>
297 store_type(C,multi_store(STs)).
298 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
299 <=>
300 store_type(C,multi_store(STs)).
301 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
302 <=> store_type(C,global_ground).
303 validate_store_type_assumption(C)
304 <=> true.
306 rule_count(C), inc_rule_count(NC)
307 <=> NC is C + 1, rule_count(NC).
308 inc_rule_count(NC)
309 <=> NC = 1, rule_count(NC).
311 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
312 passive(R,ID) \ passive(R,ID) <=> true.
314 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
315 is_passive(_,_) <=> fail.
317 passive(RuleNb,_) \ any_passive_head(RuleNb)
318 <=> true.
319 any_passive_head(_)
320 <=> fail.
321 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
323 max_occurrence(C,N) \ max_occurrence(C,M)
324 <=> N >= M | true.
326 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
327 NO is MO + 1,
328 occurrence(C,NO,RuleNb,ID,Type),
329 max_occurrence(C,NO).
330 new_occurrence(C,RuleNb,ID,_) <=>
331 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
333 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
334 <=> Q = MON.
335 get_max_occurrence(C,Q)
336 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
338 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
339 <=> Rule = QRule, ID = QID.
340 get_occurrence(C,O,_,_)
341 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
343 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(C,QON,Rule,ID)
344 <=> QON = ON.
345 get_occurrence_from_id(C,O,_,_)
346 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
348 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
350 % cannot store constraint at passive occurrence
351 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ allocation_occurrence(C,O)
352 <=> NO is O + 1, allocation_occurrence(C,NO).
353 % need not store constraint that is removed
354 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_) \ allocation_occurrence(C,O)
355 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
356 | NO is O + 1, allocation_occurrence(C,NO).
357 % need not store constraint when body is true
358 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
359 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
360 | NO is O + 1, allocation_occurrence(C,NO).
361 % need not store constraint if does not observe itself
362 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
363 <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
364 | NO is O + 1, allocation_occurrence(C,NO).
365 % need not store constraint if does not observe itself and cannot trigger
366 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_), least_occurrence(RuleNb,[])
367 \ allocation_occurrence(C,O)
368 <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
369 | NO is O + 1, allocation_occurrence(C,NO).
371 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
372 \ least_occurrence(RuleNb,[ID|IDs])
373 <=> AO >= O, \+ may_trigger(C) |
374 least_occurrence(RuleNb,IDs).
375 rule(RuleNb,Rule), passive(RuleNb,ID)
376 \ least_occurrence(RuleNb,[ID|IDs])
377 <=> least_occurrence(RuleNb,IDs).
379 rule(RuleNb,Rule)
380 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
381 least_occurrence(RuleNb,IDs).
383 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
384 <=> true.
385 is_least_occurrence(_)
386 <=> fail.
388 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
389 <=> Q = O.
390 get_allocation_occurrence(_,Q)
391 <=> chr_pp_flag(late_allocation,off), Q=0.
392 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
394 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
395 <=> Q = Rule.
396 get_rule(_,_)
397 <=> fail.
399 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
401 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
402 :- chr_constraint
403 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
404 get_constraint_index/2,
405 get_indexed_constraint/2,
406 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
407 get_max_constraint_index/1.
409 :- chr_option(mode,constraint_index(+,+)).
410 :- chr_option(mode,max_constraint_index(+)).
412 constraint_index(C,Index) \ get_constraint_index(C,Query)
413 <=> Query = Index.
414 get_constraint_index(C,Query)
415 <=> fail.
417 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
418 <=> Q = C.
419 get_indexed_constraint(Index,Q)
420 <=> fail.
422 max_constraint_index(Index) \ get_max_constraint_index(Query)
423 <=> Query = Index.
424 get_max_constraint_index(Query)
425 <=> Query = 0.
427 set_constraint_indices(Constraints) :-
428 set_constraint_indices(Constraints,1).
429 set_constraint_indices([],M) :-
430 N is M - 1,
431 max_constraint_index(N).
432 set_constraint_indices([C|Cs],N) :-
433 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)) ->
434 constraint_index(C,N),
435 M is N + 1,
436 set_constraint_indices(Cs,M)
437 ;
438 set_constraint_indices(Cs,N)
439 ).
441 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
446 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
447 %%
448 %% Translation
450 chr_translate(Declarations,NewDeclarations) :-
451 chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]),
452 init_chr_pp_flags,
453 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
454 check_declared_constraints(Constraints0),
455 generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
456 add_constraints(Constraints),
457 add_rules(Rules),
458 % start analysis
459 check_rules(Rules,Constraints),
460 static_type_check,
461 add_occurrences(Rules),
462 time(fd_analysis,chr_translate:functional_dependency_analysis(Rules)),
463 time(set_semantics_rules,chr_translate:set_semantics_rules(Rules)),
464 time(symmetry_analysis,chr_translate:symmetry_analysis(Rules)),
465 time(guard_simplification,chr_translate:guard_simplification),
466 time(storage_analysis,chr_translate:storage_analysis(Constraints)),
467 time(observation_analysis,chr_translate:observation_analysis(Constraints)),
468 time(ai_observation_analysis,chr_translate:ai_observation_analysis(Constraints)),
469 time(late_allocation_analysis,chr_translate:late_allocation_analysis(Constraints)),
470 partial_wake_analysis,
471 time(assume_constraint_stores,chr_translate:assume_constraint_stores(Constraints)),
472 time(set_constraint_indices,chr_translate:set_constraint_indices(Constraints)),
473 % end analysis
474 time(constraints_code,chr_translate:constraints_code(Constraints,ConstraintClauses)),
475 time(validate_store_type_assumptions,chr_translate:validate_store_type_assumptions(Constraints)),
476 phase_end(validate_store_type_assumptions),
477 time(store_management_preds,chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
478 insert_declarations(OtherClauses, Clauses0),
479 chr_module_declaration(CHRModuleDeclaration),
480 append([Clauses0,
481 StoreClauses,
482 ConstraintClauses,
483 CHRModuleDeclaration,
484 [end_of_file]
485 ],
486 NewDeclarations).
488 store_management_preds(Constraints,Clauses) :-
489 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
490 generate_attach_increment(AttachIncrementClauses),
491 generate_attr_unify_hook(AttrUnifyHookClauses),
492 generate_extra_clauses(Constraints,ExtraClauses),
493 generate_insert_delete_constraints(Constraints,DeleteClauses),
494 generate_attach_code(Constraints,StoreClauses),
495 generate_counter_code(CounterClauses),
496 generate_dynamic_type_check_clauses(TypeCheckClauses),
497 append([AttachAConstraintClauses
498 ,IndexedClauses
499 ,AttachIncrementClauses
500 ,AttrUnifyHookClauses
501 ,ExtraClauses
502 ,DeleteClauses
503 ,StoreClauses
504 ,CounterClauses
505 ,TypeCheckClauses
506 ]
507 ,Clauses).
509 %% SWI begin
510 extra_declaration([ :- use_module(chr(chr_runtime))
511 , :- use_module(chr(chr_hashtable_store))
512 , :- use_module(chr(chr_integertable_store))
513 , :- use_module(library('clp/clp_events'))
514 ]).
515 %% SWI end
517 %% SICStus begin
518 %% extra_declaration([]).
519 %% SICStus end
522 insert_declarations(Clauses0, Clauses) :-
523 extra_declaration(Decls),
524 append(Clauses0, Decls, Clauses).
526 generate_counter_code(Clauses) :-
527 ( chr_pp_flag(store_counter,on) ->
528 Clauses = [
529 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
530 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
531 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
532 (:- '$counter_init'('$insert_counter')),
533 (:- '$counter_init'('$delete_counter')),
534 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
535 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
536 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
537 ]
538 ;
539 Clauses = []
540 ).
542 % for systems with multifile declaration
543 chr_module_declaration(CHRModuleDeclaration) :-
544 get_target_module(Mod),
545 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
546 CHRModuleDeclaration = [
547 (:- multifile chr:'$chr_module'/1),
548 chr:'$chr_module'(Mod)
549 ]
550 ;
551 CHRModuleDeclaration = []
552 ).
555 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
556 %%
557 %% Partitioning of clauses into constraint declarations, chr rules and other
558 %% clauses
560 partition_clauses([],[],[],[]).
561 partition_clauses([C|Cs],Ds,Rs,OCs) :-
562 ( parse_rule(C,R) ->
563 Ds = RDs,
564 Rs = [R | RRs],
565 OCs = ROCs
566 ; is_declaration(C,D) ->
567 append(D,RDs,Ds),
568 Rs = RRs,
569 OCs = ROCs
570 ; is_module_declaration(C,Mod) ->
571 target_module(Mod),
572 Ds = RDs,
573 Rs = RRs,
574 OCs = [C|ROCs]
575 ; is_type_definition(C) ->
576 Ds = RDs,
577 Rs = RRs,
578 OCs = ROCs
579 ; C = (handler _) ->
580 chr_warning(deprecated(C),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
581 Ds = RDs,
582 Rs = RRs,
583 OCs = ROCs
584 ; C = (rules _) ->
585 chr_warning(deprecated(C),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
586 Ds = RDs,
587 Rs = RRs,
588 OCs = ROCs
589 ; C = option(OptionName,OptionValue) ->
590 chr_warning(deprecated(C),'Instead use :- chr_option(~w,~w).\n',[OptionName,OptionValue]),
591 handle_option(OptionName,OptionValue),
592 Ds = RDs,
593 Rs = RRs,
594 OCs = ROCs
595 ; C = (:- chr_option(OptionName,OptionValue)) ->
596 handle_option(OptionName,OptionValue),
597 Ds = RDs,
598 Rs = RRs,
599 OCs = ROCs
600 ; C = ('$chr_compiled_with_version'(_)) ->
601 Ds = RDs,
602 Rs = RRs,
603 OCs = ['$chr_compiled_with_version'(3)|ROCs]
604 ; Ds = RDs,
605 Rs = RRs,
606 OCs = [C|ROCs]
607 ),
608 partition_clauses(Cs,RDs,RRs,ROCs).
610 '$chr_compiled_with_version'(2).
612 is_declaration(D, Constraints) :- %% constraint declaration
613 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
614 conj2list(Cs,Constraints0)
615 ;
616 ( D = (:- Decl) ->
617 Decl =.. [constraints,Cs]
618 ;
619 D =.. [constraints,Cs]
620 ),
621 conj2list(Cs,Constraints0),
622 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
623 ),
624 extract_type_mode(Constraints0,Constraints).
626 extract_type_mode([],[]).
627 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
628 extract_type_mode([C|R],[C2|R2]) :-
629 functor(C,F,A),C2=F/A,
630 C =.. [_|Args],
631 extract_types_and_modes(Args,ArgTypes,ArgModes),
632 constraint_type(F/A,ArgTypes),
633 constraint_mode(F/A,ArgModes),
634 extract_type_mode(R,R2).
636 extract_types_and_modes([],[],[]).
637 extract_types_and_modes([+(T)|R],[T|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
638 extract_types_and_modes([?(T)|R],[T|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
639 extract_types_and_modes([-(T)|R],[T|R2],[(-)|R3]) :- !,extract_types_and_modes(R,R2,R3).
640 extract_types_and_modes([(+)|R],[any|R2],[(+)|R3]) :- !,extract_types_and_modes(R,R2,R3).
641 extract_types_and_modes([(?)|R],[any|R2],[(?)|R3]) :- !,extract_types_and_modes(R,R2,R3).
642 extract_types_and_modes([(-)|R],[any|R2],[(-)|R3]) :- !,extract_types_and_modes(R,R2,R3).
643 extract_types_and_modes([Illegal|R],_,_) :-
644 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
646 is_type_definition(D) :-
647 ( D = (:- TDef) ->
648 true
649 ;
650 D = TDef
651 ),
652 TDef =.. [chr_type,TypeDef],
653 ( TypeDef = (Name ---> Def) ->
654 tdisj2list(Def,DefList),
655 type_definition(Name,DefList)
656 ; TypeDef = (Alias == Name) ->
657 type_alias(Alias,Name)
658 ;
659 chr_warning(syntax,'Illegal type definition "~w".\n\tIgnoring this malformed type definition.\n',[TypeDef])
660 ).
662 % no removal of fails, e.g. :- type bool ---> true ; fail.
663 tdisj2list(Conj,L) :-
664 tdisj2list(Conj,L,[]).
665 tdisj2list(Conj,L,T) :-
666 Conj = (G1;G2), !,
667 tdisj2list(G1,L,T1),
668 tdisj2list(G2,T1,T).
669 tdisj2list(G,[G | T],T).
672 %% Data Declaration
673 %%
674 %% pragma_rule
675 %% -> pragma(
676 %% rule,
677 %% ids,
678 %% list(pragma),
679 %% yesno(string), :: maybe rule nane
680 %% int :: rule number
681 %% )
682 %%
683 %% ids -> ids(
684 %% list(int),
685 %% list(int)
686 %% )
687 %%
688 %% rule -> rule(
689 %% list(constraint), :: constraints to be removed
690 %% list(constraint), :: surviving constraints
691 %% goal, :: guard
692 %% goal :: body
693 %% )
695 parse_rule(RI,R) :- %% name @ rule
696 RI = (Name @ RI2), !,
697 rule(RI2,yes(Name),R).
698 parse_rule(RI,R) :-
699 rule(RI,no,R).
701 rule(RI,Name,R) :-
702 RI = (RI2 pragma P), !, %% pragmas
703 ( var(P) ->
704 Ps = [_] % intercept variable
705 ;
706 conj2list(P,Ps)
707 ),
708 inc_rule_count(RuleCount),
709 R = pragma(R1,IDs,Ps,Name,RuleCount),
710 is_rule(RI2,R1,IDs,R).
711 rule(RI,Name,R) :-
712 inc_rule_count(RuleCount),
713 R = pragma(R1,IDs,[],Name,RuleCount),
714 is_rule(RI,R1,IDs,R).
716 is_rule(RI,R,IDs,RC) :- %% propagation rule
717 RI = (H ==> B), !,
718 conj2list(H,Head2i),
719 get_ids(Head2i,IDs2,Head2,RC),
720 IDs = ids([],IDs2),
721 ( B = (G | RB) ->
722 R = rule([],Head2,G,RB)
723 ;
724 R = rule([],Head2,true,B)
725 ).
726 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
727 RI = (H <=> B), !,
728 ( B = (G | RB) ->
729 Guard = G,
730 Body = RB
731 ; Guard = true,
732 Body = B
733 ),
734 ( H = (H1 \ H2) ->
735 conj2list(H1,Head2i),
736 conj2list(H2,Head1i),
737 get_ids(Head2i,IDs2,Head2,0,N,RC),
738 get_ids(Head1i,IDs1,Head1,N,_,RC),
739 IDs = ids(IDs1,IDs2)
740 ; conj2list(H,Head1i),
741 Head2 = [],
742 get_ids(Head1i,IDs1,Head1,RC),
743 IDs = ids(IDs1,[])
744 ),
745 R = rule(Head1,Head2,Guard,Body).
747 get_ids(Cs,IDs,NCs,RC) :-
748 get_ids(Cs,IDs,NCs,0,_,RC).
750 get_ids([],[],[],N,N,_).
751 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
752 ( C = (NC # N1) ->
753 (var(N1) ->
754 N1 = N
755 ;
756 check_direct_pragma(N1,N,RC)
757 )
758 ;
759 NC = C
760 ),
761 M is N + 1,
762 get_ids(Cs,IDs,NCs, M,NN,RC).
764 direct_pragma(passive).
765 check_direct_pragma(passive,N,R) :-
766 R = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), passive(RuleNb,N).
767 check_direct_pragma(Abbrev,N,RC) :-
768 (direct_pragma(X),
769 atom_concat(Abbrev,Remainder,X) ->
770 chr_warning(problem_pragma(Abbrev,RC),'completed "~w" to "~w"\n',[Abbrev,X])
771 ;
772 chr_warning(unsupported_pragma(Abbrev,RC),'',[])
773 ).
775 is_module_declaration((:- module(Mod)),Mod).
776 is_module_declaration((:- module(Mod,_)),Mod).
778 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
780 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
781 % Add constraints
782 add_constraints([]).
783 add_constraints([C|Cs]) :-
784 max_occurrence(C,0),
785 C = _/A,
786 length(Mode,A),
787 set_elems(Mode,?),
788 constraint_mode(C,Mode),
789 add_constraints(Cs).
791 % Add rules
792 add_rules([]).
793 add_rules([Rule|Rules]) :-
794 Rule = pragma(_,_,_,_,RuleNb),
795 rule(RuleNb,Rule),
796 add_rules(Rules).
798 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
800 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
801 %% Some input verification:
803 check_declared_constraints(Constraints) :-
804 check_declared_constraints(Constraints,[]).
806 check_declared_constraints([],_).
807 check_declared_constraints([C|Cs],Acc) :-
808 ( memberchk_eq(C,Acc) ->
809 chr_error(syntax(C),'Constraint ~w multiply defined.\n\tRemove redundant declaration!\n',[C])
810 ;
811 true
812 ),
813 check_declared_constraints(Cs,[C|Acc]).
815 %% - all constraints in heads are declared constraints
816 %% - all passive pragmas refer to actual head constraints
818 check_rules([],_).
819 check_rules([PragmaRule|Rest],Decls) :-
820 check_rule(PragmaRule,Decls),
821 check_rules(Rest,Decls).
823 check_rule(PragmaRule,Decls) :-
824 check_rule_indexing(PragmaRule),
825 check_trivial_propagation_rule(PragmaRule),
826 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
827 Rule = rule(H1,H2,_,_),
828 append(H1,H2,HeadConstraints),
829 check_head_constraints(HeadConstraints,Decls,PragmaRule),
830 check_pragmas(Pragmas,PragmaRule).
832 % Make all heads passive in trivial propagation rule
833 % ... ==> ... | true.
834 check_trivial_propagation_rule(PragmaRule) :-
835 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
836 ( Rule = rule([],_,_,true) ->
837 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
838 set_all_passive(RuleNb)
839 ;
840 true
841 ).
843 check_head_constraints([],_,_).
844 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
845 functor(Constr,F,A),
846 ( member(F/A,Decls) ->
847 check_head_constraints(Rest,Decls,PragmaRule)
848 ;
849 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ).
851 check_pragmas([],_).
852 check_pragmas([Pragma|Pragmas],PragmaRule) :-
853 check_pragma(Pragma,PragmaRule),
854 check_pragmas(Pragmas,PragmaRule).
856 check_pragma(Pragma,PragmaRule) :-
857 var(Pragma), !,
858 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
859 check_pragma(passive(ID), PragmaRule) :-
860 !,
861 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
862 ( memberchk_eq(ID,IDs1) ->
863 true
864 ; memberchk_eq(ID,IDs2) ->
865 true
866 ;
867 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
868 ),
869 passive(RuleNb,ID).
871 check_pragma(Pragma, PragmaRule) :-
872 Pragma = already_in_heads,
873 !,
874 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
876 check_pragma(Pragma, PragmaRule) :-
877 Pragma = already_in_head(_),
878 !,
879 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
881 check_pragma(Pragma, PragmaRule) :-
882 Pragma = no_history,
883 !,
884 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
885 PragmaRule = pragma(_,_,_,_,N),
886 no_history(N).
888 check_pragma(Pragma,PragmaRule) :-
889 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
891 :- chr_constraint
892 no_history/1,
893 has_no_history/1.
895 :- chr_option(mode,no_history(+)).
897 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
898 has_no_history(_) <=> fail.
900 format_rule(PragmaRule) :-
901 PragmaRule = pragma(_,_,_,MaybeName,N),
902 ( MaybeName = yes(Name) ->
903 write('rule '), write(Name)
904 ;
905 write('rule number '), write(N)
906 ).
908 check_rule_indexing(PragmaRule) :-
909 PragmaRule = pragma(Rule,_,_,_,_),
910 Rule = rule(H1,H2,G,_),
911 term_variables(H1-H2,HeadVars),
912 remove_anti_monotonic_guards(G,HeadVars,NG),
913 check_indexing(H1,NG-H2),
914 check_indexing(H2,NG-H1),
915 % EXPERIMENT
916 ( chr_pp_flag(term_indexing,on) ->
917 term_variables(NG,GuardVariables),
918 append(H1,H2,Heads),
919 check_specs_indexing(Heads,GuardVariables,Specs)
920 ;
921 true
922 ).
924 :- chr_constraint
925 indexing_spec/2,
926 get_indexing_spec/2.
928 :- chr_option(mode,indexing_spec(+,+)).
930 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
931 get_indexing_spec(_,Spec) <=> Spec = [].
933 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
934 <=>
935 append(Specs1,Specs2,Specs),
936 indexing_spec(FA,Specs).
938 remove_anti_monotonic_guards(G,Vars,NG) :-
939 conj2list(G,GL),
940 remove_anti_monotonic_guard_list(GL,Vars,NGL),
941 list2conj(NGL,NG).
943 remove_anti_monotonic_guard_list([],_,[]).
944 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
945 ( G = var(X), memberchk_eq(X,Vars) ->
946 NGs = RGs
947 % TODO: this is not correct
948 % ; G = functor(Term,Functor,Arity), % isotonic
949 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
950 % NGs = RGs
951 ;
952 NGs = [G|RGs]
953 ),
954 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
956 check_indexing([],_).
957 check_indexing([Head|Heads],Other) :-
958 functor(Head,F,A),
959 Head =.. [_|Args],
960 term_variables(Heads-Other,OtherVars),
961 check_indexing(Args,1,F/A,OtherVars),
962 check_indexing(Heads,[Head|Other]).
964 check_indexing([],_,_,_).
965 check_indexing([Arg|Args],I,FA,OtherVars) :-
966 ( is_indexed_argument(FA,I) ->
967 true
968 ; nonvar(Arg) ->
969 indexed_argument(FA,I)
970 ; % var(Arg) ->
971 term_variables(Args,ArgsVars),
972 append(ArgsVars,OtherVars,RestVars),
973 ( memberchk_eq(Arg,RestVars) ->
974 indexed_argument(FA,I)
975 ;
976 true
977 )
978 ),
979 J is I + 1,
980 term_variables(Arg,NVars),
981 append(NVars,OtherVars,NOtherVars),
982 check_indexing(Args,J,FA,NOtherVars).
984 check_specs_indexing([],_,[]).
985 check_specs_indexing([Head|Heads],Variables,Specs) :-
986 Specs = [Spec|RSpecs],
987 term_variables(Heads,OtherVariables,Variables),
988 check_spec_indexing(Head,OtherVariables,Spec),
989 term_variables(Head,NVariables,Variables),
990 check_specs_indexing(Heads,NVariables,RSpecs).
992 check_spec_indexing(Head,OtherVariables,Spec) :-
993 functor(Head,F,A),
994 Spec = spec(F,A,ArgSpecs),
995 Head =.. [_|Args],
996 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
997 indexing_spec(F/A,[ArgSpecs]).
999 check_args_spec_indexing([],_,_,[]).
1000 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1001 term_variables(Args,Variables,OtherVariables),
1002 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1003 ArgSpecs = [ArgSpec|RArgSpecs]
1004 ;
1005 ArgSpecs = RArgSpecs
1006 ),
1007 J is I + 1,
1008 term_variables(Arg,NOtherVariables,OtherVariables),
1009 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1011 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1012 ( var(Arg) ->
1013 memberchk_eq(Arg,Variables),
1014 ArgSpec = specinfo(I,any,[])
1015 ;
1016 functor(Arg,F,A),
1017 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1018 Arg =.. [_|Args],
1019 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1020 ).
1022 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1024 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1025 % Occurrences
1027 add_occurrences([]).
1028 add_occurrences([Rule|Rules]) :-
1029 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1030 add_occurrences(H1,IDs1,simplification,Nb),
1031 add_occurrences(H2,IDs2,propagation,Nb),
1032 add_occurrences(Rules).
1034 add_occurrences([],[],_,_).
1035 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1036 functor(H,F,A),
1037 FA = F/A,
1038 new_occurrence(FA,RuleNb,ID,Type),
1039 add_occurrences(Hs,IDs,Type,RuleNb).
1041 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1043 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1044 % Observation Analysis
1045 %
1046 % CLASSIFICATION
1047 % Legacy
1048 %
1049 % - approximative: should make decision in late allocation analysis per body
1050 % TODO:
1051 % remove
1053 is_observed(C,O) :-
1054 is_self_observer(C),
1055 ai_is_observed(C,O).
1057 :- chr_constraint
1058 observes/2,
1059 spawns_observer/2,
1060 observes_indirectly/2,
1061 is_self_observer/1
1062 .
1064 :- chr_option(mode,observes(+,+)).
1065 :- chr_option(mode,spawns_observer(+,+)).
1066 :- chr_option(mode,observes_indirectly(+,+)).
1068 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
1069 observes(C1,C2) \ observes(C1,C2) <=> true.
1071 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
1073 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
1074 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
1076 observes_indirectly(C,C) \ is_self_observer(C) <=> true.
1077 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off).
1078 % true if analysis has not been run,
1079 % false if analysis has been run
1081 observation_analysis(Cs) :-
1082 ( chr_pp_flag(observation_analysis,on) ->
1083 observation_analysis(Cs,Cs)
1084 ;
1085 true
1086 ).
1088 observation_analysis([],_).
1089 observation_analysis([C|Cs],Constraints) :-
1090 get_max_occurrence(C,MO),
1091 observation_analysis_occurrences(C,1,MO,Constraints),
1092 observation_analysis(Cs,Constraints).
1094 observation_analysis_occurrences(C,O,MO,Cs) :-
1095 ( O > MO ->
1096 true
1097 ;
1098 observation_analysis_occurrence(C,O,Cs),
1099 NO is O + 1,
1100 observation_analysis_occurrences(C,NO,MO,Cs)
1101 ).
1103 observation_analysis_occurrence(C,O,Cs) :-
1104 get_occurrence(C,O,RuleNb,ID),
1105 ( is_passive(RuleNb,ID) ->
1106 true
1107 ;
1108 get_rule(RuleNb,PragmaRule),
1109 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),
1110 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
1111 append(RHeads1,Heads2,OtherHeads)
1112 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
1113 append(RHeads2,Heads1,OtherHeads)
1114 ),
1115 observe_heads(C,OtherHeads),
1116 observe_body(C,Body,Cs)
1117 ).
1119 observe_heads(C,Heads) :-
1120 findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
1121 observe_all(C,Cs).
1123 observe_all(C,Cs) :-
1124 ( Cs = [C1|Cr] ->
1125 observes(C,C1),
1126 observe_all(C,Cr)
1127 ;
1128 true
1129 ).
1131 spawn_all(C,Cs) :-
1132 ( Cs = [C1|Cr] ->
1133 spawns_observer(C,C1),
1134 spawn_all(C,Cr)
1135 ;
1136 true
1137 ).
1138 spawn_all_triggers(C,Cs) :-
1139 ( Cs = [C1|Cr] ->
1140 ( may_trigger(C1) ->
1141 spawns_observer(C,C1)
1142 ;
1143 true
1144 ),
1145 spawn_all_triggers(C,Cr)
1146 ;
1147 true
1148 ).
1150 observe_body(C,Body,Cs) :-
1151 ( var(Body) ->
1152 spawn_all(C,Cs)
1153 ; Body = true ->
1154 true
1155 ; Body = fail ->
1156 true
1157 ; Body = (B1,B2) ->
1158 observe_body(C,B1,Cs),
1159 observe_body(C,B2,Cs)
1160 ; Body = (B1;B2) ->
1161 observe_body(C,B1,Cs),
1162 observe_body(C,B2,Cs)
1163 ; Body = (B1->B2) ->
1164 observe_body(C,B1,Cs),
1165 observe_body(C,B2,Cs)
1166 ; functor(Body,F,A), member(F/A,Cs) ->
1167 spawns_observer(C,F/A)
1168 ; Body = (_ = _) ->
1169 spawn_all_triggers(C,Cs)
1170 ; Body = (_ is _) ->
1171 spawn_all_triggers(C,Cs)
1172 ; builtin_binds_b(Body,Vars) ->
1173 ( Vars == [] ->
1174 true
1175 ;
1176 spawn_all_triggers(C,Cs)
1177 )
1178 ;
1179 spawn_all(C,Cs)
1180 ).
1182 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1184 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1185 % Late allocation
1187 late_allocation_analysis(Cs) :-
1188 ( chr_pp_flag(late_allocation,on) ->
1189 late_allocation(Cs)
1190 ;
1191 true
1192 ).
1194 late_allocation([]).
1195 late_allocation([C|Cs]) :-
1196 allocation_occurrence(C,1),
1197 late_allocation(Cs).
1198 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1200 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1201 %%
1202 %% Generated predicates
1203 %% attach_$CONSTRAINT
1204 %% attach_increment
1205 %% detach_$CONSTRAINT
1206 %% attr_unify_hook
1208 %% attach_$CONSTRAINT
1209 generate_attach_detach_a_constraint_all([],[]).
1210 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1211 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint)) ->
1212 generate_attach_a_constraint(Constraint,Clauses1),
1213 generate_detach_a_constraint(Constraint,Clauses2)
1214 ;
1215 Clauses1 = [],
1216 Clauses2 = []
1217 ),
1218 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1219 append([Clauses1,Clauses2,Clauses3],Clauses).
1221 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1222 generate_attach_a_constraint_empty_list(Constraint,Clause1),
1223 get_max_constraint_index(N),
1224 ( N == 1 ->
1225 generate_attach_a_constraint_1_1(Constraint,Clause2)
1226 ;
1227 generate_attach_a_constraint_t_p(Constraint,Clause2)
1228 ).
1230 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
1231 make_name('attach_',FA,Fct),
1232 Head =.. [Fct | Args],
1233 Clause = ( Head :- Body).
1235 generate_attach_a_constraint_empty_list(FA,Clause) :-
1236 generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
1238 generate_attach_a_constraint_1_1(FA,Clause) :-
1239 Args = [[Var|Vars],Susp],
1240 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1241 generate_attach_body_1(FA,Var,Susp,AttachBody),
1242 make_name('attach_',FA,Fct),
1243 RecursiveCall =.. [Fct,Vars,Susp],
1244 % SWI-Prolog specific code
1245 chr_pp_flag(solver_events,NMod),
1246 ( NMod \== none ->
1247 Args = [[Var|_],Susp],
1248 get_target_module(Mod),
1249 use_auxiliary_predicate(run_suspensions),
1250 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1251 ;
1252 Subscribe = true
1253 ),
1254 Body =
1255 (
1256 AttachBody,
1257 Subscribe,
1258 RecursiveCall
1259 ).
1261 generate_attach_body_1(FA,Var,Susp,Body) :-
1262 get_target_module(Mod),
1263 Body =
1264 ( get_attr(Var, Mod, Susps) ->
1265 NewSusps=[Susp|Susps],
1266 put_attr(Var, Mod, NewSusps)
1267 ;
1268 put_attr(Var, Mod, [Susp])
1269 ).
1271 generate_attach_a_constraint_t_p(FA,Clause) :-
1272 Args = [[Var|Vars],Susp],
1273 generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
1274 make_name('attach_',FA,Fct),
1275 RecursiveCall =.. [Fct,Vars,Susp],
1276 generate_attach_body_n(FA,Var,Susp,AttachBody),
1277 % SWI-Prolog specific code
1278 chr_pp_flag(solver_events,NMod),
1279 ( NMod \== none ->
1280 Args = [[Var|_],Susp],
1281 get_target_module(Mod),
1282 use_auxiliary_predicate(run_suspensions),
1283 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1284 ;
1285 Subscribe = true
1286 ),
1287 Body =
1288 (
1289 AttachBody,
1290 Subscribe,
1291 RecursiveCall
1292 ).
1294 generate_attach_body_n(F/A,Var,Susp,Body) :-
1295 get_constraint_index(F/A,Position),
1296 or_pattern(Position,Pattern),
1297 get_max_constraint_index(Total),
1298 make_attr(Total,Mask,SuspsList,Attr),
1299 nth1(Position,SuspsList,Susps),
1300 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1301 make_attr(Total,Mask,SuspsList1,NewAttr1),
1302 substitute(Susps,SuspsList,[Susp],SuspsList2),
1303 make_attr(Total,NewMask,SuspsList2,NewAttr2),
1304 copy_term(SuspsList,SuspsList3),
1305 nth1(Position,SuspsList3,[Susp]),
1306 chr_delete(SuspsList3,[Susp],RestSuspsList),
1307 set_elems(RestSuspsList,[]),
1308 make_attr(Total,Pattern,SuspsList3,NewAttr3),
1309 get_target_module(Mod),
1310 Body =
1311 ( get_attr(Var,Mod,TAttr) ->
1312 TAttr = Attr,
1313 ( Mask /\ Pattern =:= Pattern ->
1314 put_attr(Var, Mod, NewAttr1)
1315 ;
1316 NewMask is Mask \/ Pattern,
1317 put_attr(Var, Mod, NewAttr2)
1318 )
1319 ;
1320 put_attr(Var,Mod,NewAttr3)
1321 ).
1323 %% detach_$CONSTRAINT
1324 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1325 generate_detach_a_constraint_empty_list(Constraint,Clause1),
1326 get_max_constraint_index(N),
1327 ( N == 1 ->
1328 generate_detach_a_constraint_1_1(Constraint,Clause2)
1329 ;
1330 generate_detach_a_constraint_t_p(Constraint,Clause2)
1331 ).
1333 generate_detach_a_constraint_empty_list(FA,Clause) :-
1334 make_name('detach_',FA,Fct),
1335 Args = [[],_],
1336 Head =.. [Fct | Args],
1337 Clause = ( Head :- true).
1339 generate_detach_a_constraint_1_1(FA,Clause) :-
1340 make_name('detach_',FA,Fct),
1341 Args = [[Var|Vars],Susp],
1342 Head =.. [Fct | Args],
1343 RecursiveCall =.. [Fct,Vars,Susp],
1344 generate_detach_body_1(FA,Var,Susp,DetachBody),
1345 Body =
1346 (
1347 DetachBody,
1348 RecursiveCall
1349 ),
1350 Clause = (Head :- Body).
1352 generate_detach_body_1(FA,Var,Susp,Body) :-
1353 get_target_module(Mod),
1354 Body =
1355 ( get_attr(Var,Mod,Susps) ->
1356 'chr sbag_del_element'(Susps,Susp,NewSusps),
1357 ( NewSusps == [] ->
1358 del_attr(Var,Mod)
1359 ;
1360 put_attr(Var,Mod,NewSusps)
1361 )
1362 ;
1363 true
1364 ).
1366 generate_detach_a_constraint_t_p(FA,Clause) :-
1367 make_name('detach_',FA,Fct),
1368 Args = [[Var|Vars],Susp],
1369 Head =.. [Fct | Args],
1370 RecursiveCall =.. [Fct,Vars,Susp],
1371 generate_detach_body_n(FA,Var,Susp,DetachBody),
1372 Body =
1373 (
1374 DetachBody,
1375 RecursiveCall
1376 ),
1377 Clause = (Head :- Body).
1379 generate_detach_body_n(F/A,Var,Susp,Body) :-
1380 get_constraint_index(F/A,Position),
1381 or_pattern(Position,Pattern),
1382 and_pattern(Position,DelPattern),
1383 get_max_constraint_index(Total),
1384 make_attr(Total,Mask,SuspsList,Attr),
1385 nth1(Position,SuspsList,Susps),
1386 substitute(Susps,SuspsList,[],SuspsList1),
1387 make_attr(Total,NewMask,SuspsList1,Attr1),
1388 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1389 make_attr(Total,Mask,SuspsList2,Attr2),
1390 get_target_module(Mod),
1391 Body =
1392 ( get_attr(Var,Mod,TAttr) ->
1393 TAttr = Attr,
1394 ( Mask /\ Pattern =:= Pattern ->
1395 'chr sbag_del_element'(Susps,Susp,NewSusps),
1396 ( NewSusps == [] ->
1397 NewMask is Mask /\ DelPattern,
1398 ( NewMask == 0 ->
1399 del_attr(Var,Mod)
1400 ;
1401 put_attr(Var,Mod,Attr1)
1402 )
1403 ;
1404 put_attr(Var,Mod,Attr2)
1405 )
1406 ;
1407 true
1408 )
1409 ;
1410 true
1411 ).
1413 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1414 :- chr_constraint generate_indexed_variables_body/4.
1415 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1416 %-------------------------------------------------------------------------------
1417 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1418 get_indexing_spec(F/A,Specs),
1419 ( chr_pp_flag(term_indexing,on) ->
1420 spectermvars(Specs,Args,F,A,Body,Vars)
1421 ;
1422 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1423 ( MaybeBody == empty ->
1424 Body = true,
1425 Vars = []
1426 ; N == 0 ->
1427 Body = term_variables(Args,Vars)
1428 ;
1429 MaybeBody = Body
1430 )
1431 ).
1432 generate_indexed_variables_body(FA,_,_,_) <=>
1433 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1434 %===============================================================================
1436 create_indexed_variables_body([],[],_,_,_,empty,0).
1437 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1438 J is I + 1,
1439 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1440 ( Mode == (?),
1441 is_indexed_argument(FA,I) ->
1442 ( RBody == empty ->
1443 Body = term_variables(V,Vars)
1444 ;
1445 Body = (term_variables(V,Vars,Tail),RBody)
1446 ),
1447 N = M
1448 ; Mode == (-), is_indexed_argument(FA,I) ->
1449 ( RBody == empty ->
1450 Body = (Vars = [V])
1451 ;
1452 Body = (Vars = [V|Tail],RBody)
1453 ),
1454 N = M
1455 ;
1456 Vars = Tail,
1457 Body = RBody,
1458 N is M + 1
1459 ).
1460 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1461 % EXPERIMENTAL
1462 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1463 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1465 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1466 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1467 Goal = (ArgGoal,RGoal),
1468 argspecs(Specs,I,TempArgSpecs,RSpecs),
1469 merge_argspecs(TempArgSpecs,ArgSpecs),
1470 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1471 J is I + 1,
1472 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1474 argspecs([],_,[],[]).
1475 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1476 argspecs(Rest,I,ArgSpecs,RestSpecs).
1477 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1478 ( I == J ->
1479 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1480 ( Specs = [] ->
1481 RRestSpecs = RestSpecs
1482 ;
1483 RestSpecs = [Specs|RRestSpecs]
1484 )
1485 ;
1486 ArgSpecs = RArgSpecs,
1487 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1488 ),
1489 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1491 merge_argspecs(In,Out) :-
1492 sort(In,Sorted),
1493 merge_argspecs_(Sorted,Out).
1495 merge_argspecs_([],[]).
1496 merge_argspecs_([X],R) :- !, R = [X].
1497 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1498 ( (F1 == any ; F2 == any) ->
1499 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1500 ; F1 == F2 ->
1501 append(A1,A2,A),
1502 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1503 ;
1504 R = [specinfo(I,F1,A1)|RR],
1505 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1506 ).
1508 arggoal(List,Arg,Goal,L,T) :-
1509 ( List == [] ->
1510 L = T,
1511 Goal = true
1512 ; List = [specinfo(_,any,_)] ->
1513 Goal = term_variables(Arg,L,T)
1514 ;
1515 Goal =
1516 ( var(Arg) ->
1517 L = [Arg|T]
1518 ;
1519 Cases
1520 ),
1521 arggoal_cases(List,Arg,L,T,Cases)
1522 ).
1524 arggoal_cases([],_,L,T,L=T).
1525 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1526 ( ArgSpecs == [] ->
1527 Cases = RCases
1528 ; ArgSpecs == [[]] ->
1529 Cases = RCases
1530 ; FA = F/A ->
1531 Cases = (Case ; RCases),
1532 functor(Term,F,A),
1533 Term =.. [_|Args],
1534 Case = (Arg = Term -> ArgsGoal),
1535 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1536 ),
1537 arggoal_cases(Rest,Arg,L,T,RCases).
1538 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1540 generate_extra_clauses(Constraints,List) :-
1541 generate_activate_clauses(Constraints,List,Tail0),
1542 generate_remove_clauses(Constraints,Tail0,Tail1),
1543 generate_allocate_clauses(Constraints,Tail1,Tail2),
1544 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
1545 generate_novel_production(Tail3,Tail4),
1546 generate_extend_history(Tail4,Tail5),
1547 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
1548 Tail6 = [].
1550 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1551 % remove_constraint_internal/[1/3]
1553 generate_remove_clauses([],List,List).
1554 generate_remove_clauses([C|Cs],List,Tail) :-
1555 generate_remove_clause(C,List,List1),
1556 generate_remove_clauses(Cs,List1,Tail).
1558 remove_constraint_goal(Constraint,Susp,Agenda,Delete,Goal) :-
1559 remove_constraint_name(Constraint,Name),
1560 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1561 Goal =.. [Name, Susp,Delete]
1562 ;
1563 Goal =.. [Name,Susp,Agenda,Delete]
1564 ).
1566 remove_constraint_name(Constraint,Name) :-
1567 make_name('$remove_constraint_internal_',Constraint,Name).
1569 generate_remove_clause(Constraint,List,Tail) :-
1570 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
1571 List = [RemoveClause|Tail],
1572 % use_auxiliary_predicate(chr_indexed_variables,Constraint),
1573 remove_constraint_goal(Constraint,Susp,Agenda,Delete,Head),
1574 % get_dynamic_suspension_term_field(state,Constraint,Susp,Mref,StateGoal),
1575 static_suspension_term(Constraint,Susp),
1576 get_static_suspension_term_field(state,Constraint,Susp,Mref),
1577 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1578 RemoveClause =
1579 (
1580 Head :-
1581 % StateGoal,
1582 'chr get_mutable'( State, Mref),
1583 'chr update_mutable'( removed, Mref),
1584 ( State == not_stored_yet ->
1585 Delete = no
1586 ;
1587 Delete = yes
1588 )
1589 )
1590 ;
1591 get_static_suspension_term_field(arguments,Constraint,Susp,Args),
1592 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
1593 ( chr_pp_flag(debugable,on) ->
1594 Constraint = Functor / _,
1595 get_static_suspension_term_field(functor,Constraint,Susp,Functor)
1596 ;
1597 true
1598 ),
1599 RemoveClause =
1600 (
1601 Head :-
1602 % StateGoal,
1603 'chr get_mutable'( State, Mref),
1604 'chr update_mutable'( removed, Mref), % mark in any case
1605 ( State == not_stored_yet -> % compound(State) -> % passive/1
1606 Agenda = [],
1607 Delete = no
1608 % ; State==removed ->
1609 % Agenda = [],
1610 % Delete = no
1611 ;
1612 Delete = yes,
1613 IndexedVariablesBody % chr_indexed_variables(Susp,Agenda)
1614 )
1615 )
1616 )
1617 ;
1618 List = Tail
1619 ).
1621 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1622 % activate_constraint/4
1624 generate_activate_clauses([],List,List).
1625 generate_activate_clauses([C|Cs],List,Tail) :-
1626 generate_activate_clause(C,List,List1),
1627 generate_activate_clauses(Cs,List1,Tail).
1629 activate_constraint_goal(Constraint,Store,Vars,Susp,Generation,Goal) :-
1630 activate_constraint_name(Constraint,Name),
1631 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1632 Goal =.. [Name,Store, Susp]
1633 ; chr_pp_flag(debugable,off), may_trigger(Constraint) ->
1634 Goal =.. [Name,Store, Vars, Susp, Generation]
1635 ;
1636 Goal =.. [Name,Store, Vars, Susp]
1637 ).
1639 activate_constraint_name(Constraint,Name) :-
1640 make_name('$activate_constraint_',Constraint,Name).
1642 generate_activate_clause(Constraint,List,Tail) :-
1643 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
1644 List = [ActivateClause|Tail],
1645 % use_auxiliary_predicate(chr_indexed_variables,Constraint),
1646 get_dynamic_suspension_term_field(state,Constraint,Susp,Mref,StateGoal),
1647 activate_constraint_goal(Constraint,Store,Vars,Susp,Generation,Head),
1648 ( chr_pp_flag(debugable,off), may_trigger(Constraint) ->
1649 get_dynamic_suspension_term_field(generation,Constraint,Susp,Gref,GenerationGoal),
1650 GenerationHandling =
1651 (
1652 GenerationGoal,
1653 'chr get_mutable'( Gen, Gref),
1654 Generation is Gen+1,
1655 'chr update_mutable'( Generation, Gref)
1656 )
1657 ;
1658 GenerationHandling = true
1659 ),
1660 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1661 % Vars = [],
1662 StoreVarsGoal =
1663 ( State == not_stored_yet -> % compound(State) -> % passive/1
1664 Store = yes
1665 % ; State == removed -> % the price for eager removal ... % XXX redundant?
1666 % Store = yes
1667 ;
1668 Store = no
1669 )
1670 ;
1671 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
1672 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
1673 ( chr_pp_flag(guard_locks,off) ->
1674 NoneLocked = true
1675 ;
1676 NoneLocked = 'chr none_locked'( Vars)
1677 ),
1678 StoreVarsGoal =
1679 ( State == not_stored_yet -> % compound(State) -> % passive/1
1680 Store = yes,
1681 ArgumentsGoal,
1682 IndexedVariablesBody,
1683 NoneLocked
1684 % ; State == removed -> % the price for eager removal ... % XXX redundant ?
1685 % chr_indexed_variables(Susp,Vars),
1686 % Store = yes
1687 ;
1688 Vars = [],
1689 Store = no
1690 )
1691 ),
1692 ActivateClause =
1693 (
1694 Head :-
1695 StateGoal,
1696 'chr get_mutable'( State, Mref),
1697 'chr update_mutable'( active, Mref),
1698 GenerationHandling,
1699 StoreVarsGoal
1700 )
1701 ;
1702 List = Tail
1703 ).
1704 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1705 % allocate_constraint/4
1707 generate_allocate_clauses([],List,List).
1708 generate_allocate_clauses([C|Cs],List,Tail) :-
1709 generate_allocate_clause(C,List,List1),
1710 generate_allocate_clauses(Cs,List1,Tail).
1712 allocate_constraint_goal(Constraint, Closure, Self, _F, Args,Goal) :-
1713 allocate_constraint_name(Constraint,Name),
1714 ( chr_pp_flag(debugable,off), may_trigger(Constraint) ->
1715 Goal =.. [Name,Closure,Self|Args]
1716 ;
1717 Goal =.. [Name,Self|Args]
1718 ).
1720 allocate_constraint_name(Constraint,Name) :-
1721 make_name('$allocate_constraint_',Constraint,Name).
1723 generate_allocate_clause(Constraint,List,Tail) :-
1724 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
1725 List = [AllocateClause|Tail],
1726 % use_auxiliary_predicate(chr_indexed_variables,Constraint),
1727 Constraint = F/A,
1728 length(Args,A),
1729 allocate_constraint_goal(Constraint,Closure,Self,F,Args,Head),
1730 static_suspension_term(Constraint,Suspension),
1731 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1732 get_static_suspension_term_field(state,Constraint,Suspension,Mref),
1733 ( chr_pp_flag(debugable,on); may_trigger(Constraint) ->
1734 get_static_suspension_term_field(continuation,Constraint,Suspension,Closure),
1735 get_static_suspension_term_field(generation,Constraint,Suspension,Gref),
1736 GenerationHandling = 'chr create_mutable'(0,Gref)
1737 ;
1738 GenerationHandling = true
1739 ),
1740 ( chr_pp_flag(debugable,on) ->
1741 Constraint = Functor / _,
1742 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1743 ;
1744 true
1745 ),
1746 ( uses_history(Constraint) ->
1747 History = t,
1748 get_static_suspension_term_field(history,Constraint,Suspension,Href),
1749 HistoryHandling = 'chr create_mutable'(History,Href) % Href = mutable(History)
1750 ;
1751 HistoryHandling = true
1752 ),
1753 % get_static_suspension_term_field(functor,Constraint,Suspension,F),
1754 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1755 Self = Suspension,
1756 AllocateClause =
1757 (
1758 Head :-
1759 % Self =.. Suspension, %[suspension,Id,Mref,Closure,Gref,Href,F|Args],
1760 GenerationHandling, %'chr create_mutable'(0,Gref), % Gref = mutable(0),
1761 % 'chr empty_history'(History),
1762 HistoryHandling,
1763 'chr create_mutable'(not_stored_yet,Mref),
1764 'chr gen_id'( Id)
1765 )
1766 ;
1767 List = Tail
1768 ).
1770 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1771 % insert_constraint_internal/[3,6]
1773 generate_insert_constraint_internal_clauses([],List,List).
1774 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
1775 generate_insert_constraint_internal_clause(C,List,List1),
1776 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
1778 insert_constraint_internal_constraint_goal(Constraint, Stored, Vars, Self, Closure, _F, Args,Goal) :-
1779 insert_constraint_internal_constraint_name(Constraint,Name),
1780 ( (chr_pp_flag(debugable,on) ; may_trigger(Constraint)) ->
1781 Goal =.. [Name,Stored, Vars, Self, Closure | Args]
1782 ; only_ground_indexed_arguments(Constraint) ->
1783 Goal =.. [Name,Self | Args]
1784 ;
1785 Goal =.. [Name,Stored, Vars, Self | Args]
1786 ).
1788 insert_constraint_internal_constraint_name(Constraint,Name) :-
1789 make_name('$insert_constraint_internal_',Constraint,Name).
1791 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
1792 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
1793 Constraint = F/A,
1794 length(Args,A),
1795 insert_constraint_internal_constraint_goal(Constraint, yes, Vars, Self, Closure, F, Args,Head),
1796 static_suspension_term(Constraint,Suspension),
1797 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1798 get_static_suspension_term_field(state,Constraint,Suspension,Mref),
1799 ( (chr_pp_flag(debugable,on); may_trigger(Constraint)) ->
1800 get_static_suspension_term_field(continuation,Constraint,Suspension,Closure),
1801 get_static_suspension_term_field(generation,Constraint,Suspension,Gref),
1802 GenerationHandling = 'chr create_mutable'(0,Gref)
1803 ;
1804 GenerationHandling = true
1805 ),
1806 ( chr_pp_flag(debugable,on) ->
1807 Constraint = Functor / _,
1808 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1809 ;
1810 true
1811 ),
1812 ( uses_history(Constraint) ->
1813 History = t,
1814 get_static_suspension_term_field(history,Constraint,Suspension,Href),
1815 HistoryHandling = 'chr create_mutable'(History,Href)
1816 ;
1817 HistoryHandling = true
1818 ),
1819 % get_static_suspension_term_field(functor,Constraint,Suspension,F),
1820 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1821 Self = Suspension,
1822 List = [Clause|Tail],
1823 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1824 Closure = true,
1825 Clause =
1826 (
1827 Head :-
1828 'chr create_mutable'(active,Mref),
1829 GenerationHandling, %'chr create_mutable'(0,Gref),
1830 % 'chr empty_history'(History),
1831 HistoryHandling,
1832 % Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1833 'chr gen_id'(Id)
1834 )
1835 ;
1836 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
1837 ( chr_pp_flag(guard_locks,off) ->
1838 NoneLocked = true
1839 ;
1840 NoneLocked = 'chr none_locked'( Vars)
1841 ),
1842 Clause =
1843 (
1844 Head :-
1845 % Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
1846 IndexedVariablesBody, % chr_indexed_variables(Self,Vars),
1847 NoneLocked,
1848 'chr create_mutable'(active,Mref), % Mref = mutable(active),
1849 'chr create_mutable'(0,Gref), % Gref = mutable(0),
1850 % 'chr empty_history'(History),
1851 % 'chr create_mutable'(History,Href), % Href = mutable(History),
1852 HistoryHandling,
1853 'chr gen_id'(Id)
1854 )
1855 )
1856 ;
1857 List = Tail
1858 ).
1860 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1861 % novel_production/2
1863 generate_novel_production(List,Tail) :-
1864 ( is_used_auxiliary_predicate(novel_production) ->
1865 List = [Clause|Tail],
1866 Clause =
1867 (
1868 '$novel_production'( Self, Tuple) :-
1869 arg( 3, Self, Ref), % ARGXXX
1870 'chr get_mutable'( History, Ref),
1871 ( hprolog:get_ds( Tuple, History, _) ->
1872 fail
1873 ;
1874 true
1875 )
1876 )
1877 ;
1878 List = Tail
1879 ).
1881 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1882 % extend_history/2
1884 generate_extend_history(List,Tail) :-
1885 ( is_used_auxiliary_predicate(extend_history) ->
1886 List = [Clause|Tail],
1887 Clause =
1888 (
1889 '$extend_history'( Self, Tuple) :-
1890 arg( 3, Self, Ref), % ARGXXX
1891 'chr get_mutable'( History, Ref),
1892 hprolog:put_ds( Tuple, History, x, NewHistory),
1893 'chr update_mutable'( NewHistory, Ref)
1894 )
1895 ;
1896 List = Tail
1897 ).
1899 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1900 % run_suspensions/2
1902 generate_run_suspensions_clauses([],List,List).
1903 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
1904 generate_run_suspensions_clause(C,List,List1),
1905 generate_run_suspensions_clauses(Cs,List1,Tail).
1907 run_suspensions_goal(Constraint,Suspensions,Goal) :-
1908 run_suspensions_name(Constraint,Name),
1909 Goal =.. [Name,Suspensions].
1911 run_suspensions_name(Constraint,Name) :-
1912 make_name('$run_suspensions_',Constraint,Name).
1914 generate_run_suspensions_clause(Constraint,List,Tail) :-
1915 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
1916 List = [Clause1,Clause2|Tail],
1917 run_suspensions_goal(Constraint,[],Clause1),
1918 ( chr_pp_flag(debugable,on) ->
1919 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1920 get_dynamic_suspension_term_field(state,Constraint,Suspension,Mref,GetMref),
1921 get_dynamic_suspension_term_field(generation,Constraint,Suspension,Gref,GetGref),
1922 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
1923 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1924 Clause2 =
1925 (
1926 Clause2Head :-
1927 GetMref,
1928 'chr get_mutable'( Status, Mref),
1929 ( Status==active ->
1930 'chr update_mutable'( triggered, Mref),
1931 GetGref,
1932 'chr get_mutable'( Gen, Gref),
1933 Generation is Gen+1,
1934 'chr update_mutable'( Generation, Gref),
1935 GetContinuation,
1936 (
1937 'chr debug_event'(wake(Suspension)),
1938 call(Continuation)
1939 ;
1940 'chr debug_event'(fail(Suspension)), !,
1941 fail
1942 ),
1943 (
1944 'chr debug_event'(exit(Suspension))
1945 ;
1946 'chr debug_event'(redo(Suspension)),
1947 fail
1948 ),
1949 'chr get_mutable'( Post, Mref),
1950 ( Post==triggered ->
1951 'chr update_mutable'( active, Mref) % catching constraints that did not do anything
1952 ;
1953 true
1954 )
1955 ;
1956 true
1957 ),
1958 Clause2Recursion
1959 )
1960 ;
1961 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1962 get_dynamic_suspension_term_field(state,Constraint,Suspension,Mref,GetMref),
1963 get_dynamic_suspension_term_field(generation,Constraint,Suspension,Gref,GetGref),
1964 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
1965 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1966 Clause2 =
1967 (
1968 Clause2Head :-
1969 GetMref,
1970 'chr get_mutable'( Status, Mref),
1971 ( Status==active ->
1972 'chr update_mutable'( triggered, Mref),
1973 GetGref,
1974 'chr get_mutable'( Gen, Gref),
1975 Generation is Gen+1,
1976 'chr update_mutable'( Generation, Gref),
1977 GetContinuation,
1978 call( Continuation),
1979 'chr get_mutable'( Post, Mref),
1980 ( Post==triggered ->
1981 'chr update_mutable'( active, Mref) % catching constraints that did not do anything
1982 ;
1983 true
1984 )
1985 ;
1986 true
1987 ),
1988 Clause2Recursion
1989 )
1990 )
1991 ;
1992 List = Tail
1993 ).
1995 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1997 %global_indexed_variables_clause(Constraints,List,Tail) :-
1998 % ( is_used_auxiliary_predicate(chr_indexed_variables) ->
1999 % List = [Clause|Tail],
2000 % ( chr_pp_flag(reduced_indexing,on) ->
2001 % ( are_none_suspended_on_variables ->
2002 % Body = true,
2003 % Vars = []
2004 % ;
2005 % Body = (Susp =.. [_,_,_,_,_,_|Term],
2006 % Term1 =.. Term,
2007 % '$indexed_variables'(Term1,Vars))
2008 % ),
2009 % Clause = ( chr_indexed_variables(Susp,Vars) :- Body )
2010 % ;
2011 % Clause =
2012 % ( chr_indexed_variables(Susp,Vars) :-
2013 % 'chr chr_indexed_variables'(Susp,Vars)
2014 % )
2015 % )
2016 % ;
2017 % List = Tail
2018 % ).
2020 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2021 generate_attach_increment(Clauses) :-
2022 get_max_constraint_index(N),
2023 ( N > 0 ->
2024 Clauses = [Clause1,Clause2],
2025 generate_attach_increment_empty(Clause1),
2026 ( N == 1 ->
2027 generate_attach_increment_one(Clause2)
2028 ;
2029 generate_attach_increment_many(N,Clause2)
2030 )
2031 ;
2032 Clauses = []
2033 ).
2035 generate_attach_increment_empty((attach_increment([],_) :- true)).
2037 generate_attach_increment_one(Clause) :-
2038 Head = attach_increment([Var|Vars],Susps),
2039 get_target_module(Mod),
2040 ( chr_pp_flag(guard_locks,off) ->
2041 NotLocked = true
2042 ;
2043 NotLocked = 'chr not_locked'( Var)
2044 ),
2045 Body =
2046 (
2047 NotLocked,
2048 ( get_attr(Var,Mod,VarSusps) ->
2049 sort(VarSusps,SortedVarSusps),
2050 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2051 put_attr(Var,Mod,MergedSusps)
2052 ;
2053 put_attr(Var,Mod,Susps)
2054 ),
2055 attach_increment(Vars,Susps)
2056 ),
2057 Clause = (Head :- Body).
2059 generate_attach_increment_many(N,Clause) :-
2060 make_attr(N,Mask,SuspsList,Attr),
2061 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2062 Head = attach_increment([Var|Vars],Attr),
2063 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
2064 list2conj(Gs,SortGoals),
2065 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
2066 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
2067 get_target_module(Mod),
2068 ( chr_pp_flag(guard_locks,off) ->
2069 NotLocked = true
2070 ;
2071 NotLocked = 'chr not_locked'( Var)
2072 ),
2073 Body =
2074 (
2075 NotLocked,
2076 ( get_attr(Var,Mod,TOtherAttr) ->
2077 TOtherAttr = OtherAttr,
2078 SortGoals,
2079 MergedMask is Mask \/ OtherMask,
2080 put_attr(Var,Mod,NewAttr)
2081 ;
2082 put_attr(Var,Mod,Attr)
2083 ),
2084 attach_increment(Vars,Attr)
2085 ),
2086 Clause = (Head :- Body).
2088 %% attr_unify_hook
2089 generate_attr_unify_hook(Clauses) :-
2090 get_max_constraint_index(N),
2091 ( N == 0 ->
2092 Clauses = []
2093 ;
2094 Clauses = [Clause],
2095 ( N == 1 ->
2096 generate_attr_unify_hook_one(Clause)
2097 ;
2098 generate_attr_unify_hook_many(N,Clause)
2099 )
2100 ).
2102 generate_attr_unify_hook_one(Clause) :-
2103 Head = attr_unify_hook(Susps,Other),
2104 get_target_module(Mod),
2105 get_indexed_constraint(1,C),
2106 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2107 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2108 Body =
2109 (
2110 sort(Susps, SortedSusps),
2111 ( var(Other) ->
2112 ( get_attr(Other,Mod,OtherSusps) ->
2113 true
2114 ;
2115 OtherSusps = []
2116 ),
2117 sort(OtherSusps,SortedOtherSusps),
2118 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2119 put_attr(Other,Mod,NewSusps),
2120 WakeNewSusps
2121 ;
2122 ( compound(Other) ->
2123 term_variables(Other,OtherVars),
2124 attach_increment(OtherVars, SortedSusps)
2125 ;
2126 true
2127 ),
2128 WakeSusps
2129 )
2130 ),
2131 Clause = (Head :- Body).
2133 generate_attr_unify_hook_many(N,Clause) :-
2134 make_attr(N,Mask,SuspsList,Attr),
2135 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2136 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2137 list2conj(SortGoalList,SortGoals),
2138 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2139 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
2140 C = (sort(E,F),
2141 'chr merge_attributes'(D,F,G)) ),
2142 SortMergeGoalList),
2143 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
2144 list2conj(SortMergeGoalList,SortMergeGoals),
2145 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
2146 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2147 Head = attr_unify_hook(Attr,Other),
2148 get_target_module(Mod),
2149 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2150 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2151 Body =
2152 (
2153 SortGoals,
2154 ( var(Other) ->
2155 ( get_attr(Other,Mod,TOtherAttr) ->
2156 TOtherAttr = OtherAttr,
2157 SortMergeGoals,
2158 MergedMask is Mask \/ OtherMask,
2159 put_attr(Other,Mod,MergedAttr),
2160 WakeMergedSusps
2161 ;
2162 put_attr(Other,Mod,SortedAttr),
2163 WakeSortedSusps
2164 )
2165 ;
2166 ( compound(Other) ->
2167 term_variables(Other,OtherVars),
2168 attach_increment(OtherVars,SortedAttr)
2169 ;
2170 true
2171 ),
2172 WakeSortedSusps
2173 )
2174 ),
2175 Clause = (Head :- Body).
2177 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2178 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2180 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2181 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2182 use_auxiliary_predicate(run_suspensions,C),
2183 ( wakes_partially(C) ->
2184 run_suspensions_goal(C,OneSusps,Goal)
2185 ;
2186 run_suspensions_goal(C,AllSusps,Goal)
2187 )
2188 ;
2189 Goal = true
2190 ).
2192 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2193 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2195 make_run_suspensions_loop([],[],_,true).
2196 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2197 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2198 J is I + 1,
2199 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2201 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2202 % $insert_in_store_F/A
2203 % $delete_from_store_F/A
2205 generate_insert_delete_constraints([],[]).
2206 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2207 ( is_stored(FA) ->
2208 Clauses = [IClause,DClause|RestClauses],
2209 generate_insert_delete_constraint(FA,IClause,DClause)
2210 ;
2211 Clauses = RestClauses
2212 ),
2213 generate_insert_delete_constraints(Rest,RestClauses).
2215 generate_insert_delete_constraint(FA,IClause,DClause) :-
2216 get_store_type(FA,StoreType),
2217 generate_insert_constraint(StoreType,FA,IClause),
2218 generate_delete_constraint(StoreType,FA,DClause).
2220 generate_insert_constraint(StoreType,C,Clause) :-
2221 make_name('$insert_in_store_',C,ClauseName),
2222 Head =.. [ClauseName,Susp],
2223 generate_insert_constraint_body(StoreType,C,Susp,Body),
2224 ( chr_pp_flag(store_counter,on) ->
2225 InsertCounterInc = '$insert_counter_inc'
2226 ;
2227 InsertCounterInc = true
2228 ),
2229 Clause = (Head :- InsertCounterInc,Body).
2231 generate_insert_constraint_body(default,C,Susp,Body) :-
2232 global_list_store_name(C,StoreName),
2233 make_get_store_goal(StoreName,Store,GetStoreGoal),
2234 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2235 ( chr_pp_flag(debugable,on) ->
2236 Cell = [Susp|Store],
2237 Body =
2238 (
2239 GetStoreGoal, % nb_getval(StoreName,Store),
2240 UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
2241 )
2242 ;
2243 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2244 Body =
2245 (
2246 GetStoreGoal, % nb_getval(StoreName,Store),
2247 Cell = [Susp|Store],
2248 UpdateStoreGoal, % b_setval(StoreName,[Susp|Store])
2249 ( Store = [NextSusp|_] ->
2250 SetGoal
2251 ;
2252 true
2253 )
2254 )
2255 ).
2256 % get_target_module(Mod),
2257 % get_max_constraint_index(Total),
2258 % ( Total == 1 ->
2259 % generate_attach_body_1(C,Store,Susp,AttachBody)
2260 % ;
2261 % generate_attach_body_n(C,Store,Susp,AttachBody)
2262 % ),
2263 % Body =
2264 % (
2265 % 'chr default_store'(Store),
2266 % AttachBody
2267 % ).
2268 generate_insert_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
2269 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2270 generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
2271 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
2272 generate_insert_constraint_body(global_ground,C,Susp,Body) :-
2273 global_ground_store_name(C,StoreName),
2274 make_get_store_goal(StoreName,Store,GetStoreGoal),
2275 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2276 ( chr_pp_flag(debugable,on) ->
2277 Cell = [Susp|Store],
2278 Body =
2279 (
2280 GetStoreGoal, % nb_getval(StoreName,Store),
2281 UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
2282 )
2283 ;
2284 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2285 Body =
2286 (
2287 GetStoreGoal, % nb_getval(StoreName,Store),
2288 Cell = [Susp|Store],
2289 UpdateStoreGoal, % b_setval(StoreName,[Susp|Store])
2290 ( Store = [NextSusp|_] ->
2291 SetGoal
2292 ;
2293 true
2294 )
2295 )
2296 ).
2297 % global_ground_store_name(C,StoreName),
2298 % make_get_store_goal(StoreName,Store,GetStoreGoal),
2299 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
2300 % Body =
2301 % (
2302 % GetStoreGoal, % nb_getval(StoreName,Store),
2303 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
2304 % ).
2305 generate_insert_constraint_body(global_singleton,C,Susp,Body) :-
2306 global_singleton_store_name(C,StoreName),
2307 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
2308 Body =
2309 (
2310 UpdateStoreGoal % b_setval(StoreName,Susp)
2311 ).
2312 generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
2313 find_with_var_identity(
2314 B,
2315 [Susp],
2316 (
2317 member(ST,StoreTypes),
2318 chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
2319 ),
2320 Bodies
2321 ),
2322 list2conj(Bodies,Body).
2324 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
2325 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2326 multi_hash_store_name(FA,Index,StoreName),
2327 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2328 Body =
2329 (
2330 KeyBody,
2331 nb_getval(StoreName,Store),
2332 insert_iht(Store,Key,Susp)
2333 ),
2334 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
2335 generate_multi_hash_insert_constraint_bodies([],_,_,true).
2336 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2337 multi_hash_store_name(FA,Index,StoreName),
2338 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2339 make_get_store_goal(StoreName,Store,GetStoreGoal),
2340 Body =
2341 (
2342 KeyBody,
2343 GetStoreGoal, % nb_getval(StoreName,Store),
2344 insert_ht(Store,Key,Susp)
2345 ),
2346 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
2348 generate_delete_constraint(StoreType,FA,Clause) :-
2349 make_name('$delete_from_store_',FA,ClauseName),
2350 Head =.. [ClauseName,Susp],
2351 generate_delete_constraint_body(StoreType,FA,Susp,Body),
2352 ( chr_pp_flag(store_counter,on) ->
2353 DeleteCounterInc = '$delete_counter_inc'
2354 ;
2355 DeleteCounterInc = true
2356 ),
2357 Clause = (Head :- DeleteCounterInc, Body).
2359 generate_delete_constraint_body(default,C,Susp,Body) :-
2360 ( chr_pp_flag(debugable,on) ->
2361 global_list_store_name(C,StoreName),
2362 make_get_store_goal(StoreName,Store,GetStoreGoal),
2363 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2364 Body =
2365 (
2366 GetStoreGoal, % nb_getval(StoreName,Store),
2367 'chr sbag_del_element'(Store,Susp,NStore),
2368 UpdateStoreGoal % b_setval(StoreName,NStore)
2369 )
2370 ;
2371 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2372 global_list_store_name(C,StoreName),
2373 make_get_store_goal(StoreName,Store,GetStoreGoal),
2374 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2375 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2376 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2377 Body =
2378 (
2379 GetGoal,
2380 ( var(PredCell) ->
2381 GetStoreGoal, % nb_getval(StoreName,Store),
2382 Store = [_|Tail],
2383 UpdateStoreGoal,
2384 ( Tail = [NextSusp|_] ->
2385 SetGoal1
2386 ;
2387 true
2388 )
2389 ;
2390 PredCell = [_,_|Tail],
2391 setarg(2,PredCell,Tail),
2392 ( Tail = [NextSusp|_] ->
2393 SetGoal2
2394 ;
2395 true
2396 )
2397 )
2398 )
2399 ).
2400 % get_target_module(Mod),
2401 % get_max_constraint_index(Total),
2402 % ( Total == 1 ->
2403 % generate_detach_body_1(C,Store,Susp,DetachBody),
2404 % Body =
2405 % (
2406 % 'chr default_store'(Store),
2407 % DetachBody
2408 % )
2409 % ;
2410 % generate_detach_body_n(C,Store,Susp,DetachBody),
2411 % Body =
2412 % (
2413 % 'chr default_store'(Store),
2414 % DetachBody
2415 % )
2416 % ).
2417 generate_delete_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
2418 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
2419 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
2420 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
2421 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
2422 ( chr_pp_flag(debugable,on) ->
2423 global_ground_store_name(C,StoreName),
2424 make_get_store_goal(StoreName,Store,GetStoreGoal),
2425 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2426 Body =
2427 (
2428 GetStoreGoal, % nb_getval(StoreName,Store),
2429 'chr sbag_del_element'(Store,Susp,NStore),
2430 UpdateStoreGoal % b_setval(StoreName,NStore)
2431 )
2432 ;
2433 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2434 global_ground_store_name(C,StoreName),
2435 make_get_store_goal(StoreName,Store,GetStoreGoal),
2436 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2437 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2438 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2439 Body =
2440 (
2441 GetGoal,
2442 ( var(PredCell) ->
2443 GetStoreGoal, % nb_getval(StoreName,Store),
2444 Store = [_|Tail],
2445 UpdateStoreGoal,
2446 ( Tail = [NextSusp|_] ->
2447 SetGoal1
2448 ;
2449 true
2450 )
2451 ;
2452 PredCell = [_,_|Tail],
2453 setarg(2,PredCell,Tail),
2454 ( Tail = [NextSusp|_] ->
2455 SetGoal2
2456 ;
2457 true
2458 )
2459 )
2460 )
2461 ).
2462 % global_ground_store_name(C,StoreName),
2463 % make_get_store_goal(StoreName,Store,GetStoreGoal),
2464 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2465 % Body =
2466 % (
2467 % GetStoreGoal, % nb_getval(StoreName,Store),
2468 % 'chr sbag_del_element'(Store,Susp,NStore),
2469 % UpdateStoreGoal % b_setval(StoreName,NStore)
2470 % ).
2471 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
2472 global_singleton_store_name(C,StoreName),
2473 make_update_store_goal(StoreName,[],UpdateStoreGoal),
2474 Body =
2475 (
2476 UpdateStoreGoal % b_setval(StoreName,[])
2477 ).
2478 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
2479 find_with_var_identity(
2480 B,
2481 [Susp],
2482 (
2483 member(ST,StoreTypes),
2484 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
2485 ),
2486 Bodies
2487 ),
2488 list2conj(Bodies,Body).
2490 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
2491 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2492 multi_hash_store_name(FA,Index,StoreName),
2493 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2494 Body =
2495 (
2496 KeyBody,
2497 nb_getval(StoreName,Store),
2498 delete_iht(Store,Key,Susp)
2499 ),
2500 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2501 generate_multi_hash_delete_constraint_bodies([],_,_,true).
2502 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2503 multi_hash_store_name(FA,Index,StoreName),
2504 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2505 make_get_store_goal(StoreName,Store,GetStoreGoal),
2506 Body =
2507 (
2508 KeyBody,
2509 GetStoreGoal, % nb_getval(StoreName,Store),
2510 delete_ht(Store,Key,Susp)
2511 ),
2512 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2514 generate_delete_constraint_call(FA,Susp,Call) :-
2515 make_name('$delete_from_store_',FA,Functor),
2516 Call =.. [Functor,Susp].
2518 generate_insert_constraint_call(FA,Susp,Call) :-
2519 make_name('$insert_in_store_',FA,Functor),
2520 Call =.. [Functor,Susp].
2522 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2524 :- chr_constraint
2525 module_initializer/1,
2526 module_initializers/1.
2528 module_initializers(G), module_initializer(Initializer) <=>
2529 G = (Initializer,Initializers),
2530 module_initializers(Initializers).
2532 module_initializers(G) <=>
2533 G = true.
2535 generate_attach_code(Constraints,[Enumerate|L]) :-
2536 enumerate_stores_code(Constraints,Enumerate),
2537 generate_attach_code(Constraints,L,T),
2538 module_initializers(Initializers),
2539 prolog_global_variables_code(PrologGlobalVariables),
2540 T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables].
2542 generate_attach_code([],L,L).
2543 generate_attach_code([C|Cs],L,T) :-
2544 get_store_type(C,StoreType),
2545 generate_attach_code(StoreType,C,L,L1),
2546 generate_attach_code(Cs,L1,T).
2548 generate_attach_code(default,C,L,T) :-
2549 global_list_store_initialisation(C,L,T).
2550 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
2551 multi_inthash_store_initialisations(Indexes,C,L,L1),
2552 multi_inthash_via_lookups(Indexes,C,L1,T).
2553 generate_attach_code(multi_hash(Indexes),C,L,T) :-
2554 multi_hash_store_initialisations(Indexes,C,L,L1),
2555 multi_hash_via_lookups(Indexes,C,L1,T).
2556 generate_attach_code(global_ground,C,L,T) :-
2557 global_ground_store_initialisation(C,L,T).
2558 generate_attach_code(global_singleton,C,L,T) :-
2559 global_singleton_store_initialisation(C,L,T).
2560 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
2561 multi_store_generate_attach_code(StoreTypes,C,L,T).
2563 multi_store_generate_attach_code([],_,L,L).
2564 multi_store_generate_attach_code([ST|STs],C,L,T) :-
2565 generate_attach_code(ST,C,L,L1),
2566 multi_store_generate_attach_code(STs,C,L1,T).
2568 multi_inthash_store_initialisations([],_,L,L).
2569 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
2570 multi_hash_store_name(FA,Index,StoreName),
2571 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
2572 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
2573 L1 = L,
2574 multi_inthash_store_initialisations(Indexes,FA,L1,T).
2575 multi_hash_store_initialisations([],_,L,L).
2576 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
2577 multi_hash_store_name(FA,Index,StoreName),
2578 prolog_global_variable(StoreName),
2579 make_init_store_goal(StoreName,HT,InitStoreGoal),
2580 module_initializer((new_ht(HT),InitStoreGoal)),
2581 L1 = L,
2582 multi_hash_store_initialisations(Indexes,FA,L1,T).
2584 global_list_store_initialisation(C,L,T) :-
2585 global_list_store_name(C,StoreName),
2586 prolog_global_variable(StoreName),
2587 make_init_store_goal(StoreName,[],InitStoreGoal),
2588 module_initializer(InitStoreGoal),
2589 L = T.
2590 global_ground_store_initialisation(C,L,T) :-
2591 global_ground_store_name(C,StoreName),
2592 prolog_global_variable(StoreName),
2593 make_init_store_goal(StoreName,[],InitStoreGoal),
2594 module_initializer(InitStoreGoal),
2595 L = T.
2596 global_singleton_store_initialisation(C,L,T) :-
2597 global_singleton_store_name(C,StoreName),
2598 prolog_global_variable(StoreName),
2599 make_init_store_goal(StoreName,[],InitStoreGoal),
2600 module_initializer(InitStoreGoal),
2601 L = T.
2603 multi_inthash_via_lookups([],_,L,L).
2604 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
2605 multi_hash_via_lookup_name(C,Index,PredName),
2606 Head =.. [PredName,Key,SuspsList],
2607 multi_hash_store_name(C,Index,StoreName),
2608 Body =
2609 (
2610 nb_getval(StoreName,HT),
2611 lookup_iht(HT,Key,SuspsList)
2612 ),
2613 L = [(Head :- Body)|L1],
2614 multi_inthash_via_lookups(Indexes,C,L1,T).
2615 multi_hash_via_lookups([],_,L,L).
2616 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
2617 multi_hash_via_lookup_name(C,Index,PredName),
2618 Head =.. [PredName,Key,SuspsList],
2619 multi_hash_store_name(C,Index,StoreName),
2620 make_get_store_goal(StoreName,HT,GetStoreGoal),
2621 Body =
2622 (
2623 GetStoreGoal, % nb_getval(StoreName,HT),
2624 lookup_ht(HT,Key,SuspsList)
2625 ),
2626 L = [(Head :- Body)|L1],
2627 multi_hash_via_lookups(Indexes,C,L1,T).
2629 multi_hash_via_lookup_name(F/A,Index,Name) :-
2630 ( integer(Index) ->
2631 IndexName = Index
2632 ; is_list(Index) ->
2633 atom_concat_list(Index,IndexName)
2634 ),
2635 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
2637 multi_hash_store_name(F/A,Index,Name) :-
2638 get_target_module(Mod),
2639 ( integer(Index) ->
2640 IndexName = Index
2641 ; is_list(Index) ->
2642 atom_concat_list(Index,IndexName)
2643 ),
2644 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
2646 multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
2647 ( ( integer(Index) ->
2648 I = Index
2649 ;
2650 Index = [I]
2651 ) ->
2652 get_dynamic_suspension_term_field(argument(I),F/A,Susp,Key,KeyBody)
2653 ; is_list(Index) ->
2654 sort(Index,Indexes),
2655 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),F/A,Susp,KeyI,Goal)),ArgKeyPairs),
2656 once(pairup(Bodies,Keys,ArgKeyPairs)),
2657 Key =.. [k|Keys],
2658 list2conj(Bodies,KeyBody)
2659 ).
2661 multi_hash_key_args(Index,Head,KeyArgs) :-
2662 ( integer(Index) ->
2663 arg(Index,Head,Arg),
2664 KeyArgs = [Arg]
2665 ; is_list(Index) ->
2666 sort(Index,Indexes),
2667 term_variables(Head,Vars),
2668 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
2669 ).
2671 global_list_store_name(F/A,Name) :-
2672 get_target_module(Mod),
2673 atom_concat_list(['$chr_store_global_list_',Mod,(:),F,(/),A],Name).
2674 global_ground_store_name(F/A,Name) :-
2675 get_target_module(Mod),
2676 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
2677 global_singleton_store_name(F/A,Name) :-
2678 get_target_module(Mod),
2679 atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
2681 :- chr_constraint
2682 prolog_global_variable/1,
2683 prolog_global_variables/1.
2685 :- chr_option(mode,prolog_global_variable(+)).
2686 :- chr_option(mode,prolog_global_variable(2)).
2688 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
2690 prolog_global_variables(List), prolog_global_variable(Name) <=>
2691 List = [Name|Tail],
2692 prolog_global_variables(Tail).
2693 prolog_global_variables(List) <=> List = [].
2695 %% SWI begin
2696 prolog_global_variables_code(Code) :-
2697 prolog_global_variables(Names),
2698 ( Names == [] ->
2699 Code = []
2700 ;
2701 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
2702 Code = [(:- dynamic user:exception/3),
2703 (:- multifile user:exception/3),
2704 (user:exception(undefined_global_variable,Name,retry) :-
2705 (
2706 '$chr_prolog_global_variable'(Name),
2707 '$chr_initialization'
2708 )
2709 )
2710 |
2711 NameDeclarations
2712 ]
2713 ).
2714 %% SWI end
2715 %% SICStus begin
2716 prolog_global_variables_code([]).
2717 %% SICStus end
2718 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2719 %sbag_member_call(S,L,sysh:mem(S,L)).
2720 sbag_member_call(S,L,'chr sbag_member'(S,L)).
2721 %sbag_member_call(S,L,member(S,L)).
2723 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2725 enumerate_stores_code(Constraints,Clause) :-
2726 Head = '$enumerate_constraints'(Constraint),
2727 enumerate_store_bodies(Constraints,Constraint,Bodies),
2728 list2disj(Bodies,Body),
2729 Clause = (Head :- Body).
2731 enumerate_store_bodies([],_,[]).
2732 enumerate_store_bodies([C|Cs],Constraint,L) :-
2733 ( is_stored(C) ->
2734 get_store_type(C,StoreType),
2735 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
2736 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
2737 C = F/_,
2738 Constraint0 =.. [F|Arguments],
2739 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
2740 L = [Body|T]
2741 ;
2742 L = T
2743 ),
2744 enumerate_store_bodies(Cs,Constraint,T).
2746 enumerate_store_body(default,C,Susp,Body) :-
2747 global_list_store_name(C,StoreName),
2748 sbag_member_call(Susp,List,Sbag),
2749 make_get_store_goal(StoreName,List,GetStoreGoal),
2750 Body =
2751 (
2752 GetStoreGoal, % nb_getval(StoreName,List),
2753 Sbag
2754 ).
2755 % get_constraint_index(C,Index),
2756 % get_target_module(Mod),
2757 % get_max_constraint_index(MaxIndex),
2758 % Body1 =
2759 % (
2760 % 'chr default_store'(GlobalStore),
2761 % get_attr(GlobalStore,Mod,Attr)
2762 % ),
2763 % ( MaxIndex > 1 ->
2764 % NIndex is Index + 1,
2765 % sbag_member_call(Susp,List,Sbag),
2766 % Body2 =
2767 % (
2768 % arg(NIndex,Attr,List),
2769 % Sbag
2770 % )
2771 % ;
2772 % sbag_member_call(Susp,Attr,Sbag),
2773 % Body2 = Sbag
2774 % ),
2775 % Body = (Body1,Body2).
2776 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
2777 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
2778 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
2779 multi_hash_enumerate_store_body(Index,C,Susp,Body).
2780 enumerate_store_body(global_ground,C,Susp,Body) :-
2781 global_ground_store_name(C,StoreName),
2782 sbag_member_call(Susp,List,Sbag),
2783 make_get_store_goal(StoreName,List,GetStoreGoal),
2784 Body =
2785 (
2786 GetStoreGoal, % nb_getval(StoreName,List),
2787 Sbag
2788 ).
2789 enumerate_store_body(global_singleton,C,Susp,Body) :-
2790 global_singleton_store_name(C,StoreName),
2791 make_get_store_goal(StoreName,Susp,GetStoreGoal),
2792 Body =
2793 (
2794 GetStoreGoal, % nb_getval(StoreName,Susp),
2795 Susp \== []
2796 ).
2797 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
2798 once((
2799 member(ST,STs),
2800 enumerate_store_body(ST,C,Susp,Body)
2801 )).
2803 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
2804 multi_hash_store_name(C,I,StoreName),
2805 B =
2806 (
2807 nb_getval(StoreName,HT),
2808 value_iht(HT,Susp)
2809 ).
2810 multi_hash_enumerate_store_body(I,C,Susp,B) :-
2811 multi_hash_store_name(C,I,StoreName),
2812 make_get_store_goal(StoreName,HT,GetStoreGoal),
2813 B =
2814 (
2815 GetStoreGoal, % nb_getval(StoreName,HT),
2816 value_ht(HT,Susp)
2817 ).
2819 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2822 :- chr_constraint
2823 prev_guard_list/7,
2824 simplify_guards/1,
2825 set_all_passive/1.
2827 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
2828 :- chr_option(mode,simplify_guards(+)).
2829 :- chr_option(mode,set_all_passive(+)).
2831 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2832 % GUARD SIMPLIFICATION
2833 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2834 % If the negation of the guards of earlier rules entails (part of)
2835 % the current guard, the current guard can be simplified. We can only
2836 % use earlier rules with a head that matches if the head of the current
2837 % rule does, and which make it impossible for the current rule to match
2838 % if they fire (i.e. they shouldn't be propagation rules and their
2839 % head constraints must be subsets of those of the current rule).
2840 % At this point, we know for sure that the negation of the guard
2841 % of such a rule has to be true (otherwise the earlier rule would have
2842 % fired, because of the refined operational semantics), so we can use
2843 % that information to simplify the guard by replacing all entailed
2844 % conditions by true/0. As a consequence, the never-stored analysis
2845 % (in a further phase) will detect more cases of never-stored constraints.
2846 %
2847 % e.g. c(X),d(Y) <=> X > 0 | ...
2848 % e(X) <=> X < 0 | ...
2849 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
2850 % \____________/
2851 % true
2853 guard_simplification :-
2854 ( chr_pp_flag(guard_simplification,on) ->
2855 multiple_occ_constraints_checked([]),
2856 simplify_guards(1)
2857 ;
2858 true
2859 ).
2861 % for every rule, we create a prev_guard_list where the last argument
2862 % eventually is a list of the negations of earlier guards
2863 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=>
2864 Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
2865 append(Head1,Head2,Heads),
2866 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
2867 add_guard_to_head(Heads,G,GHeads),
2868 PrevRule is RuleNb-1,
2869 prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
2870 multiple_occ_constraints_checked([]),
2871 NextRule is RuleNb+1, simplify_guards(NextRule).
2873 simplify_guards(_) <=> true.
2875 % the negation of the guard of a non-propagation rule is added
2876 % if its kept head constraints are a subset of the kept constraints of
2877 % the rule we're working on, and its removed head constraints (at least one)
2878 % are a subset of the removed constraints
2879 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
2880 Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
2881 H1 \== [],
2882 append(H1,H2,Heads),
2883 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
2884 setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
2885 Renamings \= []
2886 |
2887 compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
2888 append(GuardList,DerivedInfo,GL1),
2889 list2conj(GL1,GL_),
2890 conj2list(GL_,GL),
2891 append(GH_New1,GH,GH1),
2892 list2conj(GH1,GH_),
2893 conj2list(GH_,GH_New),
2894 N1 is N-1,
2895 prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
2898 % if this isn't the case, we skip this one and try the next rule
2899 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
2900 N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
2902 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
2903 GH \== [] |
2904 add_type_information_(H,GH,TypeInfo),
2905 conj2list(TypeInfo,TI),
2906 term_variables(H,HeadVars),
2907 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
2908 list2conj(Info,InfoC),
2909 conj2list(InfoC,InfoL),
2910 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
2912 add_type_information_(H,[],true) :- !.
2913 add_type_information_(H,[GH|GHs],TI) :- !,
2914 add_type_information(H,GH,TI1),
2915 TI = (TI1, TI2),
2916 add_type_information_(H,GHs,TI2).
2918 % when all earlier guards are added or skipped, we simplify the guard.
2919 % if it's different from the original one, we change the rule
2920 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=>
2921 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
2922 G \== true, % let's not try to simplify this ;)
2923 append(M,GuardList,Info),
2924 simplify_guard(G,B,Info,SimpleGuard,NB),
2925 G \== SimpleGuard |
2926 % ( prolog_flag(verbose,V), V == yes ->
2927 % format(' * Guard simplification in ~@\n',[format_rule(Rule)]),
2928 % format(' was: ~w\n',[G]),
2929 % format(' now: ~w\n',[SimpleGuard]),
2930 % (NB\==B -> format(' new body: ~w\n',[NB]) ; true)
2931 % ;
2932 % true
2933 % ),
2934 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
2935 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
2938 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2939 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
2940 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2942 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
2944 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
2945 copy_term(Matchings-G2,FreshMatchings),
2946 variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
2947 append(Renaming1,ExtraRenaming,Renaming2),
2948 list2conj(Matchings,Match),
2949 negate_b(Match,HeadsDontMatch),
2950 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
2951 list2conj(HeadsMatch,HeadsMatchBut),
2952 term_variables(Renaming2,RenVars),
2953 term_variables(Matchings-G2-HeadsMatch,MGVars),
2954 new_vars(MGVars,RenVars,ExtraRenaming2),
2955 append(Renaming2,ExtraRenaming2,Renaming),
2956 negate_b(G2,TheGuardFailed),
2957 ( G2 == true -> % true can't fail
2958 Info_ = HeadsDontMatch
2959 ;
2960 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
2961 ),
2962 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
2963 copy_with_variable_replacement(G2,RenamedG2,Renaming),
2964 copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
2965 list2conj(RenamedMatchings_,RenamedMatchings),
2966 add_guard_to_head(H,RenamedG2,GH2),
2967 add_guard_to_head(GH2,RenamedMatchings,GH3),
2968 compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
2969 append([DerivedInfo1],DerivedInfo2,DerivedInfo),
2970 append([GH3],GH_New2,GH_New).
2973 simplify_guard(G,B,Info,SG,NB) :-
2974 conj2list(G,LG),
2975 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
2976 list2conj(SGL,SG).
2979 new_vars([],_,[]).
2980 new_vars([A|As],RV,ER) :-
2981 ( memberchk_eq(A,RV) ->
2982 new_vars(As,RV,ER)
2983 ;
2984 ER = [A-NewA,NewA-A|ER2],
2985 new_vars(As,RV,ER2)
2986 ).
2988 % check if a list of constraints is a subset of another list of constraints
2989 % (multiset-subset), meanwhile computing a variable renaming to convert
2990 % one into the other.
2991 head_subset(H,Head,Renaming) :-
2992 head_subset(H,Head,Renaming,[],_).
2994 % empty list is a subset of everything
2995 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
2996 Renaming = Cumul,
2997 Headleft = Head.
2999 % first constraint has to be in the list, the rest has to be a subset
3000 % of the list with one occurrence of the first constraint removed
3001 % (has to be multiset-subset)
3002 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
3003 head_subset(A,Head,R1,Cumul,Headleft1),
3004 head_subset(B,Headleft1,R2,R1,Headleft2),
3005 Renaming = R2,
3006 Headleft = Headleft2.
3008 % check if A is in the list, remove it from Headleft
3009 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
3010 ( head_subset(A,X,R1,Cumul,HL1),
3011 Renaming = R1,
3012 Headleft = Y
3013 ;
3014 head_subset(A,Y,R2,Cumul,HL2),
3015 Renaming = R2,
3016 Headleft = [X|HL2]
3017 ).
3019 % A is X if there's a variable renaming to make them identical
3020 head_subset(A,X,Renaming,Cumul,Headleft) :-
3021 variable_replacement(A,X,Cumul,Renaming),
3022 Headleft = [].
3024 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
3025 extract_variables(Heads,VH1),
3026 make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
3027 insert_variables(H1_,Heads,UniqueVarsHeads).
3029 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
3030 extract_variables(Heads,VH1),
3031 make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
3032 insert_variables(H1_,Heads,UniqueVarsHeads).
3034 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
3035 extract_variables(Heads,VH1),
3036 extract_variables(UniqueVarsHeads,UV),
3037 make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
3040 extract_variables([],[]).
3041 extract_variables([X|R],V) :-
3042 X =.. [_|Args],
3043 extract_variables(R,V2),
3044 append(Args,V2,V).
3046 insert_variables([],[],[]) :- !.
3047 insert_variables(Vars,[C|R],[C2|R2]) :-
3048 C =.. [F | Args],
3049 length(Args,N),
3050 take_first_N(Vars,N,Args2,RestVars),
3051 C2 =.. [F | Args2],
3052 insert_variables(RestVars,R,R2).
3054 take_first_N(Vars,0,[],Vars) :- !.
3055 take_first_N([X|R],N,[X|R2],RestVars) :-
3056 N1 is N-1,
3057 take_first_N(R,N1,R2,RestVars).
3059 make_matchings_explicit([],[],_,MC,MC,[]).
3060 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
3061 ( var(X) ->
3062 ( memberchk_eq(X,C) ->
3063 list2disj(MC,MC_disj),
3064 M = [(MC_disj ; NewVar == X)|M2], % or only = ??
3065 C2 = C
3066 ;
3067 M = M2,
3068 NewVar = X,
3069 C2 = [X|C]
3070 ),
3071 MC2 = MC
3072 ;
3073 functor(X,F,A),
3074 X =.. [F|Args],
3075 make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
3076 X_ =.. [F|NewArgs],
3077 (ArgM == [] ->
3078 M = [functor(NewVar,F,A) |M2]
3079 ;
3080 list2conj(ArgM,ArgM_conj),
3081 list2disj(MC,MC_disj),
3082 ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
3083 M = [ functor(NewVar,F,A) , ArgM_|M2]
3084 ),
3085 MC2 = [ NewVar \= X_ |MC_],
3086 term_variables(Args,ArgVars),
3087 append(C,ArgVars,C2)
3088 ),
3089 make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
3092 make_matchings_explicit_not_negated([],[],_,[]).
3093 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
3094 M = [NewVar = X|M2],
3095 C2 = C,
3096 make_matchings_explicit_not_negated(R,R2,C2,M2).
3099 add_guard_to_head([],G,[]).
3100 add_guard_to_head([H|RH],G,[GH|RGH]) :-
3101 (var(H) ->
3102 find_guard_info_for_var(H,G,GH)
3103 ;
3104 functor(H,F,A),
3105 H =.. [F|HArgs],
3106 add_guard_to_head(HArgs,G,NewHArgs),
3107 GH =.. [F|NewHArgs]
3108 ),
3109 add_guard_to_head(RH,G,RGH).
3111 find_guard_info_for_var(H,(G1,G2),GH) :- !,
3112 find_guard_info_for_var(H,G1,GH1),
3113 find_guard_info_for_var(GH1,G2,GH).
3115 find_guard_info_for_var(H,G,GH) :-
3116 (G = (H1 = A), H == H1 ->
3117 GH = A
3118 ;
3119 (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
3120 length(GHArg,HA),
3121 GH =.. [HF|GHArg]
3122 ;
3123 GH = H
3124 )
3125 ).
3127 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3128 % ALWAYS FAILING HEADS
3129 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3131 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=>
3132 chr_pp_flag(check_impossible_rules,on),
3133 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3134 append(M,GuardList,Info),
3135 guard_entailment:entails_guard(Info,fail) |
3136 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3137 set_all_passive(RuleNb).
3139 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3140 % HEAD SIMPLIFICATION
3141 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3143 % now we check the head matchings (guard may have been simplified meanwhile)
3144 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=>
3145 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3146 simplify_heads(M,GuardList,G,B,NewM,NewB),
3147 NewM \== [],
3148 extract_variables(Head1,VH1),
3149 extract_variables(Head2,VH2),
3150 extract_variables(H,VH),
3151 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
3152 insert_variables(H1,Head1,NewH1),
3153 insert_variables(H2,Head2,NewH2),
3154 append(NewB,NewB_,NewBody),
3155 list2conj(NewBody,BodyMatchings),
3156 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
3157 (Head1 \== NewH1 ; Head2 \== NewH2 )
3158 |
3159 % ( prolog_flag(verbose,V), V == yes ->
3160 % format(' * Head simplification in ~@\n',[format_rule(Rule)]),
3161 % format(' was: ~w \\ ~w \n',[Head2,Head1]),
3162 % format(' now: ~w \\ ~w \n',[NewH2,NewH1]),
3163 % format(' extra body: ~w \n',[BodyMatchings])
3164 % ;
3165 % true
3166 % ),
3167 rule(RuleNb,NewRule).
3171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3172 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
3173 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3175 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
3176 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
3177 ( NH == M ->
3178 H2_ = M,
3179 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
3180 ;
3181 (M = functor(X,F,A), NH == X ->
3182 length(A_args,A),
3183 (var(H2) ->
3184 NewB1 = [],
3185 H2_ =.. [F|A_args]
3186 ;
3187 H2 =.. [F|OrigArgs],
3188 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3189 H2_ =.. [F|A_args_]
3190 ),
3191 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
3192 append(NewB1,NewB2,NewB)
3193 ;
3194 H2_ = H2,
3195 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
3196 )
3197 ).
3199 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
3200 ( NH == M ->
3201 H1_ = M,
3202 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
3203 ;
3204 (M = functor(X,F,A), NH == X ->
3205 length(A_args,A),
3206 (var(H1) ->
3207 NewB1 = [],
3208 H1_ =.. [F|A_args]
3209 ;
3210 H1 =.. [F|OrigArgs],
3211 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3212 H1_ =.. [F|A_args_]
3213 ),
3214 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
3215 append(NewB1,NewB2,NewB)
3216 ;
3217 H1_ = H1,
3218 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
3219 )
3220 ).
3222 use_same_args([],[],[],_,_,[]).
3223 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3224 var(OA),!,
3225 Out = OA,
3226 use_same_args(ROA,RNA,ROut,G,Body,NewB).
3227 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3228 nonvar(OA),!,
3229 ( vars_occur_in(OA,Body) ->
3230 NewB = [NA = OA|NextB]
3231 ;
3232 NewB = NextB
3233 ),
3234 Out = NA,
3235 use_same_args(ROA,RNA,ROut,G,Body,NextB).
3238 simplify_heads([],_GuardList,_G,_Body,[],[]).
3239 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
3240 M = (A = B),
3241 ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
3242 guard_entailment:entails_guard(GuardList,(A=B)) ->
3243 ( vars_occur_in(B,G-RM-GuardList) ->
3244 NewB = NextB,
3245 NewM = NextM
3246 ;
3247 ( vars_occur_in(B,Body) ->
3248 NewB = [A = B|NextB]
3249 ;
3250 NewB = NextB
3251 ),
3252 NewM = [A|NextM]
3253 )
3254 ;
3255 ( nonvar(B), functor(B,BFu,BAr),
3256 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
3257 NewB = NextB,
3258 ( vars_occur_in(B,G-RM-GuardList) ->
3259 NewM = NextM
3260 ;
3261 NewM = [functor(A,BFu,BAr)|NextM]
3262 )
3263 ;
3264 NewM = NextM,
3265 NewB = NextB
3266 )
3267 ),
3268 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
3270 vars_occur_in(B,G) :-
3271 term_variables(B,BVars),
3272 term_variables(G,GVars),
3273 intersect_eq(BVars,GVars,L),
3274 L \== [].
3277 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3278 % ALWAYS FAILING GUARDS
3279 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3281 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
3282 set_all_passive(_) <=> true.
3284 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==>
3285 chr_pp_flag(check_impossible_rules,on),
3286 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
3287 conj2list(G,GL),
3288 guard_entailment:entails_guard(GL,fail) |
3289 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3290 set_all_passive(RuleNb).
3294 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3295 % OCCURRENCE SUBSUMPTION
3296 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3298 :- chr_constraint
3299 first_occ_in_rule/4,
3300 next_occ_in_rule/6,
3301 multiple_occ_constraints_checked/1.
3303 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
3304 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
3305 :- chr_option(mode,multiple_occ_constraints_checked(+)).
3309 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3310 occurrence(C,O,RuleNb,ID,_), occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule)
3311 \ multiple_occ_constraints_checked(Done) <=>
3312 O < O2,
3313 chr_pp_flag(occurrence_subsumption,on),
3314 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
3315 H1 \== [],
3316 \+ memberchk_eq(C,Done) |
3317 first_occ_in_rule(RuleNb,C,O,ID),
3318 multiple_occ_constraints_checked([C|Done]).
3321 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 |
3322 first_occ_in_rule(RuleNb,C,O,ID).
3324 first_occ_in_rule(RuleNb,C,O,ID_o1) <=>
3325 C = F/A,
3326 functor(FreshHead,F,A),
3327 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
3329 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_)
3330 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
3331 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
3334 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3335 occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \
3336 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
3337 O2 is O+1,
3338 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
3339 |
3340 append(H1,H2,Heads),
3341 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
3342 ( ExtraCond == [chr_pp_void_info] ->
3343 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
3344 ;
3345 append(ExtraCond,Cond,NewCond),
3346 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
3347 copy_term(GuardList,FGuardList),
3348 variable_replacement(GuardList,FGuardList,GLRepl),
3349 copy_with_variable_replacement(GuardList,GuardList2,Repl),
3350 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
3351 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
3352 append(NewCond,GuardList2,BigCond),
3353 append(BigCond,GuardList3,BigCond2),
3354 copy_with_variable_replacement(M,M2,Repl),
3355 copy_with_variable_replacement(M,M3,Repl2),
3356 append(M3,BigCond2,BigCond3),
3357 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
3358 list2conj(CheckCond,OccSubsum),
3359 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
3360 term_variables(NewCond2-FH2,InfoVars),
3361 flatten_stuff(Info2,Info3),
3362 flatten_stuff(OccSubsum2,OccSubsum3),
3363 ( OccSubsum \= chr_pp_void_info,
3364 unify_stuff(InfoVars,Info3,OccSubsum3), !,
3365 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
3366 % ( prolog_flag(verbose,V), V == yes ->
3367 % format(' * Occurrence subsumption detected in ~@\n',[format_rule(Rule)]),
3368 % format(' passive: constraint ~w, occurrence number ~w (id ~w)\n',[C,O2,ID_o2]),
3369 % ;
3370 % true
3371 % ),
3372 passive(RuleNb,ID_o2)
3373 ;
3374 true
3375 )
3376 ; true
3377 ),!,
3378 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
3379 ).
3382 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
3383 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3384 multiple_occ_constraints_checked(Done) <=> true.
3386 flatten_stuff([A|B],C) :- !,
3387 flatten_stuff(A,C1),
3388 flatten_stuff(B,C2),
3389 append(C1,C2,C).
3390 flatten_stuff((A;B),C) :- !,
3391 flatten_stuff(A,C1),
3392 flatten_stuff(B,C2),
3393 append(C1,C2,C).
3394 flatten_stuff((A,B),C) :- !,
3395 flatten_stuff(A,C1),
3396 flatten_stuff(B,C2),
3397 append(C1,C2,C).
3399 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
3400 flatten_stuff(X,[]).
3402 unify_stuff(AllInfo,[],[]).
3404 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
3405 H \== I,
3406 term_variables(H,HVars),
3407 term_variables(I,IVars),
3408 intersect_eq(HVars,IVars,SharedVars),
3409 check_safe_unif(H,I,SharedVars),
3410 variable_replacement(H,I,Repl),
3411 check_replacement(Repl),
3412 term_variables(Repl,ReplVars),
3413 list_difference_eq(ReplVars,HVars,LDiff),
3414 intersect_eq(AllInfo,LDiff,LDiff2),
3415 LDiff2 == [],
3416 H = I,
3417 unify_stuff(AllInfo,RInfo,ROS),!.
3419 unify_stuff(AllInfo,X,[Y|ROS]) :-
3420 unify_stuff(AllInfo,X,ROS).
3422 unify_stuff(AllInfo,[Y|RInfo],X) :-
3423 unify_stuff(AllInfo,RInfo,X).
3425 check_safe_unif(H,I,SV) :- var(H), !, var(I),
3426 ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
3427 H == I
3428 ;
3429 true
3430 ).
3432 check_safe_unif([],[],SV) :- !.
3433 check_safe_unif([H|Hs],[I|Is],SV) :- !,
3434 check_safe_unif(H,I,SV),!,
3435 check_safe_unif(Hs,Is,SV).
3437 check_safe_unif(H,I,SV) :-
3438 nonvar(H),!,nonvar(I),
3439 H =.. [F|HA],
3440 I =.. [F|IA],
3441 check_safe_unif(HA,IA,SV).
3443 check_safe_unif2(H,I) :- var(H), !.
3445 check_safe_unif2([],[]) :- !.
3446 check_safe_unif2([H|Hs],[I|Is]) :- !,
3447 check_safe_unif2(H,I),!,
3448 check_safe_unif2(Hs,Is).
3450 check_safe_unif2(H,I) :-
3451 nonvar(H),!,nonvar(I),
3452 H =.. [F|HA],
3453 I =.. [F|IA],
3454 check_safe_unif2(HA,IA).
3457 check_replacement(Repl) :-
3458 check_replacement(Repl,FirstVars),
3459 sort(FirstVars,Sorted),
3460 length(Sorted,L),!,
3461 length(FirstVars,L).
3463 check_replacement([],[]).
3464 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
3467 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
3468 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
3469 append(ID2,ID1,IDs),
3470 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
3471 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
3472 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
3473 copy_with_variable_replacement(G,FG,Repl),
3474 extract_explicit_matchings(FG,FG2),
3475 negate_b(FG2,NotFG),
3476 copy_with_variable_replacement(MPCond,FMPCond,Repl),
3477 ( check_safe_unif2(FH,FH2), FH=FH2 ->
3478 FailCond = [(NotFG;FMPCond)]
3479 ;
3480 % in this case, not much can be done
3481 % e.g. c(f(...)), c(g(...)) <=> ...
3482 FailCond = [chr_pp_void_info]
3483 ).
3487 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
3488 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
3489 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
3490 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
3491 Cond = (chr_pp_not_in_store(H);Cond1),
3492 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
3495 extract_explicit_matchings(A=B) :-
3496 var(A), var(B), !, A=B.
3497 extract_explicit_matchings(A==B) :-
3498 var(A), var(B), !, A=B.
3500 extract_explicit_matchings((A,B),D) :- !,
3501 ( extract_explicit_matchings(A) ->
3502 extract_explicit_matchings(B,D)
3503 ;
3504 D = (A,E),
3505 extract_explicit_matchings(B,E)
3506 ).
3507 extract_explicit_matchings(A,D) :- !,
3508 ( extract_explicit_matchings(A) ->
3509 D = true
3510 ;
3511 D = A
3512 ).
3517 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3518 % TYPE INFORMATION
3519 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3521 :- chr_constraint
3522 type_definition/2,
3523 type_alias/2,
3524 constraint_type/2,
3525 get_type_definition/2,
3526 get_constraint_type/2,
3527 add_type_information/3.
3530 :- chr_option(mode,type_definition(?,?)).
3531 :- chr_option(mode,type_alias(?,?)).
3532 :- chr_option(mode,constraint_type(+,+)).
3533 :- chr_option(mode,add_type_information(+,+,?)).
3534 :- chr_option(type_declaration,add_type_information(list,list,any)).
3536 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3537 % Consistency checks of type aliases
3539 type_alias(T,T2) <=>
3540 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3541 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
3542 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
3544 type_alias(T1,A1), type_alias(T2,A2) <=>
3545 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
3546 \+ (T1\=T2) |
3547 copy_term_nat(T1,T1_),
3548 copy_term_nat(T2,T2_),
3549 T1_ = T2_,
3550 chr_error(type_error,
3551 'Ambiguous type aliases: you have defined \n "~w"\n "~w"\n resulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]).
3553 type_alias(T,B) \ type_alias(X,T2) <=>
3554 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3555 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
3556 chr_info(type_information,'Inferring "~w" from "~w" and "~w".\n',[X2==D1,X==T2,T==B]),
3557 type_alias(X2,D1).
3559 oneway_unification(X,Y) :-
3560 term_variables(X,XVars),
3561 chr_runtime:lockv(XVars),
3562 X=Y,
3563 chr_runtime:unlockv(XVars).
3565 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3566 % Consistency checks of type definitions
3568 type_definition(T1,_), type_definition(T2,_)
3569 <=>
3570 functor(T1,F,A), functor(T2,F,A)
3571 |
3572 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
3574 type_definition(T1,_), type_alias(T2,_)
3575 <=>
3576 functor(T1,F,A), functor(T2,F,A)
3577 |
3578 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
3580 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3581 % get_type_definition
3583 get_type_definition(T,Def) <=> \+ ground(T) |
3584 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
3586 type_alias(T,D) \ get_type_definition(T2,Def) <=>
3587 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3588 copy_term_nat((T,D),(T1,D1)),T1=T2 |
3589 (get_type_definition(D1,Def) ->
3590 true
3591 ;
3592 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
3593 ).
3595 type_definition(T,D) \ get_type_definition(T2,Def) <=>
3596 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3597 copy_term_nat((T,D),(T1,D1)),T1=T2 | Def = D1.
3598 get_type_definition(T2,Def) <=>
3599 builtin_type(T2,_,_) | Def = [T2].
3600 get_type_definition(X,Y) <=> fail.
3602 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3603 % get_constraint_type
3605 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
3606 get_constraint_type(_,_) <=> fail.
3608 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3609 % add_type_information
3611 add_type_information([],[],T) <=> T=true.
3613 constraint_mode(F/A,Modes)
3614 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
3615 functor(Head,F,A) |
3616 Head =.. [_|Args],
3617 RealHead =.. [_|RealArgs],
3618 add_mode_info(Modes,Args,ModeInfo),
3619 TypeInfo = (ModeInfo, TI),
3620 (get_constraint_type(F/A,Types) ->
3621 types2condition(Types,Args,RealArgs,Modes,TI2),
3622 list2conj(TI2,ConjTI),
3623 TI = (ConjTI,RTI),
3624 add_type_information(R,RRH,RTI)
3625 ;
3626 add_type_information(R,RRH,TI)
3627 ).
3630 add_type_information([Head|R],_,TypeInfo) <=>
3631 functor(Head,F,A),
3632 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
3635 add_mode_info([],[],true).
3636 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
3637 MI = (ground(A), ModeInfo),
3638 add_mode_info(Modes,Args,ModeInfo).
3639 add_mode_info([M|Modes],[A|Args],MI) :-
3640 add_mode_info(Modes,Args,MI).
3643 types2condition([],[],[],[],[]).
3644 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
3645 ( get_type_definition(Type,Def) ->
3646 type2condition(Def,Arg,RealArg,TC),
3647 ( Mode \== (+) ->
3648 TC_ = [(\+ ground(Arg))|TC]
3649 ;
3650 TC_ = TC
3651 ),
3652 list2disj(TC_,DisjTC),
3653 TI = [DisjTC|RTI],
3654 types2condition(Types,Args,RAs,Modes,RTI)
3655 ;
3656 chr_error(internal,'Undefined type ~w.\n',[Type])
3658 ).
3660 type2condition([],Arg,_,[]).
3661 type2condition([Def|Defs],Arg,RealArg,TC) :-
3662 ( builtin_type(Def,Arg,C) ->
3663 true
3664 ;
3665 real_type(Def,Arg,RealArg,C)
3666 ),
3667 item2list(C,LC),
3668 type2condition(Defs,Arg,RealArg,RTC),
3669 append(LC,RTC,TC).
3671 item2list([],[]) :- !.
3672 item2list([X|Y],[X|Y]) :- !.
3673 item2list(N,L) :- L = [N].
3675 builtin_type(X,Arg,true) :- var(X),!.
3676 builtin_type(X,Arg,Goal) :- builtin_type_nonvar(X,Arg,Goal).
3678 builtin_type_nonvar(any,Arg,true).
3679 builtin_type_nonvar(dense_int,Arg,(integer(Arg),Arg>=0)).
3680 builtin_type_nonvar(int,Arg,integer(Arg)).
3681 builtin_type_nonvar(number,Arg,number(Arg)).
3682 builtin_type_nonvar(float,Arg,float(Arg)).
3683 builtin_type_nonvar(natural,Arg,(integer(Arg),Arg>=0)).
3685 real_type(Def,Arg,RealArg,C) :-
3686 ( nonvar(Def) ->
3687 functor(Def,F,A),
3688 ( A == 0 ->
3689 C = (Arg = F)
3690 ;
3691 Def =.. [_|TArgs],
3692 length(AA,A),
3693 Def2 =.. [F|AA],
3694 ( var(RealArg) ->
3695 C = functor(Arg,F,A)
3696 ;
3697 ( functor(RealArg,F,A) ->
3698 RealArg =.. [_|RAArgs],
3699 nested_types(TArgs,AA,RAArgs,ACond),
3700 C = (functor(Arg,F,A),Arg=Def2,ACond)
3701 ;
3702 C = functor(Arg,F,A)
3703 )
3704 )
3705 )
3706 ;
3707 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
3708 ).
3709 nested_types([],[],[],true).
3710 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
3711 ( get_type_definition(T,Def) ->
3712 type2condition(Def,A,RealA,TC),
3713 list2disj(TC,DisjTC),
3714 C = (DisjTC, RC),
3715 nested_types(RT,RA,RRA,RC)
3716 ;
3717 chr_error(internal,'Undefined type ~w inside type definition.\n',[T])
3718 ).
3720 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3721 % Static type checking
3722 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3723 % Checks head constraints and CHR constraint calls in bodies.
3724 %
3725 % TODO:
3726 % - type clashes involving built-in types
3727 % - Prolog built-ins in guard and body
3728 % - indicate position in terms in error messages
3729 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3730 :- chr_constraint
3731 static_type_check/0.
3733 rule(_,Rule), static_type_check
3734 ==>
3735 copy_term_nat(Rule,RuleCopy),
3736 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
3737 (
3738 catch(
3739 ( static_type_check_heads(Head1),
3740 static_type_check_heads(Head2),
3741 conj2list(Body,GoalList),
3742 static_type_check_body(GoalList)
3743 ),
3744 type_error(Error),
3745 ( Error = invalid_functor(Src,Term,Type) ->
3746 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
3747 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
3748 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
3749 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
3750 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
3751 )
3752 ),
3753 fail % cleanup constraints
3754 ;
3755 true
3756 ).
3759 static_type_check <=> true.
3761 static_type_check_heads([]).
3762 static_type_check_heads([Head|Heads]) :-
3763 static_type_check_head(Head),
3764 static_type_check_heads(Heads).
3766 static_type_check_head(Head) :-
3767 functor(Head,F,A),
3768 ( get_constraint_type(F/A,Types) ->
3769 Head =..[_|Args],
3770 maplist(static_type_check_term(head(Head)),Args,Types)
3771 ; % no type declared
3772 true
3773 ).
3775 static_type_check_body([]).
3776 static_type_check_body([Goal|Goals]) :-
3777 functor(Goal,F,A),
3778 ( get_constraint_type(F/A,Types) ->
3779 Goal =..[_|Args],
3780 maplist(static_type_check_term(body(Goal)),Args,Types)
3781 ; % not a CHR constraint or no type declared
3782 true
3783 ),
3784 static_type_check_body(Goals).
3786 :- chr_constraint static_type_check_term/3.
3788 static_type_check_term(Src,Term,Type)
3789 <=>
3790 var(Term)
3791 |
3792 static_type_check_var(Src,Term,Type).
3793 static_type_check_term(Src,Term,Type)
3794 <=>
3795 builtin_type_nonvar(Type,Term,Goal)
3796 |
3797 ( call(Goal) ->
3798 true
3799 ;
3800 throw(type_error(invalid_funtor(Src,Term,Type)))
3801 ).
3802 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
3803 <=>
3804 functor(Type,F,A),
3805 functor(AType,F,A)
3806 |
3807 copy_term_nat(AType-ADef,Type-Def),
3808 static_type_check_term(Src,Term,Def).
3810 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
3811 <=>
3812 functor(Type,F,A),
3813 functor(AType,F,A)
3814 |
3815 copy_term_nat(AType-ADef,Type-Variants),
3816 functor(Term,TF,TA),
3817 ( member(Variant,Variants), functor(Variant,TF,TA) ->
3818 Term =.. [_|Args],
3819 Variant =.. [_|Types],
3820 maplist(static_type_check_term(Src),Args,Types)
3821 ;
3822 throw(type_error(invalid_functor(Src,Term,Type)))
3823 ).
3825 static_type_check_term(Src,Term,Type)
3826 <=>
3827 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
3829 :- chr_constraint static_type_check_var/3.
3831 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
3832 <=>
3833 functor(AType,F,A),
3834 functor(Type,F,A)
3835 |
3836 copy_term_nat(AType-ADef,Type-Def),
3837 static_type_check_var(Src,Var,Def).
3839 static_type_check_var(Src,Var,Type)
3840 <=>
3841 builtin_type_nonvar(Type,_,_)
3842 |
3843 true.
3846 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
3847 <=>
3848 Type1 \== Type2
3849 |
3850 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
3852 format_src(head(Head)) :- format('head ~w',[Head]).
3853 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
3855 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3856 % Dynamic type checking
3857 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3859 :- chr_constraint
3860 dynamic_type_check/0,
3861 dynamic_type_check_clauses/1,
3862 get_dynamic_type_check_clauses/1.
3864 generate_dynamic_type_check_clauses(Clauses) :-
3865 dynamic_type_check,
3866 get_dynamic_type_check_clauses(Clauses0),
3867 append(Clauses0,
3868 [('$dynamic_type_check'(Type,Term) :-
3869 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
3870 )],
3871 Clauses).
3873 type_definition(T,D), dynamic_type_check
3874 ==>
3875 copy_term_nat(T-D,Type-Definition),
3876 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
3877 dynamic_type_check_clauses(DynamicChecks).
3878 type_alias(A,B), dynamic_type_check
3879 ==>
3880 copy_term_nat(A-B,Alias-Body),
3881 dynamic_type_check_alias_clause(Alias,Body,Clause),
3882 dynamic_type_check_clauses([Clause]).
3884 dynamic_type_check <=>
3885 findall(('$dynamic_type_check'(Type,Term) :- !, Goal),builtin_type_nonvar(Type,Term,Goal), BuiltinChecks),
3886 dynamic_type_check_clauses(BuiltinChecks).
3888 dynamic_type_check_clause(T,DC,Clause) :-
3889 copy_term(T-DC,Type-DefinitionClause),
3890 functor(DefinitionClause,F,A),
3891 functor(Term,F,A),
3892 DefinitionClause =.. [_|DCArgs],
3893 Term =.. [_|TermArgs],
3894 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
3895 list2conj(RecursiveCallList,RecursiveCalls),
3896 Clause = (
3897 '$dynamic_type_check'(Type,Term) :- !,
3898 RecursiveCalls
3899 ).
3901 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
3902 Clause = (
3903 '$dynamic_type_check'(Alias,Term) :- !,
3904 '$dynamic_type_check'(Body,Term)
3905 ).
3907 dynamic_type_check_call(Type,Term,Call) :-
3908 ( nonvar(Type), builtin_type_nonvar(Type,Term,Goal) ->
3909 Call = when(nonvar(Term),Goal)
3910 ;
3911 Call = when(nonvar(Term),'$dynamic_type_check'(Type,Term))
3912 ).
3914 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
3915 <=>
3916 append(C1,C2,C),
3917 dynamic_type_check_clauses(C).
3919 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
3920 <=>
3921 Q = C.
3922 get_dynamic_type_check_clauses(Q)
3923 <=>
3924 Q = [].
3926 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3928 :- chr_constraint
3929 stored/3, % constraint,occurrence,(yes/no/maybe)
3930 stored_completing/3,
3931 stored_complete/3,
3932 is_stored/1,
3933 is_finally_stored/1,
3934 check_all_passive/2.
3936 :- chr_option(mode,stored(+,+,+)).
3937 :- chr_option(type_declaration,stored(any,int,storedinfo)).
3938 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
3939 :- chr_option(mode,stored_complete(+,+,+)).
3940 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
3941 :- chr_option(mode,guard_list(+,+,+,+)).
3942 :- chr_option(mode,check_all_passive(+,+)).
3944 % change yes in maybe when yes becomes passive
3945 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
3946 stored(C,O,yes), stored_complete(C,RO,Yesses)
3947 <=> O < RO | NYesses is Yesses - 1,
3948 stored(C,O,maybe), stored_complete(C,RO,NYesses).
3949 % change yes in maybe when not observed
3950 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
3951 <=> O < RO |
3952 NYesses is Yesses - 1,
3953 stored(C,O,maybe), stored_complete(C,RO,NYesses).
3955 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
3956 ==> RO =< MO2 | % C2 is never stored
3957 passive(RuleNb,ID).
3962 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3964 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
3965 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
3966 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
3968 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
3969 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
3970 check_all_passive(RuleNb,IDs2).
3972 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
3973 check_all_passive(RuleNb,IDs).
3975 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
3976 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
3978 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3980 % collect the storage information
3981 stored(C,O,yes) \ stored_completing(C,O,Yesses)
3982 <=> NO is O + 1, NYesses is Yesses + 1,
3983 stored_completing(C,NO,NYesses).
3984 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
3985 <=> NO is O + 1,
3986 stored_completing(C,NO,Yesses).
3988 stored(C,O,no) \ stored_completing(C,O,Yesses)
3989 <=> stored_complete(C,O,Yesses).
3990 stored_completing(C,O,Yesses)
3991 <=> stored_complete(C,O,Yesses).
3993 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
3994 O2 > O | passive(RuleNb,Id).
3996 % decide whether a constraint is stored
3997 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
3998 <=> RO =< MO | fail.
3999 is_stored(C) <=> true.
4001 % decide whether a constraint is suspends after occurrences
4002 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
4003 <=> RO =< MO | fail.
4004 is_finally_stored(C) <=> true.
4006 storage_analysis(Constraints) :-
4007 ( chr_pp_flag(storage_analysis,on) ->
4008 check_constraint_storages(Constraints)
4009 ;
4010 true
4011 ).
4013 check_constraint_storages([]).
4014 check_constraint_storages([C|Cs]) :-
4015 check_constraint_storage(C),
4016 check_constraint_storages(Cs).
4018 check_constraint_storage(C) :-
4019 get_max_occurrence(C,MO),
4020 check_occurrences_storage(C,1,MO).
4022 check_occurrences_storage(C,O,MO) :-
4023 ( O > MO ->
4024 stored_completing(C,1,0)
4025 ;
4026 check_occurrence_storage(C,O),
4027 NO is O + 1,
4028 check_occurrences_storage(C,NO,MO)
4029 ).
4031 check_occurrence_storage(C,O) :-
4032 get_occurrence(C,O,RuleNb,ID),
4033 ( is_passive(RuleNb,ID) ->
4034 stored(C,O,maybe)
4035 ;
4036 get_rule(RuleNb,PragmaRule),
4037 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
4038 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4039 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
4040 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4041 check_storage_head2(Head2,O,Heads1,Body)
4042 )
4043 ).
4045 check_storage_head1(Head,O,H1,H2,G) :-
4046 functor(Head,F,A),
4047 C = F/A,
4048 ( H1 == [Head],
4049 H2 == [],
4050 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
4051 Head =.. [_|L],
4052 no_matching(L,[]) ->
4053 stored(C,O,no)
4054 ;
4055 stored(C,O,maybe)
4056 ).
4058 no_matching([],_).
4059 no_matching([X|Xs],Prev) :-
4060 var(X),
4061 \+ memberchk_eq(X,Prev),
4062 no_matching(Xs,[X|Prev]).
4064 check_storage_head2(Head,O,H1,B) :-
4065 functor(Head,F,A),
4066 C = F/A,
4067 ( %(
4068 (H1 \== [], B == true )
4069 %;
4070 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
4071 %)
4072 ->
4073 stored(C,O,maybe)
4074 ;
4075 stored(C,O,yes)
4076 ).
4078 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4080 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4081 %% ____ _ ____ _ _ _ _
4082 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
4083 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
4084 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
4085 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
4086 %% |_|
4088 constraints_code(Constraints,Clauses) :-
4089 (chr_pp_flag(reduced_indexing,on),
4090 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
4091 none_suspended_on_variables
4092 ;
4093 true
4094 ),
4095 constraints_code1(Constraints,L,[]),
4096 clean_clauses(L,Clauses).
4098 %===============================================================================
4099 :- chr_constraint constraints_code1/3.
4100 :- chr_option(mode,constraints_code1(+,+,+)).
4101 :- chr_option(type_declaration,constraints_code(list,any,any)).
4102 %-------------------------------------------------------------------------------
4103 constraints_code1([],L,T) <=> L = T.
4104 constraints_code1([C|RCs],L,T)
4105 <=>
4106 constraint_code(C,L,T1),
4107 constraints_code1(RCs,T1,T).
4108 %===============================================================================
4109 :- chr_constraint constraint_code/3.
4110 :- chr_option(mode,constraint_code(+,+,+)).
4111 %-------------------------------------------------------------------------------
4112 %% Generate code for a single CHR constraint
4113 constraint_code(Constraint, L, T)
4114 <=> true
4115 | ( (chr_pp_flag(debugable,on) ;
4116 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
4117 ( may_trigger(Constraint) ;
4118 get_allocation_occurrence(Constraint,AO),
4119 get_max_occurrence(Constraint,MO), MO >= AO ) )
4120 ->
4121 constraint_prelude(Constraint,Clause),
4122 L = [Clause | L1]
4123 ;
4124 L = L1
4125 ),
4126 Id = [0],
4127 occurrences_code(Constraint,1,Id,NId,L1,L2),
4128 gen_cond_attach_clause(Constraint,NId,L2,T).
4130 %===============================================================================
4131 %% Generate prelude predicate for a constraint.
4132 %% f(...) :- f/a_0(...,Susp).
4133 constraint_prelude(F/A, Clause) :-
4134 vars_susp(A,Vars,Susp,VarsSusp),
4135 Head =.. [ F | Vars],
4136 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
4137 build_head(F,A,[0],VarsSusp,Delegate),
4138 ( chr_pp_flag(debugable,on) ->
4139 use_auxiliary_predicate(insert_constraint_internal,F/A),
4140 generate_insert_constraint_call(F/A,Susp,InsertCall),
4141 make_name('attach_',F/A,AttachF),
4142 AttachCall =.. [AttachF,Vars2,Susp],
4143 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
4144 insert_constraint_internal_constraint_goal(F/A, Stored, Vars2, Susp, Continuation, F, Vars,InsertGoal),
4146 ( get_constraint_type(F/A,ArgTypeList) ->
4147 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
4148 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
4149 ;
4150 DynamicTypeChecks = true
4151 ),
4153 Clause =
4154 ( Head :-
4155 DynamicTypeChecks,
4156 InsertGoal, % insert_constraint_internal(Stored,Vars2,Susp,Continuation,F,Vars),
4157 InsertCall,
4158 AttachCall,
4159 Inactive,
4160 'chr debug_event'(insert(Head#Susp)),
4161 (
4162 'chr debug_event'(call(Susp)),
4163 Delegate
4164 ;
4165 'chr debug_event'(fail(Susp)), !,
4166 fail
4167 ),
4168 (
4169 'chr debug_event'(exit(Susp))
4170 ;
4171 'chr debug_event'(redo(Susp)),
4172 fail
4173 )
4174 )
4175 ; get_allocation_occurrence(F/A,0) ->
4176 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
4177 Inactive = (arg(2,Susp,Mutable), 'chr update_mutable'(inactive,Mutable)),
4178 Clause = ( Head :- Goal, Inactive, Delegate )
4179 ;
4180 Clause = ( Head :- Delegate )
4181 ).
4183 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
4184 ( may_trigger(F/A) ->
4185 get_target_module(Mod),
4186 build_head(F,A,[0],VarsSusp,Delegate),
4187 Goal = Mod:Delegate
4188 ;
4189 Goal = true
4190 ).
4192 %===============================================================================
4193 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
4194 %-------------------------------------------------------------------------------
4195 has_active_occurrence(C) <=> has_active_occurrence(C,1).
4197 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
4198 O > MO | fail.
4199 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
4200 has_active_occurrence(C,O) <=>
4201 NO is O + 1,
4202 has_active_occurrence(C,NO).
4203 has_active_occurrence(C,O) <=> true.
4204 %===============================================================================
4206 gen_cond_attach_clause(F/A,Id,L,T) :-
4207 ( is_finally_stored(F/A) ->
4208 get_allocation_occurrence(F/A,AllocationOccurrence),
4209 get_max_occurrence(F/A,MaxOccurrence),
4210 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
4211 ( only_ground_indexed_arguments(F/A) ->
4212 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
4213 ;
4214 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
4215 )
4216 ; vars_susp(A,Args,Susp,AllArgs),
4217 gen_uncond_attach_goal(F/A,Susp,Body,_)
4218 ),
4219 build_head(F,A,Id,AllArgs,Head),
4220 Clause = ( Head :- Body ),
4221 L = [Clause | T]
4222 ;
4223 L = T
4224 ).
4226 :- chr_constraint
4227 use_auxiliary_predicate/1,
4228 use_auxiliary_predicate/2,
4229 is_used_auxiliary_predicate/1,
4230 is_used_auxiliary_predicate/2.
4232 :- chr_option(mode,use_auxiliary_predicate(+)).
4233 :- chr_option(mode,use_auxiliary_predicate(+,+)).
4235 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
4237 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
4239 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
4241 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
4243 is_used_auxiliary_predicate(P) <=> fail.
4245 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
4246 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
4248 is_used_auxiliary_predicate(P,C) <=> fail.
4251 % only called for constraints with
4252 % at least one
4253 % non-ground indexed argument
4254 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
4255 vars_susp(A,Args,Susp,AllArgs),
4256 make_suspension_continuation_goal(F/A,AllArgs,Closure),
4257 make_name('attach_',F/A,AttachF),
4258 Attach =.. [AttachF,Vars,Susp],
4259 FTerm =.. [F|Args],
4260 generate_insert_constraint_call(F/A,Susp,InsertCall),
4261 use_auxiliary_predicate(insert_constraint_internal,F/A),
4262 insert_constraint_internal_constraint_goal(F/A, Stored, Vars, Susp, Closure, F, Args,InsertGoal),
4263 use_auxiliary_predicate(activate_constraint,F/A),
4264 ( may_trigger(F/A) ->
4265 activate_constraint_goal(F/A,Stored,Vars,Susp,_,ActivateGoal),
4266 Goal =
4267 (
4268 ( var(Susp) ->
4269 InsertGoal % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
4270 ;
4271 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
4272 ),
4273 ( Stored == yes ->
4274 InsertCall,
4275 Attach
4276 ;
4277 true
4278 )
4279 )
4280 ;
4281 Goal =
4282 (
4283 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
4284 InsertCall,
4285 Attach
4286 )
4287 ).
4289 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
4290 vars_susp(A,Args,Susp,AllArgs),
4291 make_suspension_continuation_goal(F/A,AllArgs,Cont),
4292 ( \+ only_ground_indexed_arguments(F/A) ->
4293 make_name('attach_',F/A,AttachF),
4294 Attach =.. [AttachF,Vars,Susp]
4295 ;
4296 Attach = true
4297 ),
4298 FTerm =.. [F|Args],
4299 generate_insert_constraint_call(F/A,Susp,InsertCall),
4300 use_auxiliary_predicate(insert_constraint_internal,F/A),
4301 insert_constraint_internal_constraint_goal(F/A, _, Vars, Susp, Cont, F, Args,InsertInternalGoal),
4302 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
4303 Goal =
4304 (
4305 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
4306 InsertCall
4307 )
4308 ;
4309 Goal =
4310 (
4311 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
4312 InsertCall,
4313 Attach
4314 )
4315 ).
4317 gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
4318 ( \+ only_ground_indexed_arguments(FA) ->
4319 make_name('attach_',FA,AttachF),
4320 Attach =.. [AttachF,Vars,Susp]
4321 ;
4322 Attach = true
4323 ),
4324 generate_insert_constraint_call(FA,Susp,InsertCall),
4325 ( chr_pp_flag(late_allocation,on) ->
4326 use_auxiliary_predicate(activate_constraint,FA),
4327 activate_constraint_goal(FA,Stored,Vars,Susp,Generation,ActivateGoal),
4328 AttachGoal =
4329 (
4330 ActivateGoal,
4331 ( Stored == yes ->
4332 InsertCall,
4333 Attach
4334 ;
4335 true
4336 )
4337 )
4338 ;
4339 use_auxiliary_predicate(activate_constraint,FA),
4340 activate_constraint_goal(FA,Stored,Vars,Susp,Generation,AttachGoal)
4341 % AttachGoal =
4342 % (
4343 % activate_constraint(Stored,Vars, Susp, Generation)
4344 % )
4345 ).
4347 %-------------------------------------------------------------------------------
4348 :- chr_constraint occurrences_code/6.
4349 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
4350 %-------------------------------------------------------------------------------
4351 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
4352 <=> O > MO
4353 | NId = Id, L = T.
4354 occurrences_code(C,O,Id,NId,L,T)
4355 <=>
4356 occurrence_code(C,O,Id,Id1,L,L1),
4357 NO is O + 1,
4358 occurrences_code(C,NO,Id1,NId,L1,T).
4359 %-------------------------------------------------------------------------------
4360 :- chr_constraint occurrence_code/6.
4361 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
4362 %-------------------------------------------------------------------------------
4363 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
4364 <=> NId = Id, L = T.
4365 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
4366 <=> true |
4367 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
4368 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4369 NId = Id,
4370 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
4371 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4372 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
4373 inc_id(Id,NId),
4374 ( unconditional_occurrence(C,O) ->
4375 L1 = T
4376 ;
4377 gen_alloc_inc_clause(C,O,Id,L1,T)
4378 )
4379 ).
4381 occurrence_code(C,O,_,_,_,_)
4382 <=>
4383 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
4384 %-------------------------------------------------------------------------------
4386 %% Generate code based on one removed head of a CHR rule
4387 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4388 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4389 Rule = rule(_,Head2,_,_),
4390 ( Head2 == [] ->
4391 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4392 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
4393 ;
4394 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
4395 ).
4397 %% Generate code based on one persistent head of a CHR rule
4398 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4399 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4400 Rule = rule(Head1,_,_,_),
4401 ( Head1 == [] ->
4402 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4403 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
4404 ;
4405 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
4406 ).
4408 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
4409 vars_susp(A,Vars,Susp,VarsSusp),
4410 build_head(F,A,Id,VarsSusp,Head),
4411 inc_id(Id,IncId),
4412 build_head(F,A,IncId,VarsSusp,CallHead),
4413 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConditionalAlloc),
4414 Clause =
4415 (
4416 Head :-
4417 ConditionalAlloc,
4418 CallHead
4419 ),
4420 L = [Clause|T].
4422 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
4423 gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
4424 ConstraintAllocationGoal =
4425 ( var(Susp) ->
4426 UncondConstraintAllocationGoal
4427 ;
4428 true
4429 ).
4430 gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
4431 ( may_trigger(F/A) ->
4432 build_head(F,A,[0],VarsSusp,Term),
4433 get_target_module(Mod),
4434 Cont = Mod : Term
4435 ;
4436 Cont = true
4437 ),
4438 FTerm =.. [F|Vars],
4439 use_auxiliary_predicate(allocate_constraint,F/A),
4440 allocate_constraint_goal(F/A, Cont, Susp, F, Vars, ConstraintAllocationGoal).
4442 gen_occ_allocation(FA,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal) :-
4443 get_allocation_occurrence(FA,AO),
4444 ( chr_pp_flag(debugable,off), O == AO ->
4445 ( may_trigger(FA) ->
4446 gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
4447 ;
4448 gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
4449 )
4450 ;
4451 ConstraintAllocationGoal = true
4452 ).
4453 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4455 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4456 %
4457 % Reorders guard goals with respect to partner constraint retrieval goals and
4458 % active constraint. Returns combined partner retrieval + guard goal.
4460 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
4461 ( chr_pp_flag(guard_via_reschedule,on) ->
4462 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4463 list2conj(ScheduleSkeleton,GoalSkeleton)
4464 ;
4465 length(Retrievals,RL), length(LookupSkeleton,RL),
4466 length(GuardList,GL), length(GuardListSkeleton,GL),
4467 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
4468 list2conj(GoalListSkeleton,GoalSkeleton)
4469 ).
4470 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
4471 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
4472 initialize_unit_dictionary(ActiveHead,Dict),
4473 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
4474 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
4475 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
4476 dependency_reorder(Units,NUnits),
4477 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4478 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
4479 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
4481 wrap_in_functor(Functor,X,Term) :-
4482 Term =.. [Functor,X].
4484 wrappedunits2lists([],[],[],[]).
4485 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
4486 Ss = [GoalCopy|TSs],
4487 ( WrappedGoal = lookup(Goal) ->
4488 Ls = [GoalCopy|TLs],
4489 Gs = TGs
4490 ; WrappedGoal = guard(Goal) ->
4491 Gs = [N-GoalCopy|TGs],
4492 Ls = TLs
4493 ),
4494 wrappedunits2lists(Units,TGs,TLs,TSs).
4496 guard_splitting(Rule,SplitGuardList) :-
4497 Rule = rule(H1,H2,Guard,_),
4498 append(H1,H2,Heads),
4499 conj2list(Guard,GuardList),
4500 term_variables(Heads,HeadVars),
4501 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
4502 append(GuardPrefix,[RestGuard],SplitGuardList),
4503 term_variables(RestGuardList,GuardVars1),
4504 % variables that are declared to be ground don't need to be locked
4505 ground_vars(Heads,GroundVars),
4506 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
4507 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
4508 ( chr_pp_flag(guard_locks,on),
4509 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
4510 once(pairup(Locks,Unlocks,LocksUnlocks))
4511 ;
4512 Locks = [],
4513 Unlocks = []
4514 ),
4515 list2conj(Locks,LockPhase),
4516 list2conj(Unlocks,UnlockPhase),
4517 list2conj(RestGuardList,RestGuard1),
4518 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
4520 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
4521 Rule = rule(_,_,_,Body),
4522 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
4523 my_term_copy(Body,VarDict2,BodyCopy).
4526 split_off_simple_guard_new([],_,[],[]).
4527 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
4528 ( simple_guard_new(G,VarDict) ->
4529 S = [G|Ss],
4530 split_off_simple_guard_new(Gs,VarDict,Ss,C)
4531 ;
4532 S = [],
4533 C = [G|Gs]
4534 ).
4536 % simple guard: cheap and benign (does not bind variables)
4537 simple_guard_new(G,Vars) :-
4538 binds_b(G,BoundVars),
4539 \+ (( member(V,BoundVars),
4540 memberchk_eq(V,Vars)
4541 )).
4543 dependency_reorder(Units,NUnits) :-
4544 dependency_reorder(Units,[],NUnits).
4546 dependency_reorder([],Acc,Result) :-
4547 reverse(Acc,Result).
4549 dependency_reorder([Unit|Units],Acc,Result) :-
4550 Unit = unit(_GID,_Goal,Type,GIDs),
4551 ( Type == fixed ->
4552 NAcc = [Unit|Acc]
4553 ;
4554 dependency_insert(Acc,Unit,GIDs,NAcc)
4555 ),
4556 dependency_reorder(Units,NAcc,Result).
4558 dependency_insert([],Unit,_,[Unit]).
4559 dependency_insert([X|Xs],Unit,GIDs,L) :-
4560 X = unit(GID,_,_,_),
4561 ( memberchk(GID,GIDs) ->
4562 L = [Unit,X|Xs]
4563 ;
4564 L = [X | T],
4565 dependency_insert(Xs,Unit,GIDs,T)
4566 ).
4568 build_units(Retrievals,Guard,InitialDict,Units) :-
4569 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
4570 build_guard_units(Guard,N,Dict,Tail).
4572 build_retrieval_units([],N,N,Dict,Dict,L,L).
4573 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
4574 term_variables(U,Vs),
4575 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
4576 L = [unit(N,U,fixed,GIDs)|L1],
4577 N1 is N + 1,
4578 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
4580 initialize_unit_dictionary(Term,Dict) :-
4581 term_variables(Term,Vars),
4582 pair_all_with(Vars,0,Dict).
4584 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
4585 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4586 ( lookup_eq(Dict,V,GID) ->
4587 ( (GID == This ; memberchk(GID,GIDs) ) ->
4588 GIDs1 = GIDs
4589 ;
4590 GIDs1 = [GID|GIDs]
4591 ),
4592 Dict1 = Dict
4593 ;
4594 Dict1 = [V - This|Dict],
4595 GIDs1 = GIDs
4596 ),
4597 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4599 build_guard_units(Guard,N,Dict,Units) :-
4600 ( Guard = [Goal] ->
4601 Units = [unit(N,Goal,fixed,[])]
4602 ; Guard = [Goal|Goals] ->
4603 term_variables(Goal,Vs),
4604 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
4605 Units = [unit(N,Goal,movable,GIDs)|RUnits],
4606 N1 is N + 1,
4607 build_guard_units(Goals,N1,NDict,RUnits)
4608 ).
4610 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
4611 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4612 ( lookup_eq(Dict,V,GID) ->
4613 ( (GID == This ; memberchk(GID,GIDs) ) ->
4614 GIDs1 = GIDs
4615 ;
4616 GIDs1 = [GID|GIDs]
4617 ),
4618 Dict1 = [V - This|Dict]
4619 ;
4620 Dict1 = [V - This|Dict],
4621 GIDs1 = GIDs
4622 ),
4623 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4625 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4627 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4628 %% ____ _ ____ _ _
4629 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
4630 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
4631 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
4632 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
4633 %%
4634 %% _ _ _ ___ __
4635 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
4636 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
4637 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
4638 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
4639 %% |_|
4640 :- chr_constraint
4641 functional_dependency/4,
4642 get_functional_dependency/4.
4644 :- chr_option(mode,functional_dependency(+,+,?,?)).
4646 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
4647 <=>
4648 RuleNb > 1, AO > O
4649 |
4650 functional_dependency(C,1,Pattern,Key).
4652 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
4653 <=>
4654 RuleNb2 >= RuleNb1
4655 |
4656 QPattern = Pattern, QKey = Key.
4657 get_functional_dependency(_,_,_,_)
4658 <=>
4659 fail.
4661 functional_dependency_analysis(Rules) :-
4662 ( chr_pp_flag(functional_dependency_analysis,on) ->
4663 functional_dependency_analysis_main(Rules)
4664 ;
4665 true
4666 ).
4668 functional_dependency_analysis_main([]).
4669 functional_dependency_analysis_main([PRule|PRules]) :-
4670 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
4671 functional_dependency(C,RuleNb,Pattern,Key)
4672 ;
4673 true
4674 ),
4675 functional_dependency_analysis_main(PRules).
4677 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
4678 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
4679 Rule = rule(H1,H2,Guard,_),
4680 ( H1 = [C1],
4681 H2 = [C2] ->
4682 true
4683 ; H1 = [C1,C2],
4684 H2 == [] ->
4685 true
4686 ),
4687 check_unique_constraints(C1,C2,Guard,RuleNb,List),
4688 term_variables(C1,Vs),
4689 \+ (
4690 member(V1,Vs),
4691 lookup_eq(List,V1,V2),
4692 memberchk_eq(V2,Vs)
4693 ),
4694 select_pragma_unique_variables(Vs,List,Key1),
4695 copy_term_nat(C1-Key1,Pattern-Key),
4696 functor(C1,F,A).
4698 select_pragma_unique_variables([],_,[]).
4699 select_pragma_unique_variables([V|Vs],List,L) :-
4700 ( lookup_eq(List,V,_) ->
4701 L = T
4702 ;
4703 L = [V|T]
4704 ),
4705 select_pragma_unique_variables(Vs,List,T).
4707 % depends on functional dependency analysis
4708 % and shape of rule: C1 \ C2 <=> true.
4709 set_semantics_rules(Rules) :-
4710 ( chr_pp_flag(set_semantics_rule,on) ->
4711 set_semantics_rules_main(Rules)
4712 ;
4713 true
4714 ).
4716 set_semantics_rules_main([]).
4717 set_semantics_rules_main([R|Rs]) :-
4718 set_semantics_rule_main(R),
4719 set_semantics_rules_main(Rs).
4721 set_semantics_rule_main(PragmaRule) :-
4722 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
4723 ( Rule = rule([C1],[C2],true,_),
4724 IDs = ids([ID1],[ID2]),
4725 \+ is_passive(RuleNb,ID1),
4726 functor(C1,F,A),
4727 get_functional_dependency(F/A,RuleNb,Pattern,Key),
4728 copy_term_nat(Pattern-Key,C1-Key1),
4729 copy_term_nat(Pattern-Key,C2-Key2),
4730 Key1 == Key2 ->
4731 passive(RuleNb,ID2)
4732 ;
4733 true
4734 ).
4736 check_unique_constraints(C1,C2,G,RuleNb,List) :-
4737 \+ any_passive_head(RuleNb),
4738 variable_replacement(C1-C2,C2-C1,List),
4739 copy_with_variable_replacement(G,OtherG,List),
4740 negate_b(G,NotG),
4741 once(entails_b(NotG,OtherG)).
4743 % checks for rules of the shape ...,C1,C2... (<|=)==> ...
4744 % where C1 and C2 are symmteric constraints
4745 symmetry_analysis(Rules) :-
4746 ( chr_pp_flag(check_unnecessary_active,off) ->
4747 true
4748 ;
4749 symmetry_analysis_main(Rules)
4750 ).
4752 symmetry_analysis_main([]).
4753 symmetry_analysis_main([R|Rs]) :-
4754 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
4755 Rule = rule(H1,H2,_,_),
4756 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
4757 ; H2 == [] ), H1 \== [] ->
4758 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
4759 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
4760 ;
4761 true
4762 ),
4763 symmetry_analysis_main(Rs).
4765 symmetry_analysis_heads([],[],_,_,_,_).
4766 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
4767 ( \+ is_passive(RuleNb,ID),
4768 member2(PreHs,PreIDs,PreH-PreID),
4769 \+ is_passive(RuleNb,PreID),
4770 variable_replacement(PreH,H,List),
4771 copy_with_variable_replacement(Rule,Rule2,List),
4772 identical_rules(Rule,Rule2) ->
4773 passive(RuleNb,ID)
4774 ;
4775 true
4776 ),
4777 symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
4779 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4781 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4782 %% ____ _ _ _ __ _ _ _
4783 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
4784 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
4785 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
4786 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
4787 %% |_|
4789 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
4790 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
4791 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
4792 build_head(F,A,Id,HeadVars,ClauseHead),
4793 get_constraint_mode(F/A,Mode),
4794 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
4796 guard_splitting(Rule,GuardList),
4797 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
4799 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
4801 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
4803 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
4804 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
4806 ( chr_pp_flag(debugable,on) ->
4807 Rule = rule(_,_,Guard,Body),
4808 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4809 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
4810 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
4811 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
4812 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4813 ;
4814 Cut = ActualCut
4815 ),
4816 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
4817 Clause = ( ClauseHead :-
4818 FirstMatching,
4819 RescheduledTest,
4820 Cut,
4821 SuspsDetachments,
4822 SuspDetachment,
4823 BodyCopy
4824 ),
4825 L = [Clause | T].
4827 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
4828 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
4830 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
4831 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
4832 list2conj(GoalList,Goal).
4834 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
4835 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
4836 ( var(Arg) ->
4837 ( lookup_eq(VarDict,Arg,OtherVar) ->
4838 ( Mode = (+) ->
4839 ( memberchk_eq(Arg,GroundVars) ->
4840 GoalList = [Var = OtherVar | RestGoalList],
4841 GroundVars1 = GroundVars
4842 ;
4843 GoalList = [Var == OtherVar | RestGoalList],
4844 GroundVars1 = [Arg|GroundVars]
4845 )
4846 ;
4847 GoalList = [Var == OtherVar | RestGoalList],
4848 GroundVars1 = GroundVars
4849 ),
4850 VarDict1 = VarDict
4851 ; VarDict1 = [Arg-Var | VarDict],
4852 GoalList = RestGoalList,
4853 ( Mode = (+) ->
4854 GroundVars1 = [Arg|GroundVars]
4855 ;
4856 GroundVars1 = GroundVars
4857 )
4858 ),
4859 Pairs = Rest,
4860 RestModes = Modes
4861 ; atomic(Arg) ->
4862 ( Mode = (+) ->
4863 GoalList = [ Var = Arg | RestGoalList]
4864 ;
4865 GoalList = [ Var == Arg | RestGoalList]
4866 ),
4867 VarDict = VarDict1,
4868 GroundVars1 = GroundVars,
4869 Pairs = Rest,
4870 RestModes = Modes
4871 ; Mode == (+), is_ground(GroundVars,Arg) ->
4872 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
4873 GoalList = [ Var = ArgCopy | RestGoalList],
4874 VarDict = VarDict1,
4875 GroundVars1 = GroundVars,
4876 Pairs = Rest,
4877 RestModes = Modes
4878 ; Arg =.. [_|Args],
4879 functor(Arg,Fct,N),
4880 functor(Term,Fct,N),
4881 Term =.. [_|Vars],
4882 ( Mode = (+) ->
4883 GoalList = [ Var = Term | RestGoalList ]
4884 ;
4885 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
4886 ),
4887 pairup(Args,Vars,NewPairs),
4888 append(NewPairs,Rest,Pairs),
4889 replicate(N,Mode,NewModes),
4890 append(NewModes,Modes,RestModes),
4891 VarDict1 = VarDict,
4892 GroundVars1 = GroundVars
4893 ),
4894 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
4896 is_ground(GroundVars,Term) :-
4897 ( ground(Term) ->
4898 true
4899 ; compound(Term) ->
4900 Term =.. [_|Args],
4901 maplist(is_ground(GroundVars),Args)
4902 ;
4903 memberchk_eq(Term,GroundVars)
4904 ).
4906 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
4907 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
4909 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
4910 ( Heads = [_|_] ->
4911 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
4912 ;
4913 GoalList = [],
4914 Susps = [],
4915 VarDict = NVarDict,
4916 GroundVars = NGroundVars
4917 ).
4919 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
4920 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
4921 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
4922 functor(H,F,A),
4923 head_info(H,A,Vars,_,_,Pairs),
4924 get_store_type(F/A,StoreType),
4925 ( StoreType == default ->
4926 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
4927 create_get_mutable_ref(active,State,GetMutable),
4928 get_constraint_mode(F/A,Mode),
4929 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
4930 NPairs = Pairs,
4931 sbag_member_call(Susp,VarSusps,Sbag),
4932 ExistentialLookup = (
4933 ViaGoal,
4934 Sbag,
4935 Susp = Suspension, % not inlined
4936 GetMutable
4937 )
4938 ;
4939 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,State,ExistentialLookup,Susp,Pairs,NPairs),
4940 get_constraint_mode(F/A,Mode),
4941 filter_mode(NPairs,Pairs,Mode,NMode),
4942 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
4943 ),
4944 delay_phase_end(validate_store_type_assumptions,
4945 ( static_suspension_term(F/A,Suspension),
4946 get_static_suspension_term_field(state,F/A,Suspension,State),
4947 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
4948 )
4949 ),
4950 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
4951 append(NPairs,VarDict1,DA_), % order important here
4952 translate(GroundVars1,DA_,GroundVarsA),
4953 translate(GroundVars1,VarDict1,GroundVarsB),
4954 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
4955 Goal =
4956 (
4957 ExistentialLookup,
4958 DiffSuspGoals,
4959 MatchingGoal2
4960 ),
4961 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
4963 inline_matching_goal(A==B,true,GVA,GVB) :-
4964 memberchk_eq(A,GVA),
4965 memberchk_eq(B,GVB),
4966 A=B, !.
4968 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
4969 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
4970 inline_matching_goal(A,A2,GVA,GVB),
4971 inline_matching_goal(B,B2,GVA,GVB).
4972 inline_matching_goal(X,X,_,_).
4975 filter_mode([],_,_,[]).
4976 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
4977 ( Var == V ->
4978 Modes = [M|MT],
4979 filter_mode(Rest,R,Ms,MT)
4980 ;
4981 filter_mode([Arg-Var|Rest],R,Ms,Modes)
4982 ).
4984 check_unique_keys([],_).
4985 check_unique_keys([V|Vs],Dict) :-
4986 lookup_eq(Dict,V,_),
4987 check_unique_keys(Vs,Dict).
4989 % Generates tests to ensure the found constraint differs from previously found constraints
4990 % TODO: detect more cases where constraints need be different
4991 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
4992 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
4993 list2conj(DiffSuspGoalList,DiffSuspGoals).
4995 different_from_other_susps_(_,[],_,_,[]) :- !.
4996 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
4997 ( functor(Head,F,A), functor(PreHead,F,A),
4998 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
4999 \+ \+ PreHeadCopy = HeadCopy ->
5001 List = [Susp \== PreSusp | Tail]
5002 ;
5003 List = Tail
5004 ),
5005 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
5007 % passive_head_via(in,in,in,in,out,out,out) :-
5008 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
5009 functor(Head,F,A),
5010 get_constraint_index(F/A,Pos),
5011 common_variables(Head,PrevHeads,CommonVars),
5012 global_list_store_name(F/A,Name),
5013 GlobalGoal = nb_getval(Name,AllSusps),
5014 get_constraint_mode(F/A,ArgModes),
5015 ( Vars == [] ->
5016 Goal = GlobalGoal
5017 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
5018 translate([CommonVar],VarDict,[Var]),
5019 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
5020 Goal = AttrGoal
5021 ;
5022 translate(CommonVars,VarDict,Vars),
5023 gen_get_mod_constraints(F/A,Vars,ViaGoal,AttrGoal,AllSusps),
5024 Goal =
5025 ( ViaGoal ->
5026 AttrGoal
5027 ;
5028 GlobalGoal
5029 )
5030 ).
5032 common_variables(T,Ts,Vs) :-
5033 term_variables(T,V1),
5034 term_variables(Ts,V2),
5035 intersect_eq(V1,V2,Vs).
5037 gen_get_mod_constraints(FA,Vars,ViaGoal,AttrGoal,AllSusps) :-
5038 get_target_module(Mod),
5039 ( Vars = [A] ->
5040 ViaGoal = 'chr newvia_1'(A,V)
5041 ; Vars = [A,B] ->
5042 ViaGoal = 'chr newvia_2'(A,B,V)
5043 ;
5044 ViaGoal = 'chr newvia'(Vars,V)
5045 ),
5046 AttrGoal =
5047 ( get_attr(V,Mod,TSusps),
5048 TSuspsEqSusps % TSusps = Susps
5049 ),
5050 get_max_constraint_index(N),
5051 ( N == 1 ->
5052 TSuspsEqSusps = true, % TSusps = Susps
5053 AllSusps = TSusps
5054 ;
5055 TSuspsEqSusps = (TSusps = Susps),
5056 get_constraint_index(FA,Pos),
5057 make_attr(N,_,SuspsList,Susps),
5058 nth1(Pos,SuspsList,AllSusps)
5059 ).
5060 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
5061 get_target_module(Mod),
5062 AttrGoal =
5063 ( get_attr(Var,Mod,TSusps),
5064 TSuspsEqSusps % TSusps = Susps
5065 ),
5066 get_max_constraint_index(N),
5067 ( N == 1 ->
5068 TSuspsEqSusps = true, % TSusps = Susps
5069 AllSusps = TSusps
5070 ;
5071 TSuspsEqSusps = (TSusps = Susps),
5072 get_constraint_index(FA,Pos),
5073 make_attr(N,_,SuspsList,Susps),
5074 nth1(Pos,SuspsList,AllSusps)
5075 ).
5077 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
5078 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
5079 list2conj(GuardCopyList,GuardCopy).
5081 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
5082 Rule = rule(H,_,Guard,Body),
5083 conj2list(Guard,GuardList),
5084 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
5085 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
5087 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
5088 term_variables(RestGuardList,GuardVars),
5089 term_variables(RestGuardListCopyCore,GuardCopyVars),
5090 % variables that are declared to be ground don't need to be locked
5091 ground_vars(H,GroundVars),
5092 list_difference_eq(GuardVars,GroundVars,GuardVars_),
5093 ( chr_pp_flag(guard_locks,on),
5094 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
5095 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
5096 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
5097 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
5098 ),
5099 LocksUnlocks) ->
5100 once(pairup(Locks,Unlocks,LocksUnlocks))
5101 ;
5102 Locks = [],
5103 Unlocks = []
5104 ),
5105 list2conj(Locks,LockPhase),
5106 list2conj(Unlocks,UnlockPhase),
5107 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
5108 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
5109 my_term_copy(Body,VarDict2,BodyCopy).
5112 split_off_simple_guard([],_,[],[]).
5113 split_off_simple_guard([G|Gs],VarDict,S,C) :-
5114 ( simple_guard(G,VarDict) ->
5115 S = [G|Ss],
5116 split_off_simple_guard(Gs,VarDict,Ss,C)
5117 ;
5118 S = [],
5119 C = [G|Gs]
5120 ).
5122 % simple guard: cheap and benign (does not bind variables)
5123 simple_guard(G,VarDict) :-
5124 binds_b(G,Vars),
5125 \+ (( member(V,Vars),
5126 lookup_eq(VarDict,V,_)
5127 )).
5129 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
5130 ( is_stored(FA) ->
5131 ( (Id == [0];
5132 (get_allocation_occurrence(FA,AO),
5133 get_max_occurrence(FA,MO),
5134 MO < AO )),
5135 only_ground_indexed_arguments(FA), chr_pp_flag(late_allocation,on) ->
5136 SuspDetachment = true
5137 ;
5138 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
5139 ( chr_pp_flag(late_allocation,on) ->
5140 SuspDetachment =
5141 ( var(Susp) ->
5142 true
5143 ; UnCondSuspDetachment
5144 )
5145 ;
5146 SuspDetachment = UnCondSuspDetachment
5147 )
5148 )
5149 ;
5150 SuspDetachment = true
5151 ).
5153 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
5154 ( is_stored(FA) ->
5155 ( \+ only_ground_indexed_arguments(FA) ->
5156 make_name('detach_',FA,Fct),
5157 Detach =.. [Fct,Vars,Susp]
5158 ;
5159 Detach = true
5160 ),
5161 ( chr_pp_flag(debugable,on) ->
5162 DebugEvent = 'chr debug_event'(remove(Susp))
5163 ;
5164 DebugEvent = true
5165 ),
5166 generate_delete_constraint_call(FA,Susp,DeleteCall),
5167 use_auxiliary_predicate(remove_constraint_internal,FA),
5168 remove_constraint_goal(FA,Susp,Vars,Delete,RemoveInternalGoal),
5169 ( only_ground_indexed_arguments(FA) -> % are_none_suspended_on_variables ->
5170 SuspDetachment =
5171 (
5172 DebugEvent,
5173 RemoveInternalGoal,
5174 ( Delete = yes ->
5175 DeleteCall,
5176 Detach
5177 ;
5178 true
5179 )
5180 )
5181 ;
5182 SuspDetachment =
5183 (
5184 DebugEvent,
5185 RemoveInternalGoal,
5186 ( Delete == yes ->
5187 DeleteCall,
5188 Detach
5189 ;
5190 true
5191 )
5192 )
5193 )
5194 ;
5195 SuspDetachment = true
5196 ).
5198 gen_uncond_susps_detachments([],[],true).
5199 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
5200 functor(Term,F,A),
5201 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
5202 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
5204 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5206 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5207 %% ____ _ _ _ _
5208 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
5209 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
5210 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
5211 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
5212 %% |_| |___/
5214 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
5215 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
5216 Rule = rule(_Heads,Heads2,Guard,Body),
5218 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
5219 get_constraint_mode(F/A,Mode),
5220 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
5222 build_head(F,A,Id,HeadVars,ClauseHead),
5224 append(RestHeads,Heads2,Heads),
5225 append(OtherIDs,Heads2IDs,IDs),
5226 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
5228 guard_splitting(Rule,GuardList),
5229 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
5231 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
5232 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
5234 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
5236 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
5237 gen_uncond_susps_detachments(SortedSusps1,RestHeads,SuspsDetachments),
5238 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
5240 ( chr_pp_flag(debugable,on) ->
5241 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5242 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
5243 sort_by_key(Susps2,Susps2IDs,KeptSusps),
5244 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5245 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5246 instrument_goal((!),DebugTry,DebugApply,Cut)
5247 ;
5248 Cut = (!)
5249 ),
5251 Clause = ( ClauseHead :-
5252 FirstMatching,
5253 RescheduledTest,
5254 Cut,
5255 SuspsDetachments,
5256 SuspDetachment,
5257 BodyCopy
5258 ),
5259 L = [Clause | T].
5261 split_by_ids([],[],_,[],[]).
5262 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
5263 ( memberchk_eq(I,I1s) ->
5264 S1s = [S | R1s],
5265 S2s = R2s
5266 ;
5267 S1s = R1s,
5268 S2s = [S | R2s]
5269 ),
5270 split_by_ids(Is,Ss,I1s,R1s,R2s).
5272 split_by_ids([],[],_,[],[],[],[]).
5273 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
5274 ( memberchk_eq(I,I1s) ->
5275 S1s = [S | R1s],
5276 SI1s = [I|RSI1s],
5277 S2s = R2s,
5278 SI2s = RSI2s
5279 ;
5280 S1s = R1s,
5281 SI1s = RSI1s,
5282 S2s = [S | R2s],
5283 SI2s = [I|RSI2s]
5284 ),
5285 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
5286 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5289 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5290 %% ____ _ _ _ ____
5291 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
5292 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
5293 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
5294 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
5295 %% |_| |___/
5297 %% Genereate prelude + worker predicate
5298 %% prelude calls worker
5299 %% worker iterates over one type of removed constraints
5300 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
5301 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
5302 Rule = rule(Heads1,_,Guard,Body),
5303 append(Heads1,RestHeads2,Heads),
5304 append(IDs1,RestIDs,IDs),
5305 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
5306 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
5307 extend_id(Id,Id1),
5308 ( memberchk_eq(NID,IDs2) ->
5309 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
5310 ;
5311 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
5312 ),
5313 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
5314 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
5316 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
5317 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
5318 Heads = [Head|RHeads],
5319 inc_id(Id,Id1),
5320 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
5321 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
5322 ( memberchk_eq(ID,IDs2) ->
5323 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
5324 ;
5325 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
5326 ).
5328 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5329 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
5330 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5331 build_head(F,A,Id1,VarsSusp,ClauseHead),
5332 get_constraint_mode(F/A,Mode),
5333 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5335 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
5337 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,ConstraintAllocationGoal),
5339 extend_id(Id1,DelegateId),
5340 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
5341 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
5342 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
5344 PreludeClause =
5345 ( ClauseHead :-
5346 FirstMatching,
5347 ModConstraintsGoal,
5348 !,
5349 ConstraintAllocationGoal,
5350 Delegate
5351 ),
5352 L = [PreludeClause|T].
5354 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
5355 Term =.. [_|Args],
5356 delegate_variables(Term,Terms,VarDict,Args,Vars).
5358 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
5359 term_variables(PrevTerms,PrevVars),
5360 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
5362 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
5363 term_variables(Term,V1),
5364 term_variables(Terms,V2),
5365 intersect_eq(V1,V2,V3),
5366 list_difference_eq(V3,PrevVars,V4),
5367 translate(V4,VarDict,Vars).
5370 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5371 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
5372 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
5373 Rule = rule(_,_,Guard,Body),
5374 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,PreSusps),
5376 gen_var(OtherSusp),
5377 gen_var(OtherSusps),
5379 functor(CurrentHead,OtherF,OtherA),
5380 gen_vars(OtherA,OtherVars),
5381 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
5382 get_constraint_mode(OtherF/OtherA,Mode),
5383 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
5385 % BEGIN NEW - Customizable suspension term layout
5386 % OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
5387 delay_phase_end(validate_store_type_assumptions,
5388 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
5389 get_static_suspension_term_field(state,OtherF/OtherA,OtherSuspension,State),
5390 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
5391 )
5392 ),
5393 % END NEW
5394 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
5395 create_get_mutable_ref(active,State,GetMutable),
5396 CurrentSuspTest = (
5397 OtherSusp = OtherSuspension,
5398 GetMutable,
5399 DiffSuspGoals,
5400 FirstMatching
5401 ),
5403 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5404 build_head(F,A,Id,ClauseVars,ClauseHead),
5406 guard_splitting(Rule,GuardList),
5407 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
5409 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
5410 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
5411 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
5413 gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
5415 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5416 build_head(F,A,Id,RecursiveVars,RecursiveCall),
5417 RecursiveVars2 = [[]|PreVarsAndSusps],
5418 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
5420 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
5421 ( BodyCopy \== true, is_observed(F/A,O) ->
5422 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
5423 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
5424 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
5425 ; Attachment = true,
5426 ConditionalRecursiveCall = RecursiveCall,
5427 ConditionalRecursiveCall2 = RecursiveCall2
5428 ),
5430 ( chr_pp_flag(debugable,on) ->
5431 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5432 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
5433 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
5434 ;
5435 DebugTry = true,
5436 DebugApply = true
5437 ),
5439 ( member(unique(ID1,UniqueKeys), Pragmas),
5440 check_unique_keys(UniqueKeys,VarDict) ->
5441 Clause =
5442 ( ClauseHead :-
5443 ( CurrentSuspTest ->
5444 ( RescheduledTest,
5445 DebugTry ->
5446 DebugApply,
5447 Susps1Detachments,
5448 Attachment,
5449 BodyCopy,
5450 ConditionalRecursiveCall2
5451 ;
5452 RecursiveCall2
5453 )
5454 ;
5455 RecursiveCall
5456 )
5457 )
5458 ;
5459 Clause =
5460 ( ClauseHead :-
5461 ( CurrentSuspTest,
5462 RescheduledTest,
5463 DebugTry ->
5464 DebugApply,
5465 Susps1Detachments,
5466 Attachment,
5467 BodyCopy,
5468 ConditionalRecursiveCall
5469 ;
5470 RecursiveCall
5471 )
5472 )
5473 ),
5474 L = [Clause | T].
5476 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
5477 % BEGIN NEW - Customizable suspension term layout
5478 % length(Args,A),
5479 % Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
5480 ( may_trigger(FA) ->
5481 delay_phase_end(validate_store_type_assumptions,
5482 ( static_suspension_term(FA,Suspension),
5483 get_static_suspension_term_field(state,FA,Suspension,State),
5484 get_static_suspension_term_field(generation,FA,Suspension,NewGeneration),
5485 get_static_suspension_term_field(arguments,FA,Suspension,Args)
5486 )
5487 ),
5488 create_get_mutable_ref(Generation,NewGeneration,GetGeneration)
5489 ;
5490 delay_phase_end(validate_store_type_assumptions,
5491 ( static_suspension_term(FA,Suspension),
5492 get_static_suspension_term_field(state,FA,Suspension,State),
5493 get_static_suspension_term_field(arguments,FA,Suspension,Args)
5494 )
5495 ),
5496 GetGeneration = true
5497 ),
5498 % END NEW
5499 create_get_mutable_ref(active,State,GetState),
5500 ConditionalCall =
5501 ( Susp = Suspension,
5502 GetState,
5503 GetGeneration ->
5504 'chr update_mutable'(inactive,State),
5505 Call
5506 ;
5507 true
5508 ).
5510 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5513 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5514 %% ____ _ _
5515 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
5516 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
5517 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
5518 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
5519 %% |_| |___/
5521 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5522 ( RestHeads == [] ->
5523 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
5524 ;
5525 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
5526 ).
5527 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5528 %% Single headed propagation
5529 %% everything in a single clause
5530 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
5531 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5532 build_head(F,A,Id,VarsSusp,ClauseHead),
5534 inc_id(Id,NextId),
5535 build_head(F,A,NextId,VarsSusp,NextHead),
5537 get_constraint_mode(F/A,Mode),
5538 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
5539 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5540 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,Allocation),
5542 % - recursive call -
5543 RecursiveCall = NextHead,
5544 ( Body \== true, is_observed(F/A,O) ->
5545 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
5546 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5547 ; Attachment = true,
5548 ConditionalRecursiveCall = RecursiveCall
5549 ),
5551 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
5552 ActualCut = true
5553 ;
5554 ActualCut = !
5555 ),
5557 ( chr_pp_flag(debugable,on) ->
5558 Rule = rule(_,_,Guard,Body),
5559 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5560 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
5561 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
5562 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
5563 ;
5564 Cut = ActualCut
5565 ),
5566 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
5567 use_auxiliary_predicate(novel_production),
5568 use_auxiliary_predicate(extend_history),
5569 does_use_history(F/A,O),
5570 NovelProduction = '$novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
5571 ExtendHistory = '$extend_history'(Susp,RuleNb)
5572 ;
5573 NovelProduction = true,
5574 ExtendHistory = true
5575 ),
5577 Clause = (
5578 ClauseHead :-
5579 HeadMatching,
5580 Allocation,
5581 NovelProduction,
5582 GuardCopy,
5583 Cut,
5584 ExtendHistory,
5585 Attachment,
5586 BodyCopy,
5587 ConditionalRecursiveCall
5588 ),
5589 ProgramList = [Clause | ProgramTail].
5591 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5592 %% multi headed propagation
5593 %% prelude + predicates to accumulate the necessary combinations of suspended
5594 %% constraints + predicate to execute the body
5595 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5596 RestHeads = [First|Rest],
5597 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
5598 extend_id(Id,ExtendedId),
5599 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
5601 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5602 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
5603 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5604 build_head(F,A,Id,VarsSusp,PreludeHead),
5605 get_constraint_mode(F/A,Mode),
5606 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5607 Rule = rule(_,_,Guard,Body),
5608 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
5610 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
5612 gen_occ_allocation(F/A,O,Vars,Susp,VarsSusp,CondAllocation),
5614 extend_id(Id,NestedId),
5615 append([Susps|VarsSusp],ExtraVars,NestedVars),
5616 build_head(F,A,NestedId,NestedVars,NestedHead),
5617 NestedCall = NestedHead,
5619 Prelude = (
5620 PreludeHead :-
5621 FirstMatching,
5622 FirstSuspGoal,
5623 !,
5624 CondAllocation,
5625 NestedCall
5626 ),
5627 L = [Prelude|T].
5629 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5630 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5631 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
5632 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
5634 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5635 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
5636 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
5637 inc_id(Id,IncId),
5638 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
5640 %check_fd_lookup_condition(_,_,_,_) :- fail.
5641 check_fd_lookup_condition(F,A,_,_) :-
5642 get_store_type(F/A,global_singleton), !.
5643 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
5644 \+ may_trigger(F/A),
5645 get_functional_dependency(F/A,1,P,K),
5646 copy_term(P-K,CurrentHead-Key),
5647 term_variables(PreHeads,PreVars),
5648 intersect_eq(Key,PreVars,Key),!.
5650 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
5651 Rule = rule(_,H2,Guard,Body),
5652 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
5653 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
5654 init(AllSusps,RestSusps),
5655 last(AllSusps,Susp),
5656 gen_var(OtherSusp),
5657 gen_var(OtherSusps),
5658 functor(CurrentHead,OtherF,OtherA),
5659 gen_vars(OtherA,OtherVars),
5660 delay_phase_end(validate_store_type_assumptions,
5661 ( static_suspension_term(OtherF/OtherA,Suspension),
5662 get_static_suspension_term_field(state,OtherF/OtherA,Suspension,State),
5663 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
5664 )
5665 ),
5666 create_get_mutable_ref(active,State,GetMutable),
5667 CurrentSuspTest = (
5668 OtherSusp = Suspension,
5669 GetMutable
5670 ),
5671 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5672 build_head(F,A,Id,ClauseVars,ClauseHead),
5673 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
5674 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
5675 RecursiveVars = PreVarsAndSusps1
5676 ;
5677 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5678 PrevId = Id
5679 ),
5680 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
5681 RecursiveCall = RecursiveHead,
5682 CurrentHead =.. [_|OtherArgs],
5683 pairup(OtherArgs,OtherVars,OtherPairs),
5684 get_constraint_mode(OtherF/OtherA,Mode),
5685 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
5687 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
5688 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5690 ( BodyCopy \== true, is_observed(F/A,O) ->
5691 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
5692 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5693 ; Attach = true,
5694 ConditionalRecursiveCall = RecursiveCall
5695 ),
5696 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
5697 NovelProduction = true,
5698 ExtendHistory = true
5699 ;
5700 get_occurrence(F/A,O,_,ID),
5701 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
5702 Tuple =.. [t,RuleNb|HistorySusps],
5703 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
5704 sort([ID|RestIDs],HistoryIDs),
5705 ( \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
5706 NovelProduction = true,
5707 ExtendHistory = true
5708 ;
5709 use_auxiliary_predicate(novel_production),
5710 use_auxiliary_predicate(extend_history),
5711 does_use_history(F/A,O),
5712 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
5713 NovelProduction = ( TupleVar = Tuple, NovelProductions),
5714 ExtendHistory = '$extend_history'(Susp,TupleVar)
5715 )
5716 ),
5719 ( chr_pp_flag(debugable,on) ->
5720 Rule = rule(_,_,Guard,Body),
5721 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5722 get_occurrence(F/A,O,_,ID),
5723 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
5724 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
5725 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
5726 ;
5727 DebugTry = true,
5728 DebugApply = true
5729 ),
5731 Clause = (
5732 ClauseHead :-
5733 ( CurrentSuspTest,
5734 DiffSuspGoals,
5735 Matching,
5736 NovelProduction,
5737 GuardCopy,
5738 DebugTry ->
5739 DebugApply,
5740 ExtendHistory,
5741 Attach,
5742 BodyCopy,
5743 ConditionalRecursiveCall
5744 ; RecursiveCall
5745 )
5746 ),
5747 L = [Clause|T].
5749 novel_production_calls([],[],[],_,_,true).
5750 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
5751 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
5752 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
5753 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
5755 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
5756 reverse(ReversedRestSusps,RestSusps),
5757 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
5760 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
5761 !,
5762 functor(Head,F,A),
5763 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
5764 get_constraint_mode(F/A,Mode),
5765 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
5766 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
5767 append(VarsSusp,ExtraVars,HeadVars).
5768 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
5769 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
5770 functor(Head,F,A),
5771 gen_var(Susps),
5772 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5773 get_constraint_mode(F/A,Mode),
5774 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5775 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5776 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
5778 % returns
5779 % VarDict for the copies of variables in the original heads
5780 % VarsSuspsList list of lists of arguments for the successive heads
5781 % FirstVarsSusp top level arguments
5782 % SuspList list of all suspensions
5783 % Iterators list of all iterators
5784 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
5785 !,
5786 functor(Head,F,A),
5787 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), % make variables for argument positions
5788 get_constraint_mode(F/A,Mode),
5789 head_arg_matches(HeadPairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
5790 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
5791 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
5792 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
5793 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
5794 functor(Head,F,A),
5795 gen_var(Susps),
5796 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5797 get_constraint_mode(F/A,Mode),
5798 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5799 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
5800 append(HeadVars,[Susp,Susps],Vars).
5802 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
5803 !,
5804 functor(Head,F,A),
5805 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
5806 get_constraint_mode(F/A,Mode),
5807 head_arg_matches(Pairs,Mode,[],_,VarDict),
5808 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
5809 append(VarsSusp,ExtraVars,HeadVars).
5810 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
5811 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
5812 functor(Head,F,A),
5813 gen_var(Susps),
5814 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
5815 get_constraint_mode(F/A,Mode),
5816 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
5817 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5818 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
5820 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5822 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5823 %% ____ _ _ _ _
5824 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
5825 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
5826 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
5827 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
5828 %%
5829 %% ____ _ _ _
5830 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
5831 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
5832 %% | _ < __/ |_| | | | __/\ V / (_| | |
5833 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
5834 %%
5835 %% ____ _ _
5836 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
5837 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
5838 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
5839 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
5840 %% |___/
5842 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5843 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
5844 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
5845 ;
5846 NRestHeads = RestHeads,
5847 NRestIDs = RestIDs
5848 ).
5850 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5851 term_variables(Head,Vars),
5852 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
5853 copy_term_nat(InitialData,InitialDataCopy),
5854 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
5855 InitialDataCopy = InitialData,
5856 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
5857 reverse(RNRestHeads,NRestHeads),
5858 reverse(RNRestIDs,NRestIDs).
5860 final_data(Entry) :-
5861 Entry = entry(_,_,_,_,[],_).
5863 expand_data(Entry,NEntry,Cost) :-
5864 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
5865 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
5866 term_variables([Head1|Vars],Vars1),
5867 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
5868 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
5870 % Assigns score to head based on known variables and heads to lookup
5871 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
5872 functor(Head,F,A),
5873 get_store_type(F/A,StoreType),
5874 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
5876 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
5877 term_variables(Head,HeadVars),
5878 term_variables(RestHeads,RestVars),
5879 order_score_vars(HeadVars,KnownVars,RestVars,Score).
5880 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
5881 order_score_indexes(Indexes,Head,KnownVars,0,Score).
5882 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
5883 order_score_indexes(Indexes,Head,KnownVars,0,Score).
5884 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
5885 term_variables(Head,HeadVars),
5886 term_variables(RestHeads,RestVars),
5887 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
5888 Score is Score_ * 2.
5889 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
5890 Score = 1. % guaranteed O(1)
5892 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
5893 find_with_var_identity(
5894 S,
5895 t(Head,KnownVars,RestHeads),
5896 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
5897 Scores
5898 ),
5899 min_list(Scores,Score).
5902 order_score_indexes([],_,_,Score,NScore) :-
5903 Score > 0, NScore = 100.
5904 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
5905 multi_hash_key_args(I,Head,Args),
5906 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
5907 Score1 is Score + 1
5908 ;
5909 Score1 = Score
5910 ),
5911 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
5913 order_score_vars(Vars,KnownVars,RestVars,Score) :-
5914 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
5915 ( K-R-O == 0-0-0 ->
5916 Score = 0
5917 ; K > 0 ->
5918 Score is max(10 - K,0)
5919 ; R > 0 ->
5920 Score is max(10 - R,1) * 10
5921 ;
5922 Score is max(10-O,1) * 100
5923 ).
5924 order_score_count_vars([],_,_,0-0-0).
5925 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
5926 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
5927 ( memberchk_eq(V,KnownVars) ->
5928 NK is K + 1,
5929 NR = R, NO = O
5930 ; memberchk_eq(V,RestVars) ->
5931 NR is R + 1,
5932 NK = K, NO = O
5933 ;
5934 NO is O + 1,
5935 NK = K, NR = R
5936 ).
5938 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5939 %% ___ _ _ _
5940 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
5941 %% | || '_ \| | | '_ \| | '_ \ / _` |
5942 %% | || | | | | | | | | | | | | (_| |
5943 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
5944 %% |___/
5946 %% SWI begin
5947 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
5948 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
5949 %% SWI end
5951 %% SICStus begin
5952 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
5953 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
5954 %% SICStus end
5956 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5959 %% _ _ _ _ _ _ _
5960 %% | | | | |_(_) (_) |_ _ _
5961 %% | | | | __| | | | __| | | |
5962 %% | |_| | |_| | | | |_| |_| |
5963 %% \___/ \__|_|_|_|\__|\__, |
5964 %% |___/
5966 gen_var(_).
5967 gen_vars(N,Xs) :-
5968 length(Xs,N).
5970 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
5971 vars_susp(A,Vars,Susp,VarsSusp),
5972 Head =.. [_|Args],
5973 pairup(Args,Vars,HeadPairs).
5975 inc_id([N|Ns],[O|Ns]) :-
5976 O is N + 1.
5977 dec_id([N|Ns],[M|Ns]) :-
5978 M is N - 1.
5980 extend_id(Id,[0|Id]).
5982 next_id([_,N|Ns],[O|Ns]) :-
5983 O is N + 1.
5985 build_head(F,A,Id,Args,Head) :-
5986 buildName(F,A,Id,Name),
5987 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
5988 ( may_trigger(F/A) ;
5989 get_allocation_occurrence(F/A,AO),
5990 get_max_occurrence(F/A,MO),
5991 MO >= AO ) ) ->
5992 Head =.. [Name|Args]
5993 ;
5994 init(Args,ArgsWOSusp), % XXX not entirely correct!
5995 Head =.. [Name|ArgsWOSusp]
5996 ).
5998 buildName(Fct,Aty,List,Result) :-
5999 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
6000 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
6001 MO >= AO ) ; List \= [0])) ) ) ->
6002 atom_concat(Fct, (/) ,FctSlash),
6003 atomic_concat(FctSlash,Aty,FctSlashAty),
6004 buildName_(List,FctSlashAty,Result)
6005 ;
6006 Result = Fct
6007 ).
6009 buildName_([],Name,Name).
6010 buildName_([N|Ns],Name,Result) :-
6011 buildName_(Ns,Name,Name1),
6012 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
6013 atomic_concat(NameDash,N,Result).
6015 vars_susp(A,Vars,Susp,VarsSusp) :-
6016 length(Vars,A),
6017 append(Vars,[Susp],VarsSusp).
6019 make_attr(N,Mask,SuspsList,Attr) :-
6020 length(SuspsList,N),
6021 Attr =.. [v,Mask|SuspsList].
6023 or_pattern(Pos,Pat) :-
6024 Pow is Pos - 1,
6025 Pat is 1 << Pow. % was 2 ** X
6027 and_pattern(Pos,Pat) :-
6028 X is Pos - 1,
6029 Y is 1 << X, % was 2 ** X
6030 Pat is (-1)*(Y + 1).
6032 make_name(Prefix,F/A,Name) :-
6033 atom_concat_list([Prefix,F,(/),A],Name).
6035 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6036 % Storetype dependent lookup
6037 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
6038 functor(Head,F,A),
6039 get_store_type(F/A,StoreType),
6040 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
6042 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
6043 functor(Head,F,A),
6044 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps).
6045 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6046 once((
6047 member(Index,Indexes),
6048 multi_hash_key_args(Index,Head,KeyArgs),
6049 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6050 ground(KeyArgs), KeyArgCopies = KeyArgs )
6051 )),
6052 ( KeyArgCopies = [KeyCopy] ->
6053 true
6054 ;
6055 KeyCopy =.. [k|KeyArgCopies]
6056 ),
6057 functor(Head,F,A),
6058 multi_hash_via_lookup_name(F/A,Index,ViaName),
6059 Goal =.. [ViaName,KeyCopy,AllSusps],
6060 update_store_type(F/A,multi_inthash([Index])).
6061 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6062 once((
6063 member(Index,Indexes),
6064 multi_hash_key_args(Index,Head,KeyArgs),
6065 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6066 ground(KeyArgs), KeyArgCopies = KeyArgs )
6067 )),
6068 ( KeyArgCopies = [KeyCopy] ->
6069 true
6070 ;
6071 KeyCopy =.. [k|KeyArgCopies]
6072 ),
6073 functor(Head,F,A),
6074 multi_hash_via_lookup_name(F/A,Index,ViaName),
6075 Goal =.. [ViaName,KeyCopy,AllSusps],
6076 update_store_type(F/A,multi_hash([Index])).
6077 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6078 functor(Head,F,A),
6079 global_ground_store_name(F/A,StoreName),
6080 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
6081 update_store_type(F/A,global_ground).
6082 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6083 functor(Head,F,A),
6084 global_singleton_store_name(F/A,StoreName),
6085 make_get_store_goal(StoreName,Susp,GetStoreGoal),
6086 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
6087 update_store_type(F/A,global_singleton).
6088 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
6089 once((
6090 member(ST,StoreTypes),
6091 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
6092 )).
6094 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :- !,
6095 functor(Head,F,A),
6096 global_singleton_store_name(F/A,StoreName),
6097 make_get_store_goal(StoreName,Susp,GetStoreGoal),
6098 Goal = (
6099 GetStoreGoal, % nb_getval(StoreName,Susp),
6100 Susp \== [],
6101 Susp = SuspTerm
6102 ),
6103 update_store_type(F/A,global_singleton).
6104 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
6105 once((
6106 member(ST,StoreTypes),
6107 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs)
6108 )).
6109 existential_lookup(multi_inthash(Indexes),Head,_PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
6110 once((
6111 member(Index,Indexes),
6112 multi_hash_key_args(Index,Head,KeyArgs),
6113 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6114 ground(KeyArgs), KeyArgCopies = KeyArgs )
6115 )),
6116 ( KeyArgCopies = [KeyCopy] ->
6117 true
6118 ;
6119 KeyCopy =.. [k|KeyArgCopies]
6120 ),
6121 functor(Head,F,A),
6122 multi_hash_via_lookup_name(F/A,Index,ViaName),
6123 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6124 create_get_mutable(active,State,GetMutable),
6125 sbag_member_call(Susp,AllSusps,Sbag),
6126 Goal = (
6127 LookupGoal,
6128 Sbag,
6129 Susp = SuspTerm, % not inlined
6130 GetMutable
6131 ),
6132 hash_index_filter(Pairs,Index,NPairs),
6133 update_store_type(F/A,multi_inthash([Index])).
6134 existential_lookup(multi_hash(Indexes),Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,NPairs) :- !,
6135 once((
6136 member(Index,Indexes),
6137 multi_hash_key_args(Index,Head,KeyArgs),
6138 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6139 ground(KeyArgs), KeyArgCopies = KeyArgs )
6140 )),
6141 ( KeyArgCopies = [KeyCopy] ->
6142 true
6143 ;
6144 KeyCopy =.. [k|KeyArgCopies]
6145 ),
6146 functor(Head,F,A),
6147 multi_hash_via_lookup_name(F/A,Index,ViaName),
6148 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6149 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
6150 Sbag = (AllSusps = [Susp])
6151 ;
6152 sbag_member_call(Susp,AllSusps,Sbag)
6153 ),
6154 create_get_mutable(active,State,GetMutable),
6155 Goal = (
6156 LookupGoal,
6157 Sbag,
6158 Susp = SuspTerm, % not inlined
6159 GetMutable
6160 ),
6161 hash_index_filter(Pairs,Index,NPairs),
6162 update_store_type(F/A,multi_hash([Index])).
6163 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,State,Goal,Susp,Pairs,Pairs) :-
6164 lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),
6165 sbag_member_call(Susp,Susps,Sbag),
6166 create_get_mutable(active,State,GetMutable),
6167 Goal = (
6168 UGoal,
6169 Sbag,
6170 Susp = SuspTerm, % not inlined
6171 GetMutable
6172 ).
6174 hash_index_filter(Pairs,Index,NPairs) :-
6175 ( integer(Index) ->
6176 NIndex = [Index]
6177 ;
6178 NIndex = Index
6179 ),
6180 hash_index_filter(Pairs,NIndex,1,NPairs).
6182 hash_index_filter([],_,_,[]).
6183 hash_index_filter([P|Ps],Index,N,NPairs) :-
6184 ( Index = [I|Is] ->
6185 NN is N + 1,
6186 ( I > N ->
6187 NPairs = [P|NPs],
6188 hash_index_filter(Ps,[I|Is],NN,NPs)
6189 ; I == N ->
6190 NPairs = NPs,
6191 hash_index_filter(Ps,Is,NN,NPs)
6192 )
6193 ;
6194 NPairs = [P|Ps]
6195 ).
6197 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6198 assume_constraint_stores([]).
6199 assume_constraint_stores([C|Cs]) :-
6200 ( only_ground_indexed_arguments(C),
6201 is_stored(C),
6202 get_store_type(C,default) ->
6203 get_indexed_arguments(C,IndexedArgs),
6204 % TODO: O(2^n) is not robust for too many indexed arguments,
6205 % reject some possible indexes...
6206 % or replace brute force index generation with other approach
6207 length(IndexedArgs,NbIndexedArgs),
6208 ( NbIndexedArgs > 10 ->
6209 findall([Index],member(Index,IndexedArgs),Indexes)
6210 ;
6211 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
6212 predsort(longer_list,UnsortedIndexes,Indexes)
6213 ),
6214 ( get_functional_dependency(C,1,Pattern,Key),
6215 all_distinct_var_args(Pattern), Key == [] ->
6216 assumed_store_type(C,global_singleton)
6217 ;
6218 ( get_constraint_type(C,Type),
6219 findall(Index,(member(Index,Indexes), Index = [I],
6220 nth(I,Type,dense_int)),IndexesA),
6221 IndexesA \== [] ->
6222 list_difference_eq(Indexes,IndexesA,IndexesB),
6223 ( IndexesB \== [] ->
6224 assumed_store_type(C,multi_store([multi_inthash(IndexesA),multi_hash(IndexesB),global_ground]))
6225 ;
6226 assumed_store_type(C,multi_store([multi_inthash(IndexesA),global_ground]))
6227 )
6228 ;
6229 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
6230 )
6231 )
6232 ;
6233 true
6234 ),
6235 assume_constraint_stores(Cs).
6237 longer_list(R,L1,L2) :-
6238 length(L1,N1),
6239 length(L2,N2),
6240 compare(Rt,N2,N1),
6241 ( Rt == (=) ->
6242 compare(R,L1,L2)
6243 ;
6244 R = Rt
6245 ).
6247 all_distinct_var_args(Term) :-
6248 Term =.. [_|Args],
6249 copy_term_nat(Args,NArgs),
6250 all_distinct_var_args_(NArgs).
6252 all_distinct_var_args_([]).
6253 all_distinct_var_args_([X|Xs]) :-
6254 var(X),
6255 X = t,
6256 all_distinct_var_args_(Xs).
6258 get_indexed_arguments(C,IndexedArgs) :-
6259 C = F/A,
6260 get_indexed_arguments(1,A,C,IndexedArgs).
6262 get_indexed_arguments(I,N,C,L) :-
6263 ( I > N ->
6264 L = []
6265 ; ( is_indexed_argument(C,I) ->
6266 L = [I|T]
6267 ;
6268 L = T
6269 ),
6270 J is I + 1,
6271 get_indexed_arguments(J,N,C,T)
6272 ).
6274 validate_store_type_assumptions([]).
6275 validate_store_type_assumptions([C|Cs]) :-
6276 validate_store_type_assumption(C),
6277 validate_store_type_assumptions(Cs).
6279 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6280 % new code generation
6281 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
6282 Rule = rule(H1,_,Guard,Body),
6283 ( H1 == [],
6284 functor(CurrentHead,CF,CA),
6285 check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
6286 L = T
6287 ;
6288 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
6289 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
6290 flatten(VarsAndSuspsList,VarsAndSusps),
6291 Vars = [ [] | VarsAndSusps],
6292 build_head(F,A,Id,Vars,Head),
6293 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
6294 Clause = ( Head :- PredecessorCall),
6295 L = [Clause | T]
6296 ).
6298 % skips back intelligently over global_singleton lookups
6299 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
6300 ( Id = [0|_] ->
6301 next_id(Id,PrevId),
6302 PrevVarsAndSusps = BaseCallArgs
6303 ;
6304 VarsAndSuspsList = [_|AllButFirstList],
6305 dec_id(Id,PrevId1),
6306 ( PrevHeads = [PrevHead|PrevHeads1],
6307 functor(PrevHead,F,A),
6308 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
6309 PrevIterators = [_|PrevIterators1],
6310 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
6311 ;
6312 PrevId = PrevId1,
6313 flatten(AllButFirstList,AllButFirst),
6314 PrevIterators = [PrevIterator|_],
6315 PrevVarsAndSusps = [PrevIterator|AllButFirst]
6316 )
6317 ).
6319 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
6320 Rule = rule(_,_,Guard,Body),
6321 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
6322 init(AllSusps,PreSusps),
6323 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
6324 gen_var(OtherSusps),
6325 functor(CurrentHead,OtherF,OtherA),
6326 gen_vars(OtherA,OtherVars),
6327 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
6328 get_constraint_mode(OtherF/OtherA,Mode),
6329 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
6331 % BEGIN NEW - Customizable suspension term layout
6332 % OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
6333 delay_phase_end(validate_store_type_assumptions,
6334 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
6335 get_static_suspension_term_field(state,OtherF/OtherA,OtherSuspension,State),
6336 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
6337 )
6338 ),
6339 % END NEW
6341 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
6342 create_get_mutable_ref(active,State,GetMutable),
6343 CurrentSuspTest = (
6344 OtherSusp = OtherSuspension,
6345 GetMutable,
6346 DiffSuspGoals,
6347 FirstMatching
6348 ),
6349 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
6350 inc_id(Id,NestedId),
6351 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6352 build_head(F,A,Id,ClauseVars,ClauseHead),
6353 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
6354 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
6355 build_head(F,A,NestedId,NestedVars,NestedHead),
6357 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
6358 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
6359 RecursiveVars = PreVarsAndSusps1
6360 ;
6361 RecursiveVars = [OtherSusps|PreVarsAndSusps],
6362 PrevId = Id
6363 ),
6364 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
6366 Clause = (
6367 ClauseHead :-
6368 ( CurrentSuspTest,
6369 NextSuspGoal
6370 ->
6371 NestedHead
6372 ; RecursiveHead
6373 )
6374 ),
6375 L = [Clause|T].
6377 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6379 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6380 % % Observation Analysis
6381 % %
6382 % % CLASSIFICATION
6383 % % Enabled
6384 % %
6385 % % Analysis based on Abstract Interpretation paper.
6386 % %
6387 % % TODO:
6388 % % replace explicit constraint representation with
6389 % % GMP integers as bit vectors
6390 % % 1 << N empty set for 0 .. N-1 constraints
6391 % % 1 << I for ith constraint mask M_i
6392 % % \ I for inverted constraint mask
6393 % % Set /\ M_I =:= 0 for member test
6394 % % Set \/ M_I for addition
6395 % % Set /\ (\I1 /\ ... /\ \In) for removal of many ints
6396 % %
6397 % % stronger analysis domain [research]
6398 %
6399 % :- chr_constraint
6400 % initial_call_pattern/1,
6401 % call_pattern/1,
6402 % final_answer_pattern/2,
6403 % abstract_constraints/1,
6404 % depends_on/2,
6405 % depends_on_ap/4,
6406 % depends_on_goal/2,
6407 % ai_observed_internal/2,
6408 % ai_observed/2,
6409 % ai_not_observed_internal/2,
6410 % ai_not_observed/2,
6411 % ai_is_observed/2,
6412 % depends_on_as/3,
6413 % ai_observation_gather_results/0.
6414 %
6415 % :- chr_option(mode,initial_call_pattern(+)).
6416 % :- chr_option(mode,call_pattern(+)).
6417 % :- chr_option(mode,final_answer_pattern(+,+)).
6418 % :- chr_option(mode,abstract_constraints(+)).
6419 % :- chr_option(mode,depends_on(+,+)).
6420 % :- chr_option(mode,depends_on_as(+,+,+)).
6421 % :- chr_option(mode,depends_on_ap(+,+,+,+)).
6422 % :- chr_option(mode,depends_on_goal(+,+)).
6423 % :- chr_option(mode,ai_observed(+,+)).
6424 % :- chr_option(mode,ai_is_observed(+,+)).
6425 % :- chr_option(mode,ai_not_observed(+,+)).
6426 % :- chr_option(mode,ai_observed(+,+)).
6427 % :- chr_option(mode,ai_not_observed_internal(+,+)).
6428 % :- chr_option(mode,ai_observed_internal(+,+)).
6429 %
6430 % abstract_constraints_fd @
6431 % abstract_constraints(_) \ abstract_constraints(_) <=> true.
6432 %
6433 % ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6434 % ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6435 % ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
6436 %
6437 % ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
6438 % ai_is_observed(_,_) <=> true.
6439 %
6440 % ai_observation_gather_results, bit_position(C,CMask) \ ai_observed_internal(CMask,O) <=> ai_observed(C,O).
6441 % ai_observation_gather_results, bit_position(C,CMask) \ ai_not_observed_internal(CMask,O) <=> ai_not_observed(C,O).
6442 % ai_observation_gather_results <=> true.
6443 %
6444 % %------------------------------------------------------------------------------%
6445 % % Main Analysis Entry
6446 % %------------------------------------------------------------------------------%
6447 % ai_observation_analysis(ACs) :-
6448 % ( chr_pp_flag(ai_observation_analysis,on),
6449 % get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
6450 % list_to_ord_set(ACs,ACSet),
6451 % ai_observation_associate_bit_positions(ACSet,ACMasks),
6452 % abstract_constraints(ACMasks),
6453 % ai_observation_schedule_initial_calls(ACMasks),
6454 % ai_observation_gather_results
6455 % ;
6456 % true
6457 % ).
6458 %
6459 % %------------------------------------------------------------------------------%
6460 % % Bit Vector Stuff
6461 % %------------------------------------------------------------------------------%
6462 %
6463 % :- chr_constraint bit_position/2.
6464 % :- chr_option(mode,bit_position(+,+)).
6465 % :- chr_constraint get_bit_position/2.
6466 % :- chr_option(mode,get_bit_position(+,?)).
6467 %
6468 % bit_position(C,P) \ get_bit_position(C,Q) <=> Q = P.
6469 % get_bit_position(_,_) <=> fail.
6470 %
6471 % ai_observation_associate_bit_positions(FAs,Masks) :-
6472 % ai_observation_associate_bit_positions(FAs,0,Masks).
6473 %
6474 % ai_observation_associate_bit_positions([],_,[]).
6475 % ai_observation_associate_bit_positions([FA|FAs],I,[Mask|Masks]) :-
6476 % ai_observation_associate_bit_position(FA,I,Mask),
6477 % J is I + 1,
6478 % ai_observation_associate_bit_positions(FAs,J,Masks).
6479 %
6480 % ai_observation_associate_bit_position(FA,I,Mask) :-
6481 % Mask is 1 << I,
6482 % bit_position(FA,Mask).
6483 %
6484 % %------------------------------------------------------------------------------%
6485 % % Initial Calls
6486 % %------------------------------------------------------------------------------%
6487 % ai_observation_schedule_initial_calls([]).
6488 % ai_observation_schedule_initial_calls([ACMask|ACMasks]) :-
6489 % ai_observation_schedule_initial_call(ACMask),
6490 % ai_observation_schedule_initial_calls(ACMasks).
6491 %
6492 % ai_observation_schedule_initial_call(ACMask) :-
6493 % ai_observation_top(ACMask,CallPattern),
6494 % initial_call_pattern(CallPattern).
6495 %
6496 % ai_observation_schedule_new_calls([],AP).
6497 % ai_observation_schedule_new_calls([AC|ACs],AP) :-
6498 % AP = odom(_,Set),
6499 % initial_call_pattern(odom(AC,Set)),
6500 % ai_observation_schedule_new_calls(ACs,AP).
6501 %
6502 % final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
6503 % <=>
6504 % ai_observation_leq(AP2,AP1)
6505 % |
6506 % true.
6507 %
6508 % initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
6509 %
6510 % initial_call_pattern(CP) ==> call_pattern(CP).
6511 %
6512 % initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
6513 % ==>
6514 % ai_observation_schedule_new_calls(ACs,AP)
6515 % pragma
6516 % passive(ID3).
6517 %
6518 % call_pattern(CP) \ call_pattern(CP) <=> true.
6519 %
6520 % depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
6521 % final_answer_pattern(CP1,AP).
6522 %
6523 % % call_pattern(CP) ==> writeln(call_pattern(CP)).
6524 %
6525 % %------------------------------------------------------------------------------%
6526 % % Abstract Goal
6527 % %------------------------------------------------------------------------------%
6528 %
6529 % % AbstractGoala
6530 % %call_pattern(odom([],Set)) ==>
6531 % % final_answer_pattern(odom([],Set),odom([],Set)).
6532 %
6533 % call_pattern(odom([],Set)) <=>
6534 % final_answer_pattern(odom([],Set),odom([],Set)).
6535 %
6536 % % AbstractGoalb
6537 % call_pattern(odom([G|Gs],Set)) ==>
6538 % CP1 = odom(G,Set),
6539 % depends_on_goal(odom([G|Gs],Set),CP1),
6540 % call_pattern(CP1).
6541 %
6542 % depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
6543 % <=> true pragma passive(ID).
6544 % depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
6545 % ==>
6546 % CP1 = odom([_|Gs],_),
6547 % AP2 = odom([],Set),
6548 % CCP = odom(Gs,Set),
6549 % call_pattern(CCP),
6550 % depends_on(CP1,CCP).
6551 %
6552 % %------------------------------------------------------------------------------%
6553 % % Abstract Solve
6554 % %------------------------------------------------------------------------------%
6555 % call_pattern(odom(builtin,Set)) ==>
6556 % % writeln(' - AbstractSolve'),
6557 % EmptySet = 0,
6558 % final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
6559 %
6560 % %------------------------------------------------------------------------------%
6561 % % Abstract Drop
6562 % %------------------------------------------------------------------------------%
6563 % call_pattern(odom(occ(CMask,O),Set)), bit_position(C,CMask) # ID2, max_occurrence(C,MO) # ID3
6564 % ==>
6565 % O > MO
6566 % |
6567 % % writeln(' - AbstractDrop'(occ(CMask,O),Set)),
6568 % final_answer_pattern(odom(occ(CMask,O),Set),odom([],Set))
6569 % pragma
6570 % passive(ID2),
6571 % passive(ID3).
6572 %
6573 % %------------------------------------------------------------------------------%
6574 % % Abstract Activate
6575 % %------------------------------------------------------------------------------%
6576 % call_pattern(odom(AC,Set))
6577 % ==>
6578 % integer(AC) % AC = _ / _
6579 % |
6580 % % writeln(' - AbstractActivate'(AC)),
6581 % CP = odom(occ(AC,1),Set),
6582 % call_pattern(CP),
6583 % depends_on(odom(AC,Set),CP).
6584 %
6585 % %------------------------------------------------------------------------------%
6586 % % Abstract Passive
6587 % %------------------------------------------------------------------------------%
6588 % call_pattern(odom(occ(CMask,O),Set)), bit_position(C,CMask) # ID2, occurrence(C,O,RuleNb,ID,_) # ID3 ==>
6589 % is_passive(RuleNb,ID)
6590 % |
6591 % % DEFAULT
6592 % NO is O + 1,
6593 % DCP = odom(occ(CMask,NO),Set),
6594 % call_pattern(DCP),
6595 % final_answer_pattern(odom(occ(CMask,O),Set),odom([],Set)),
6596 % depends_on(odom(occ(CMask,O),Set),DCP)
6597 % pragma
6598 % passive(ID2),
6599 % passive(ID3).
6600 % %------------------------------------------------------------------------------%
6601 % % Abstract Simplify
6602 % %------------------------------------------------------------------------------%
6603 %
6604 % % AbstractSimplify
6605 % call_pattern(odom(occ(CMask,O),Set)), bit_position(C,CMask) # ID2, occurrence(C,O,RuleNb,ID,simplification) # ID3
6606 % ==>
6607 % \+ is_passive(RuleNb,ID)
6608 % |
6609 % % writeln(' - AbstractSimplify'(C,O)),
6610 % ai_observation_memo_simplification_rest_heads(C,O,InvertedRestMask),
6611 % Set2 is Set /\ InvertedRestMask, % ai_observation_observe_list(Set,AbstractRestHeads,Set2),
6612 % ai_observation_memo_abstract_goal(RuleNb,AG),
6613 % call_pattern(odom(AG,Set2)),
6614 % % DEFAULT
6615 % NO is O + 1,
6616 % DCP = odom(occ(CMask,NO),Set),
6617 % call_pattern(DCP),
6618 % depends_on_as(odom(occ(CMask,O),Set),odom(AG,Set2),DCP),
6619 % % DEADLOCK AVOIDANCE
6620 % final_answer_pattern(odom(occ(CMask,O),Set),odom([],Set))
6621 % pragma
6622 % passive(ID2),
6623 % passive(ID3).
6624 %
6625 % depends_on_as(CP,CPS,CPD),
6626 % final_answer_pattern(CPS,APS),
6627 % final_answer_pattern(CPD,APD) ==>
6628 % ai_observation_lub(APS,APD,AP),
6629 % final_answer_pattern(CP,AP).
6630 %
6631 %
6632 % :- chr_constraint
6633 % ai_observation_memo_simplification_rest_heads/3,
6634 % ai_observation_memoed_simplification_rest_heads/3.
6635 %
6636 % :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
6637 % :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
6638 %
6639 % ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6640 % <=>
6641 % QRH = RH.
6642 % occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6643 % <=>
6644 % Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
6645 % once(select2(ID,_,IDs1,H1,_,RestH1)),
6646 % ai_observation_abstract_constraints(RestH1,ARestHeads),
6647 % ai_observation_abstract_constraints(H2,AH2),
6648 % append(ARestHeads,AH2,AbstractHeads),
6649 % hprolog:or_list(AbstractHeads,Mask),
6650 % QRH is \Mask,
6651 % ai_observation_memoed_simplification_rest_heads(C,O,QRH)
6652 % pragma
6653 % passive(ID2),
6654 % passive(ID3).
6655 %
6656 % %------------------------------------------------------------------------------%
6657 % % Abstract Propagate
6658 % %------------------------------------------------------------------------------%
6659 %
6660 %
6661 % % AbstractPropagate
6662 % call_pattern(odom(occ(CMask,O),Set)), bit_position(C,CMask) # ID2, occurrence(C,O,RuleNb,ID,propagation) # ID3
6663 % ==>
6664 % \+ is_passive(RuleNb,ID)
6665 % |
6666 % % writeln(' - AbstractPropagate'(C,O)),
6667 % % observe partners
6668 % ai_observation_memo_propagation_rest_heads(C,O,InvertedRestMask),
6669 % Set2 is Set /\ InvertedRestMask, % ai_observation_observe_list(Set,AHs,Set2),
6670 % Set3 is Set2 \/ CMask, % ord_add_element(Set2,C,Set3),
6671 % ai_observation_memo_abstract_goal(RuleNb,AG),
6672 % call_pattern(odom(AG,Set3)),
6673 % ( Set2 /\ CMask > 0 -> % ord_memberchk(C,Set2) ->
6674 % Delete = no
6675 % ;
6676 % Delete = yes
6677 % ),
6678 % % DEFAULT
6679 % NO is O + 1,
6680 % DCP = odom(occ(CMask,NO),Set),
6681 % call_pattern(DCP),
6682 % depends_on_ap(odom(occ(CMask,O),Set),odom(AG,Set3),DCP,Delete)
6683 % pragma
6684 % passive(ID2),
6685 % passive(ID3).
6686 %
6687 % :- chr_constraint
6688 % ai_observation_memo_propagation_rest_heads/3,
6689 % ai_observation_memoed_propagation_rest_heads/3.
6690 %
6691 % :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
6692 % :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
6693 %
6694 % ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6695 % <=>
6696 % QRH = RH.
6697 % occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6698 % <=>
6699 % Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
6700 % once(select2(ID,_,IDs2,H2,_,RestH2)),
6701 % ai_observation_abstract_constraints(RestH2,ARestHeads),
6702 % ai_observation_abstract_constraints(H1,AH1),
6703 % append(ARestHeads,AH1,AbstractHeads),
6704 % hprolog:or_list(AbstractHeads,Mask),
6705 % QRH is \Mask,
6706 % ai_observation_memoed_propagation_rest_heads(C,O,QRH)
6707 % pragma
6708 % passive(ID2),
6709 % passive(ID3).
6710 %
6711 % depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
6712 % final_answer_pattern(CP,APD).
6713 % depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
6714 % final_answer_pattern(CPD,APD) ==>
6715 % true |
6716 % CP = odom(occ(C,O),_),
6717 % ( ai_observation_is_observed(APP,C) ->
6718 % ai_observed_internal(C,O)
6719 % ;
6720 % ai_not_observed_internal(C,O)
6721 % ),
6722 % ( Delete == yes ->
6723 % APP = odom([],Set0),
6724 % Set is Set0 /\ \C, % ord_del_element(Set0,C,Set),
6725 % NAPP = odom([],Set)
6726 % ;
6727 % NAPP = APP
6728 % ),
6729 % ai_observation_lub(NAPP,APD,AP),
6730 % final_answer_pattern(CP,AP).
6731 %
6732 % %------------------------------------------------------------------------------%
6733 % % Auxiliary Predicates
6734 % %------------------------------------------------------------------------------%
6735 %
6736 % ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
6737 % S3 is S1 /\ S2.
6738 %
6739 % ai_observation_bot(AG,AS,odom(AG,AS)).
6740 %
6741 % ai_observation_top(AG,odom(AG,EmptyS)) :-
6742 % EmptyS = 0.
6743 %
6744 % ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
6745 % S2 /\ S1 =:= S2.
6746 % % ord_subset(S2,S1).
6747 %
6748 % ai_observation_abstract_constraint(C,AC) :-
6749 % functor(C,F,A),
6750 % get_bit_position(F/A,AC).
6751 %
6752 %
6753 % ai_observation_abstract_constraints(Cs,NACs) :-
6754 % findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,NAC)),NACs).
6755 %
6756 % %------------------------------------------------------------------------------%
6757 % % Abstraction of Rule Bodies
6758 % %------------------------------------------------------------------------------%
6759 %
6760 % :- chr_constraint
6761 % ai_observation_memoed_abstract_goal/2,
6762 % ai_observation_memo_abstract_goal/2.
6763 %
6764 % :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
6765 % :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
6766 %
6767 % ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6768 % <=>
6769 % QAG = AG
6770 % pragma
6771 % passive(ID1).
6772 %
6773 % rule(RuleNb,Rule) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6774 % <=>
6775 % Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
6776 % ai_observation_abstract_goal_(H1,H2,Guard,Body,AG),
6777 % QAG = AG,
6778 % ai_observation_memoed_abstract_goal(RuleNb,AG)
6779 % pragma
6780 % passive(ID1).
6781 %
6782 % ai_observation_abstract_goal_(H1,H2,Guard,G,AG) :-
6783 % % also guard: e.g. b, c(X) ==> Y=X | p(Y).
6784 % term_variables((H1,H2,Guard),HVars),
6785 % append(H1,H2,Heads),
6786 % % variables that are declared to be ground are safe,
6787 % ground_vars(Heads,GroundVars),
6788 % % so we remove them from the list of 'dangerous' head variables
6789 % list_difference_eq(HVars,GroundVars,HV),
6790 % ai_observation_abstract_goal(G,AG,[],HV),!.
6791 % % HV are 'dangerous' variables, all others are fresh and safe
6792 %
6793 % ground_vars([],[]).
6794 % ground_vars([H|Hs],GroundVars) :-
6795 % functor(H,F,A),
6796 % get_constraint_mode(F/A,Mode),
6797 % head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
6798 % head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
6799 % ground_vars(Hs,GroundVars2),
6800 % append(GroundVars1,GroundVars2,GroundVars).
6801 %
6802 % ai_observation_abstract_goal((G1,G2),List,Tail,HV) :- !, % conjunction
6803 % ai_observation_abstract_goal(G1,List,IntermediateList,HV),
6804 % ai_observation_abstract_goal(G2,IntermediateList,Tail,HV).
6805 % ai_observation_abstract_goal((G1;G2),List,Tail,HV) :- !, % disjunction
6806 % ai_observation_abstract_goal(G1,List,IntermediateList,HV),
6807 % ai_observation_abstract_goal(G2,IntermediateList,Tail,HV).
6808 % ai_observation_abstract_goal((G1->G2),List,Tail,HV) :- !, % if-then
6809 % ai_observation_abstract_goal(G1,List,IntermediateList,HV),
6810 % ai_observation_abstract_goal(G2,IntermediateList,Tail,HV).
6811 % ai_observation_abstract_goal(C,[AC|Tail],Tail,HV) :-
6812 % ai_observation_abstract_constraint(C,AC), !. % CHR constraint
6813 % ai_observation_abstract_goal(true,Tail,Tail,_) :- !.
6814 % ai_observation_abstract_goal(writeln(_),Tail,Tail,_) :- !.
6815 % % non-CHR constraint is safe if it only binds fresh variables
6816 % ai_observation_abstract_goal(G,Tail,Tail,HV) :-
6817 % binds_b(G,Vars),
6818 % intersect_eq(Vars,HV,[]),
6819 % !.
6820 % ai_observation_abstract_goal(G,[AG|Tail],Tail,_) :-
6821 % AG = builtin. % default case if goal is not recognized/safe
6822 %
6823 % ai_observation_is_observed(odom(_,ACSet),AC) :-
6824 % AC /\ ACSet =:= 0.
6825 %
6826 %
6828 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6829 % Observation Analysis
6830 %
6831 % CLASSIFICATION
6832 % Enabled
6833 %
6834 % Analysis based on Abstract Interpretation paper.
6835 %
6836 % TODO:
6837 % stronger analysis domain [research]
6839 :- chr_constraint
6840 initial_call_pattern/1,
6841 call_pattern/1,
6842 call_pattern_worker/1,
6843 final_answer_pattern/2,
6844 abstract_constraints/1,
6845 depends_on/2,
6846 depends_on_ap/4,
6847 depends_on_goal/2,
6848 ai_observed_internal/2,
6849 % ai_observed/2,
6850 ai_not_observed_internal/2,
6851 ai_not_observed/2,
6852 ai_is_observed/2,
6853 depends_on_as/3,
6854 ai_observation_gather_results/0.
6856 :- chr_option(type_definition,type(abstract_domain,[odom(any,any)])).
6858 :- chr_option(mode,initial_call_pattern(+)).
6859 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6861 :- chr_option(mode,call_pattern(+)).
6862 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6864 :- chr_option(mode,call_pattern_worker(+)).
6865 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
6867 :- chr_option(mode,final_answer_pattern(+,+)).
6868 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
6870 :- chr_option(mode,abstract_constraints(+)).
6871 :- chr_option(type_declaration,abstract_constraints(list)).
6873 :- chr_option(mode,depends_on(+,+)).
6874 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
6876 :- chr_option(mode,depends_on_as(+,+,+)).
6877 :- chr_option(mode,depends_on_ap(+,+,+,+)).
6878 :- chr_option(mode,depends_on_goal(+,+)).
6879 :- chr_option(mode,ai_is_observed(+,+)).
6880 :- chr_option(mode,ai_not_observed(+,+)).
6881 % :- chr_option(mode,ai_observed(+,+)).
6882 :- chr_option(mode,ai_not_observed_internal(+,+)).
6883 :- chr_option(mode,ai_observed_internal(+,+)).
6886 abstract_constraints_fd @
6887 abstract_constraints(_) \ abstract_constraints(_) <=> true.
6889 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6890 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6891 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
6893 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
6894 ai_is_observed(_,_) <=> true.
6896 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
6897 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
6898 ai_observation_gather_results <=> true.
6900 %------------------------------------------------------------------------------%
6901 % Main Analysis Entry
6902 %------------------------------------------------------------------------------%
6903 ai_observation_analysis(ACs) :-
6904 ( chr_pp_flag(ai_observation_analysis,on),
6905 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
6906 list_to_ord_set(ACs,ACSet),
6907 abstract_constraints(ACSet),
6908 ai_observation_schedule_initial_calls(ACSet,ACSet),
6909 ai_observation_gather_results
6910 ;
6911 true
6912 ).
6914 ai_observation_schedule_initial_calls([],_).
6915 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
6916 ai_observation_schedule_initial_call(AC,ACs),
6917 ai_observation_schedule_initial_calls(RACs,ACs).
6919 ai_observation_schedule_initial_call(AC,ACs) :-
6920 ai_observation_top(AC,CallPattern),
6921 % ai_observation_bot(AC,ACs,CallPattern),
6922 initial_call_pattern(CallPattern).
6924 ai_observation_schedule_new_calls([],AP).
6925 ai_observation_schedule_new_calls([AC|ACs],AP) :-
6926 AP = odom(_,Set),
6927 initial_call_pattern(odom(AC,Set)),
6928 ai_observation_schedule_new_calls(ACs,AP).
6930 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
6931 <=>
6932 ai_observation_leq(AP2,AP1)
6933 |
6934 true.
6936 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
6938 initial_call_pattern(CP) ==> call_pattern(CP).
6940 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
6941 ==>
6942 ai_observation_schedule_new_calls(ACs,AP)
6943 pragma
6944 passive(ID3).
6946 call_pattern(CP) \ call_pattern(CP) <=> true.
6948 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
6949 final_answer_pattern(CP1,AP).
6951 %call_pattern(CP) ==> writeln(call_pattern(CP)).
6953 call_pattern(CP) ==> call_pattern_worker(CP).
6955 %------------------------------------------------------------------------------%
6956 % Abstract Goal
6957 %------------------------------------------------------------------------------%
6959 % AbstractGoala
6960 %call_pattern(odom([],Set)) ==>
6961 % final_answer_pattern(odom([],Set),odom([],Set)).
6963 call_pattern_worker(odom([],Set)) <=>
6964 % writeln(' - AbstractGoal'(odom([],Set))),
6965 final_answer_pattern(odom([],Set),odom([],Set)).
6967 % AbstractGoalb
6968 call_pattern_worker(odom([G|Gs],Set)) <=>
6969 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
6970 CP1 = odom(G,Set),
6971 depends_on_goal(odom([G|Gs],Set),CP1),
6972 call_pattern(CP1).
6974 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
6975 <=> true pragma passive(ID).
6976 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
6977 ==>
6978 CP1 = odom([_|Gs],_),
6979 AP2 = odom([],Set),
6980 CCP = odom(Gs,Set),
6981 call_pattern(CCP),
6982 depends_on(CP1,CCP).
6984 %------------------------------------------------------------------------------%
6985 % Abstract Solve
6986 %------------------------------------------------------------------------------%
6987 call_pattern_worker(odom(builtin,Set)) <=>
6988 % writeln(' - AbstractSolve'(odom(builtin,Set))),
6989 ord_empty(EmptySet),
6990 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
6992 %------------------------------------------------------------------------------%
6993 % Abstract Drop
6994 %------------------------------------------------------------------------------%
6995 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6996 <=>
6997 O > MO
6998 |
6999 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
7000 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
7001 pragma
7002 passive(ID2).
7004 %------------------------------------------------------------------------------%
7005 % Abstract Activate
7006 %------------------------------------------------------------------------------%
7007 call_pattern_worker(odom(AC,Set))
7008 <=>
7009 AC = _ / _
7010 |
7011 % writeln(' - AbstractActivate'(odom(AC,Set))),
7012 CP = odom(occ(AC,1),Set),
7013 call_pattern(CP),
7014 depends_on(odom(AC,Set),CP).
7016 %------------------------------------------------------------------------------%
7017 % Abstract Passive
7018 %------------------------------------------------------------------------------%
7019 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7020 <=>
7021 is_passive(RuleNb,ID)
7022 |
7023 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
7024 % DEFAULT
7025 NO is O + 1,
7026 DCP = odom(occ(C,NO),Set),
7027 call_pattern(DCP),
7028 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
7029 depends_on(odom(occ(C,O),Set),DCP)
7030 pragma
7031 passive(ID2).
7032 %------------------------------------------------------------------------------%
7033 % Abstract Simplify
7034 %------------------------------------------------------------------------------%
7036 % AbstractSimplify
7037 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7038 <=>
7039 \+ is_passive(RuleNb,ID)
7040 |
7041 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
7042 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
7043 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
7044 ai_observation_memo_abstract_goal(RuleNb,AG),
7045 call_pattern(odom(AG,Set2)),
7046 % DEFAULT
7047 NO is O + 1,
7048 DCP = odom(occ(C,NO),Set),
7049 call_pattern(DCP),
7050 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
7051 % DEADLOCK AVOIDANCE
7052 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
7053 pragma
7054 passive(ID2).
7056 depends_on_as(CP,CPS,CPD),
7057 final_answer_pattern(CPS,APS),
7058 final_answer_pattern(CPD,APD) ==>
7059 ai_observation_lub(APS,APD,AP),
7060 final_answer_pattern(CP,AP).
7063 :- chr_constraint
7064 ai_observation_memo_simplification_rest_heads/3,
7065 ai_observation_memoed_simplification_rest_heads/3.
7067 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
7068 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
7070 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
7071 <=>
7072 QRH = RH.
7073 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
7074 <=>
7075 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
7076 once(select2(ID,_,IDs1,H1,_,RestH1)),
7077 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
7078 ai_observation_abstract_constraints(H2,ACs,AH2),
7079 append(ARestHeads,AH2,AbstractHeads),
7080 sort(AbstractHeads,QRH),
7081 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
7082 pragma
7083 passive(ID1),
7084 passive(ID2),
7085 passive(ID3).
7087 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
7089 %------------------------------------------------------------------------------%
7090 % Abstract Propagate
7091 %------------------------------------------------------------------------------%
7094 % AbstractPropagate
7095 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7096 <=>
7097 \+ is_passive(RuleNb,ID)
7098 |
7099 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
7100 % observe partners
7101 ai_observation_memo_propagation_rest_heads(C,O,AHs),
7102 ai_observation_observe_set(Set,AHs,Set2),
7103 ord_add_element(Set2,C,Set3),
7104 ai_observation_memo_abstract_goal(RuleNb,AG),
7105 call_pattern(odom(AG,Set3)),
7106 ( ord_memberchk(C,Set2) ->
7107 Delete = no
7108 ;
7109 Delete = yes
7110 ),
7111 % DEFAULT
7112 NO is O + 1,
7113 DCP = odom(occ(C,NO),Set),
7114 call_pattern(DCP),
7115 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
7116 pragma
7117 passive(ID2).
7119 :- chr_constraint
7120 ai_observation_memo_propagation_rest_heads/3,
7121 ai_observation_memoed_propagation_rest_heads/3.
7123 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
7124 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
7126 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
7127 <=>
7128 QRH = RH.
7129 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
7130 <=>
7131 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
7132 once(select2(ID,_,IDs2,H2,_,RestH2)),
7133 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
7134 ai_observation_abstract_constraints(H1,ACs,AH1),
7135 append(ARestHeads,AH1,AbstractHeads),
7136 sort(AbstractHeads,QRH),
7137 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
7138 pragma
7139 passive(ID1),
7140 passive(ID2),
7141 passive(ID3).
7143 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
7145 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
7146 final_answer_pattern(CP,APD).
7147 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
7148 final_answer_pattern(CPD,APD) ==>
7149 true |
7150 CP = odom(occ(C,O),_),
7151 ( ai_observation_is_observed(APP,C) ->
7152 ai_observed_internal(C,O)
7153 ;
7154 ai_not_observed_internal(C,O)
7155 ),
7156 ( Delete == yes ->
7157 APP = odom([],Set0),
7158 ord_del_element(Set0,C,Set),
7159 NAPP = odom([],Set)
7160 ;
7161 NAPP = APP
7162 ),
7163 ai_observation_lub(NAPP,APD,AP),
7164 final_answer_pattern(CP,AP).
7166 %------------------------------------------------------------------------------%
7167 % Catch All
7168 %------------------------------------------------------------------------------%
7170 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
7172 %------------------------------------------------------------------------------%
7173 % Auxiliary Predicates
7174 %------------------------------------------------------------------------------%
7176 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
7177 ord_intersection(S1,S2,S3).
7179 ai_observation_bot(AG,AS,odom(AG,AS)).
7181 ai_observation_top(AG,odom(AG,EmptyS)) :-
7182 ord_empty(EmptyS).
7184 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
7185 ord_subset(S2,S1).
7187 ai_observation_observe_set(S,ACSet,NS) :-
7188 ord_subtract(S,ACSet,NS).
7190 ai_observation_abstract_constraint(C,ACs,AC) :-
7191 functor(C,F,A),
7192 AC = F/A,
7193 memberchk(AC,ACs).
7195 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
7196 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
7198 %------------------------------------------------------------------------------%
7199 % Abstraction of Rule Bodies
7200 %------------------------------------------------------------------------------%
7202 :- chr_constraint
7203 ai_observation_memoed_abstract_goal/2,
7204 ai_observation_memo_abstract_goal/2.
7206 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
7207 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
7209 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
7210 <=>
7211 QAG = AG
7212 pragma
7213 passive(ID1).
7215 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
7216 <=>
7217 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
7218 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
7219 QAG = AG,
7220 ai_observation_memoed_abstract_goal(RuleNb,AG)
7221 pragma
7222 passive(ID1),
7223 passive(ID2).
7225 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
7226 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
7227 term_variables((H1,H2,Guard),HVars),
7228 append(H1,H2,Heads),
7229 % variables that are declared to be ground are safe,
7230 ground_vars(Heads,GroundVars),
7231 % so we remove them from the list of 'dangerous' head variables
7232 list_difference_eq(HVars,GroundVars,HV),
7233 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
7234 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
7235 % HV are 'dangerous' variables, all others are fresh and safe
7237 ground_vars([],[]).
7238 ground_vars([H|Hs],GroundVars) :-
7239 functor(H,F,A),
7240 get_constraint_mode(F/A,Mode),
7241 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
7242 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
7243 ground_vars(Hs,GroundVars2),
7244 append(GroundVars1,GroundVars2,GroundVars).
7246 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
7247 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
7248 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
7249 ai_observation_abstract_goal((G1;G2),ACs,List,Tail,HV) :- !, % disjunction
7250 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
7251 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
7252 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
7253 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
7254 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
7255 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
7256 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
7257 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
7258 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
7259 % non-CHR constraint is safe if it only binds fresh variables
7260 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
7261 builtin_binds_b(G,Vars),
7262 intersect_eq(Vars,HV,[]),
7263 !.
7264 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
7265 AG = builtin. % default case if goal is not recognized/safe
7267 ai_observation_is_observed(odom(_,ACSet),AC) :-
7268 \+ ord_memberchk(AC,ACSet).
7270 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7271 unconditional_occurrence(C,O) :-
7272 get_occurrence(C,O,RuleNb,ID),
7273 get_rule(RuleNb,PRule),
7274 PRule = pragma(ORule,_,_,_,_),
7275 copy_term_nat(ORule,Rule),
7276 Rule = rule(H1,H2,Guard,_),
7277 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
7278 once((
7279 H1 = [Head], H2 == []
7280 ;
7281 H2 = [Head], H1 == [], \+ may_trigger(C)
7282 )),
7283 functor(Head,F,A),
7284 Head =.. [_|Args],
7285 unconditional_occurrence_args(Args).
7287 unconditional_occurrence_args([]).
7288 unconditional_occurrence_args([X|Xs]) :-
7289 var(X),
7290 X = x,
7291 unconditional_occurrence_args(Xs).
7293 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7295 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7296 % Partial wake analysis
7297 %
7298 % In a Var = Var unification do not wake up constraints of both variables,
7299 % but rather only those of one variable.
7300 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7302 :- chr_constraint
7303 partial_wake_analysis/0,
7304 no_partial_wake/1,
7305 wakes_partially/1.
7307 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
7308 ==>
7309 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
7310 ( is_passive(RuleNb,ID) ->
7311 true
7312 ; Type == simplification ->
7313 select(H,H1,RestH1),
7314 H =.. [_|Args],
7315 term_variables(Guard,Vars),
7316 partial_wake_args(Args,ArgModes,Vars,FA)
7317 ; % Type == propagation ->
7318 select(H,H2,RestH2),
7319 H =.. [_|Args],
7320 term_variables(Guard,Vars),
7321 partial_wake_args(Args,ArgModes,Vars,FA)
7322 ).
7324 partial_wake_args([],_,_,_).
7325 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
7326 ( Mode \== (+) ->
7327 ( nonvar(Arg) ->
7328 no_partial_wake(C)
7329 ; memberchk_eq(Arg,Vars) ->
7330 no_partial_wake(C)
7331 ;
7332 true
7333 )
7334 ;
7335 true
7336 ),
7337 partial_wake_args(Args,Modes,Vars,C).
7339 no_partial_wake(C) \ no_partial_wake(C) <=> true.
7341 no_partial_wake(C) \ wakes_partially(C) <=> fail.
7343 wakes_partially(C) <=> true.
7346 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7347 % Generate rules that implement chr_show_store/1 functionality.
7348 %
7349 % CLASSIFICATION
7350 % Experimental
7351 % Unused
7352 %
7353 % Generates additional rules:
7354 %
7355 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
7356 % ...
7357 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
7358 % $show <=> true.
7360 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
7361 ( chr_pp_flag(show,on) ->
7362 Constraints = ['$show'/0|Constraints0],
7363 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
7364 inc_rule_count(RuleNb),
7365 Rule = pragma(
7366 rule(['$show'],[],true,true),
7367 ids([0],[]),
7368 [],
7369 no,
7370 RuleNb
7371 )
7372 ;
7373 Constraints = Constraints0,
7374 Rules = Rules0
7375 ).
7377 generate_show_rules([],Rules,Rules).
7378 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
7379 functor(C,F,A),
7380 inc_rule_count(RuleNb),
7381 Rule = pragma(
7382 rule([],['$show',C],true,writeln(C)),
7383 ids([],[0,1]),
7384 [passive(1)],
7385 no,
7386 RuleNb
7387 ),
7388 generate_show_rules(Rest,Tail,Rules).
7390 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7391 % Custom supension term layout
7393 static_suspension_term(F/A,Suspension) :-
7394 suspension_term_base(F/A,Base),
7395 Arity is Base + A,
7396 functor(Suspension,suspension,Arity).
7398 suspension_term_base(FA,Base) :-
7399 suspension_term_base_fields(FA,Fields),
7400 length(Fields,Base).
7402 suspension_term_base_fields(FA,Fields) :-
7403 Fields = [id,state|Fields1],
7404 ( chr_pp_flag(debugable,on) ->
7405 % 1. ID
7406 % 2. State
7407 % 3. Propagation History
7408 % 4. Generation Number
7409 % 5. Continuation Goal
7410 % 6. Functor
7411 Fields1 = [history,generation,continuation,functor]
7412 ;
7413 ( uses_history(FA) ->
7414 Fields1 = [history|Fields2]
7415 ;
7416 Fields1 = Fields2
7417 ),
7418 ( only_ground_indexed_arguments(FA) ->
7419 get_store_type(FA,StoreType),
7420 basic_store_types(StoreType,BasicStoreTypes),
7421 ( memberchk(global_ground,BasicStoreTypes) ->
7422 % 1. ID
7423 % 2. State
7424 % 3. Propagation History
7425 % 4. Global List Prev
7426 Fields2 = [global_list_prev]
7427 ;
7428 % 1. ID
7429 % 2. State
7430 % 3. Propagation History
7431 Fields2 = []
7432 )
7433 ; may_trigger(FA) ->
7434 % 1. ID
7435 % 2. State
7436 % 3. Propagation History
7437 % 4. Generation Number
7438 % 5. Continuation Goal
7439 % 6. Global List Prev
7440 Fields2 = [generation,continuation,global_list_prev]
7441 ;
7442 % 1. ID
7443 % 2. State
7444 % 3. Propagation History
7445 % 4. Global List Prev
7446 Fields2 = [global_list_prev]
7447 )
7448 ).
7450 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
7451 suspension_term_base_fields(FA,Fields),
7452 nth(Index,Fields,FieldName), !,
7453 arg(Index,StaticSuspension,Field).
7454 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
7455 suspension_term_base(FA,Base),
7456 StaticSuspension =.. [_|Args],
7457 drop(Base,Args,Field).
7458 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
7459 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
7462 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7463 suspension_term_base_fields(FA,Fields),
7464 nth(Index,Fields,FieldName), !,
7465 Goal = arg(Index,DynamicSuspension,Field).
7466 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
7467 static_suspension_term(FA,StaticSuspension),
7468 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
7469 Goal = (DynamicSuspension = StaticSuspension).
7470 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
7471 suspension_term_base(FA,Base),
7472 Index is I + Base,
7473 Goal = arg(Index,DynamicSuspension,Field).
7474 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7475 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
7478 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7479 suspension_term_base_fields(FA,Fields),
7480 nth(Index,Fields,FieldName), !,
7481 Goal = setarg(Index,DynamicSuspension,Field).
7482 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7483 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
7485 basic_store_types(multi_store(Types),Types) :- !.
7486 basic_store_types(Type,[Type]).
7488 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7489 %
7491 :- chr_constraint
7492 phase_end/1,
7493 delay_phase_end/2.
7495 :- chr_option(mode,phase_end(+)).
7496 :- chr_option(mode,delay_phase_end(+,?)).
7498 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
7499 phase_end(Phase) <=> true.
7502 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7503 % Issues: run_suspension still has hardcoded argument index > 3
7505 :- chr_constraint
7506 does_use_history/2,
7507 uses_history/1,
7508 novel_production_call/4.
7510 :- chr_option(mode,uses_history(+)).
7511 :- chr_option(mode,does_use_history(+,+)).
7512 :- chr_option(mode,novel_production_call(+,+,?,?)).
7514 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
7515 does_use_history(FA,_) \ uses_history(FA) <=> true.
7516 uses_history(_FA) <=> fail.
7518 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
7519 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
7521 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7522 % Counter number of calls to generated predicates, if == 1 then inline...