?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* Add missing file
[chr.git] / chr_translate_bootstrap.pl
blob2284b485282c6ea0ed7153b74aa46f56549b3d03
1 /* $Id$
2
3 Part of CHR (Constraint Handling Rules)
4
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
9
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.
14
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.
19
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
23
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 */
31
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 %% To Do
51 %%
52 %% * SICStus compatibility
53 %% - rules/1 declaration
54 %% - options
55 %% - pragmas
56 %% - tell guard
57 %%
58 %%
59 %% * do not suspend on variables that don't matter
60 %% * make difference between cheap guards for reordering
61 %% and non-binding guards for lock removal
62 %%
63 %% * unqiue -> once/[] transformation for propagation
64 %%
65 %% * cheap guards interleaved with head retrieval + faster
66 %% via-retrieval + non-empty checking for propagation rules
67 %% redo for simpagation_head2 prelude
68 %%
69 %% * intelligent backtracking for simplification/simpagation rule
70 %% generator_1(X),'_$savecp'(CP_1),
71 %% ...
72 %% if( (
73 %% generator_n(Y),
74 %% test(X,Y)
75 %% ),
76 %% true,
77 %% ('_$cutto'(CP_1), fail)
78 %% ),
79 %% ...
80 %%
81 %% or recently developped cascading-supported approach
82 %%
83 %% * intelligent backtracking for propagation rule
84 %% use additional boolean argument for each possible smart backtracking
85 %% when boolean at end of list true -> no smart backtracking
86 %% false -> smart backtracking
87 %% only works for rules with at least 3 constraints in the head
88 %%
89 %% * mutually exclusive rules
90 %%
91 %% * constraints that can never be attached / always simplified away
92 %% -> need not be considered in diverse operations
93 %%
94 %% * (set semantics + functional dependency) declaration + resolution
95 %%
96 %% * type and instantiation declarations + optimisations
97 %% + better indexes
98 %%
99 %% * disable global store option
100 %%
101 %% Done
102 %%
103 %% * clean up generated code
104 %% * input verification: pragmas
105 %% * SICStus compatibility: handler/1, constraints/1
106 %% * optimise variable passing for propagation rule
107 %% * reordering of head constraints for passive head search
108 %% * unique inference for simpagation rules
109 %% * unique optimisation for simpagation and simplification rules
110 %% * cheap guards interleaved with head retrieval + faster
111 %% via-retrieval + non-empty checking for simplification / simpagation rules
112 %% * transform
113 %% C \ C <=> true
114 %% into
115 %% C # ID \ C <=> true pragma passive.
116 %% * valid to disregard body in uniqueness inference?
117 %% * unique inference for simplification rules
118 %%
119 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
120
121 :- module(chr_translate,
122 [ chr_translate/2 % +Decls, -TranslatedDecls
123 ]).
124 :- use_module(library(lists)).
125 :- use_module(hprolog).
126 :- use_module(library(assoc)).
127 :- use_module(pairlist).
128 :- use_module(library(ordsets)).
129 :- include(chr_op).
130
131 %% SICStus begin
132 %% :- use_module(library(terms),[term_variables/2]).
133 %% SICStus end
134
135
136 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
137 %%
138 %% Translation
139
140 chr_translate(Declarations,NewDeclarations) :-
141 init_chr_pp_flags,
142 partition_clauses(Declarations,Decls,Rules,OtherClauses,Mod),
143 default(Mod,user),
144 ( Decls == [] ->
145 NewDeclarations = OtherClauses
146 ;
147 check_rules(Rules,Decls),
148 unique_analyse_optimise(Rules,1,[],NRules),
149 generate_attach_a_constraint_all(Decls,Mod,AttachAConstraintClauses),
150 generate_detach_a_constraint_all(Decls,Mod,DettachAConstraintClauses),
151 generate_attach_increment(Decls,Mod,AttachIncrementClauses),
152 generate_attr_unify_hook(Decls,Mod,AttrUnifyHookClauses),
153 constraints_code(Decls,NRules,Mod,ConstraintClauses),
154 append_lists([ OtherClauses,
155 AttachAConstraintClauses,
156 DettachAConstraintClauses,
157 AttachIncrementClauses,
158 AttrUnifyHookClauses,
159 ConstraintClauses
160 ],
161 NewDeclarations)
162 ).
163
164
165
166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
167 %%
168 %% Partitioning of clauses into constraint declarations, chr rules and other
169 %% clauses
170
171 partition_clauses([],[],[],[],_).
172 partition_clauses([C|Cs],Ds,Rs,OCs,Mod) :-
173 ( rule(C,R) ->
174 Ds = RDs,
175 Rs = [R | RRs],
176 OCs = ROCs
177 ; is_declaration(C,D) ->
178 append(D,RDs,Ds),
179 Rs = RRs,
180 OCs = ROCs
181 ; is_module_declaration(C,Mod) ->
182 Ds = RDs,
183 Rs = RRs,
184 OCs = [C|ROCs]
185 ; C = (handler _) ->
186 format('CHR compiler WARNING: ~w.\n',[C]),
187 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
188 Ds = RDs,
189 Rs = RRs,
190 OCs = ROCs
191 ; C = (rules _) ->
192 format('CHR compiler WARNING: ~w.\n',[C]),
193 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
194 Ds = RDs,
195 Rs = RRs,
196 OCs = ROCs
197 ; C = (:- chr_option(OptionName,OptionValue)) ->
198 handle_option(OptionName,OptionValue),
199 Ds = RDs,
200 Rs = RRs,
201 OCs = ROCs
202 ; Ds = RDs,
203 Rs = RRs,
204 OCs = [C|ROCs]
205 ),
206 partition_clauses(Cs,RDs,RRs,ROCs,Mod).
207
208 is_declaration(D, Constraints) :- %% constraint declaration
209 D = (:- Decl),
210 ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
211 conj2list(Cs,Constraints).
212
213 %% Data Declaration
214 %%
215 %% pragma_rule
216 %% -> pragma(
217 %% rule,
218 %% ids,
219 %% list(pragma),
220 %% yesno(string)
221 %% )
222 %%
223 %% ids -> ids(
224 %% list(int),
225 %% list(int)
226 %% )
227 %%
228 %% rule -> rule(
229 %% list(constraint), :: constraints to be removed
230 %% list(constraint), :: surviving constraints
231 %% goal, :: guard
232 %% goal :: body
233 %% )
234
235 rule(RI,R) :- %% name @ rule
236 RI = (Name @ RI2), !,
237 rule(RI2,yes(Name),R).
238 rule(RI,R) :-
239 rule(RI,no,R).
240
241 rule(RI,Name,R) :-
242 RI = (RI2 pragma P), !, %% pragmas
243 is_rule(RI2,R1,IDs),
244 conj2list(P,Ps),
245 R = pragma(R1,IDs,Ps,Name).
246 rule(RI,Name,R) :-
247 is_rule(RI,R1,IDs),
248 R = pragma(R1,IDs,[],Name).
249
250 is_rule(RI,R,IDs) :- %% propagation rule
251 RI = (H ==> B), !,
252 conj2list(H,Head2i),
253 get_ids(Head2i,IDs2,Head2),
254 IDs = ids([],IDs2),
255 ( B = (G | RB) ->
256 R = rule([],Head2,G,RB)
257 ;
258 R = rule([],Head2,true,B)
259 ).
260 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
261 RI = (H <=> B), !,
262 ( B = (G | RB) ->
263 Guard = G,
264 Body = RB
265 ; Guard = true,
266 Body = B
267 ),
268 ( H = (H1 \ H2) ->
269 conj2list(H1,Head2i),
270 conj2list(H2,Head1i),
271 get_ids(Head2i,IDs2,Head2,0,N),
272 get_ids(Head1i,IDs1,Head1,N,_),
273 IDs = ids(IDs1,IDs2)
274 ; conj2list(H,Head1i),
275 Head2 = [],
276 get_ids(Head1i,IDs1,Head1),
277 IDs = ids(IDs1,[])
278 ),
279 R = rule(Head1,Head2,Guard,Body).
280
281 get_ids(Cs,IDs,NCs) :-
282 get_ids(Cs,IDs,NCs,0,_).
283
284 get_ids([],[],[],N,N).
285 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
286 ( C = (NC # N) ->
287 true
288 ;
289 NC = C
290 ),
291 M is N + 1,
292 get_ids(Cs,IDs,NCs, M,NN).
293
294 is_module_declaration((:- module(Mod)),Mod).
295 is_module_declaration((:- module(Mod,_)),Mod).
296
297 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
298
299 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
300 %% Some input verification:
301 %% - all constraints in heads are declared constraints
302
303 check_rules(Rules,Decls) :-
304 check_rules(Rules,Decls,1).
305
306 check_rules([],_,_).
307 check_rules([PragmaRule|Rest],Decls,N) :-
308 check_rule(PragmaRule,Decls,N),
309 N1 is N + 1,
310 check_rules(Rest,Decls,N1).
311
312 check_rule(PragmaRule,Decls,N) :-
313 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name),
314 Rule = rule(H1,H2,_,_),
315 append(H1,H2,HeadConstraints),
316 check_head_constraints(HeadConstraints,Decls,PragmaRule,N),
317 check_pragmas(Pragmas,PragmaRule,N).
318
319 check_head_constraints([],_,_,_).
320 check_head_constraints([Constr|Rest],Decls,PragmaRule,N) :-
321 functor(Constr,F,A),
322 ( member(F/A,Decls) ->
323 check_head_constraints(Rest,Decls,PragmaRule,N)
324 ;
325 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
326 [F/A,format_rule(PragmaRule,N)]),
327 format(' `--> Constraint should be on of ~w.\n',[Decls]),
328 fail
329 ).
330
331 check_pragmas([],_,_).
332 check_pragmas([Pragma|Pragmas],PragmaRule,N) :-
333 check_pragma(Pragma,PragmaRule,N),
334 check_pragmas(Pragmas,PragmaRule,N).
335
336 check_pragma(Pragma,PragmaRule,N) :-
337 var(Pragma), !,
338 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
339 [Pragma,format_rule(PragmaRule,N)]),
340 format(' `--> Pragma should not be a variable!\n',[]),
341 fail.
342
343 check_pragma(passive(ID), PragmaRule, N) :-
344 !,
345 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_),
346 ( memberchk_eq(ID,IDs1) ->
347 true
348 ; memberchk_eq(ID,IDs2) ->
349 true
350 ;
351 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
352 [ID,format_rule(PragmaRule,N)]),
353 fail
354 ).
355
356 check_pragma(Pragma, PragmaRule, N) :-
357 Pragma = unique(_,_),
358 !,
359 format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
360 format(' `--> Only use this pragma if you know what you are doing.\n',[]).
361
362 check_pragma(Pragma, PragmaRule, N) :-
363 Pragma = already_in_heads,
364 !,
365 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
366 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
367
368 check_pragma(Pragma, PragmaRule, N) :-
369 Pragma = already_in_head(_),
370 !,
371 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
372 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
373
374 check_pragma(Pragma,PragmaRule,N) :-
375 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
376 format(' `--> Pragma should be one of passive/1!\n',[]),
377 fail.
378
379 format_rule(PragmaRule,N) :-
380 PragmaRule = pragma(_,_,_,MaybeName),
381 ( MaybeName = yes(Name) ->
382 write('rule '), write(Name)
383 ;
384 write('rule number '), write(N)
385 ).
386
387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
388
389 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
390 % Global Options
391 %
392
393 handle_option(Var,Value) :-
394 var(Var), !,
395 format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
396 format(' `--> First argument should be an atom, not a variable.\n',[]),
397 fail.
398
399 handle_option(Name,Value) :-
400 var(Value), !,
401 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
402 format(' `--> Second argument should be a nonvariable.\n',[]),
403 fail.
404
405 handle_option(Name,Value) :-
406 option_definition(Name,Value,Flags),
407 !,
408 set_chr_pp_flags(Flags).
409
410 handle_option(Name,Value) :-
411 \+ option_definition(Name,_,_), !,
412 setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
413 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
414 format(' `--> Invalid option name ~w: should be one of ~w.\n',[Name,Ns]),
415 fail.
416
417 handle_option(Name,Value) :-
418 findall(V,option_definition(Name,V,_),Vs),
419 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
420 format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
421 fail.
422
423 option_definition(optimize,full,Flags) :-
424 Flags = [ unique_analyse_optimise - on,
425 check_unnecessary_active - full,
426 reorder_heads - on,
427 set_semantics_rule - on,
428 guard_via_reschedule - on
429 ].
430
431 option_definition(optimize,sicstus,Flags) :-
432 Flags = [ unique_analyse_optimise - off,
433 check_unnecessary_active - simplification,
434 reorder_heads - off,
435 set_semantics_rule - off,
436 guard_via_reschedule - off
437 ].
438
439 option_definition(optimize,off,Flags) :-
440 Flags = [ unique_analyse_optimise - off,
441 check_unnecessary_active - off,
442 reorder_heads - off,
443 set_semantics_rule - off,
444 guard_via_reschedule - off
445 ].
446
447 option_definition(check_guard_bindings,on,Flags) :-
448 Flags = [ guard_locks - on ].
449
450 option_definition(check_guard_bindings,off,Flags) :-
451 Flags = [ guard_locks - off ].
452
453 init_chr_pp_flags :-
454 chr_pp_flag_definition(Name,[DefaultValue|_]),
455 set_chr_pp_flag(Name,DefaultValue),
456 fail.
457 init_chr_pp_flags.
458
459 set_chr_pp_flags([]).
460 set_chr_pp_flags([Name-Value|Flags]) :-
461 set_chr_pp_flag(Name,Value),
462 set_chr_pp_flags(Flags).
463
464 set_chr_pp_flag(Name,Value) :-
465 atom_concat('$chr_pp_',Name,GlobalVar),
466 nb_setval(GlobalVar,Value).
467
468 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
469 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
470 chr_pp_flag_definition(reorder_heads,[on,off]).
471 chr_pp_flag_definition(set_semantics_rule,[on,off]).
472 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
473 chr_pp_flag_definition(guard_locks,[on,off]).
474
475 chr_pp_flag(Name,Value) :-
476 atom_concat('$chr_pp_',Name,GlobalVar),
477 nb_getval(GlobalVar,V),
478 ( V == [] ->
479 chr_pp_flag_definition(Name,[Value|_])
480 ;
481 V = Value
482 ).
483 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
484
485 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
486 %%
487 %% Generated predicates
488 %% attach_$CONSTRAINT
489 %% attach_increment
490 %% detach_$CONSTRAINT
491 %% attr_unify_hook
492
493 %% attach_$CONSTRAINT
494 generate_attach_a_constraint_all(Constraints,Mod,Clauses) :-
495 length(Constraints,Total),
496 generate_attach_a_constraint_all(Constraints,1,Total,Mod,Clauses).
497
498 generate_attach_a_constraint_all([],_,_,_,[]).
499 generate_attach_a_constraint_all([Constraint|Constraints],Position,Total,Mod,Clauses) :-
500 generate_attach_a_constraint(Total,Position,Constraint,Mod,Clauses1),
501 NextPosition is Position + 1,
502 generate_attach_a_constraint_all(Constraints,NextPosition,Total,Mod,Clauses2),
503 append(Clauses1,Clauses2,Clauses).
504
505 generate_attach_a_constraint(Total,Position,Constraint,Mod,[Clause1,Clause2]) :-
506 generate_attach_a_constraint_empty_list(Constraint,Clause1),
507 ( Total == 1 ->
508 generate_attach_a_constraint_1_1(Constraint,Mod,Clause2)
509 ;
510 generate_attach_a_constraint_t_p(Total,Position,Constraint,Mod,Clause2)
511 ).
512
513 generate_attach_a_constraint_empty_list(CFct / CAty,Clause) :-
514 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
515 Args = [[],_],
516 Head =.. [Fct | Args],
517 Clause = ( Head :- true).
518
519 generate_attach_a_constraint_1_1(CFct / CAty,Mod,Clause) :-
520 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
521 Args = [[Var|Vars],Susp],
522 Head =.. [Fct | Args],
523 RecursiveCall =.. [Fct,Vars,Susp],
524 Body =
525 (
526 ( get_attr(Var, Mod, Susps) ->
527 NewSusps=[Susp|Susps],
528 put_attr(Var, Mod, NewSusps)
529 ;
530 put_attr(Var, Mod, [Susp])
531 ),
532 RecursiveCall
533 ),
534 Clause = (Head :- Body).
535
536 generate_attach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
537 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
538 Args = [[Var|Vars],Susp],
539 Head =.. [Fct | Args],
540 RecursiveCall =.. [Fct,Vars,Susp],
541 or_pattern(Position,Pattern),
542 make_attr(Total,Mask,SuspsList,Attr),
543 nth(Position,SuspsList,Susps),
544 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
545 make_attr(Total,Mask,SuspsList1,NewAttr1),
546 substitute(Susps,SuspsList,[Susp],SuspsList2),
547 make_attr(Total,NewMask,SuspsList2,NewAttr2),
548 copy_term(SuspsList,SuspsList3),
549 nth(Position,SuspsList3,[Susp]),
550 chr_delete(SuspsList3,[Susp],RestSuspsList),
551 set_elems(RestSuspsList,[]),
552 make_attr(Total,Pattern,SuspsList3,NewAttr3),
553 Body =
554 (
555 ( get_attr(Var,Mod,TAttr) ->
556 TAttr = Attr,
557 ( Mask /\ Pattern =:= Pattern ->
558 put_attr(Var, Mod, NewAttr1)
559 ;
560 NewMask is Mask \/ Pattern,
561 put_attr(Var, Mod, NewAttr2)
562 )
563 ;
564 put_attr(Var,Mod,NewAttr3)
565 ),
566 RecursiveCall
567 ),
568 Clause = (Head :- Body).
569
570 %% detach_$CONSTRAINT
571 generate_detach_a_constraint_all(Constraints,Mod,Clauses) :-
572 length(Constraints,Total),
573 generate_detach_a_constraint_all(Constraints,1,Total,Mod,Clauses).
574
575 generate_detach_a_constraint_all([],_,_,_,[]).
576 generate_detach_a_constraint_all([Constraint|Constraints],Position,Total,Mod,Clauses) :-
577 generate_detach_a_constraint(Total,Position,Constraint,Mod,Clauses1),
578 NextPosition is Position + 1,
579 generate_detach_a_constraint_all(Constraints,NextPosition,Total,Mod,Clauses2),
580 append(Clauses1,Clauses2,Clauses).
581
582 generate_detach_a_constraint(Total,Position,Constraint,Mod,[Clause1,Clause2]) :-
583 generate_detach_a_constraint_empty_list(Constraint,Clause1),
584 ( Total == 1 ->
585 generate_detach_a_constraint_1_1(Constraint,Mod,Clause2)
586 ;
587 generate_detach_a_constraint_t_p(Total,Position,Constraint,Mod,Clause2)
588 ).
589
590 generate_detach_a_constraint_empty_list(CFct / CAty,Clause) :-
591 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
592 Args = [[],_],
593 Head =.. [Fct | Args],
594 Clause = ( Head :- true).
595
596 generate_detach_a_constraint_1_1(CFct / CAty,Mod,Clause) :-
597 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
598 Args = [[Var|Vars],Susp],
599 Head =.. [Fct | Args],
600 RecursiveCall =.. [Fct,Vars,Susp],
601 Body =
602 (
603 ( get_attr(Var,Mod,Susps) ->
604 'chr sbag_del_element'(Susps,Susp,NewSusps),
605 ( NewSusps == [] ->
606 del_attr(Var,Mod)
607 ;
608 put_attr(Var,Mod,NewSusps)
609 )
610 ;
611 true
612 ),
613 RecursiveCall
614 ),
615 Clause = (Head :- Body).
616
617 generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
618 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
619 Args = [[Var|Vars],Susp],
620 Head =.. [Fct | Args],
621 RecursiveCall =.. [Fct,Vars,Susp],
622 or_pattern(Position,Pattern),
623 and_pattern(Position,DelPattern),
624 make_attr(Total,Mask,SuspsList,Attr),
625 nth(Position,SuspsList,Susps),
626 substitute(Susps,SuspsList,[],SuspsList1),
627 make_attr(Total,NewMask,SuspsList1,Attr1),
628 substitute(Susps,SuspsList,NewSusps,SuspsList2),
629 make_attr(Total,Mask,SuspsList2,Attr2),
630 Body =
631 (
632 ( get_attr(Var,Mod,TAttr) ->
633 TAttr = Attr,
634 ( Mask /\ Pattern =:= Pattern ->
635 'chr sbag_del_element'(Susps,Susp,NewSusps),
636 ( NewSusps == [] ->
637 NewMask is Mask /\ DelPattern,
638 ( NewMask == 0 ->
639 del_attr(Var,Mod)
640 ;
641 put_attr(Var,Mod,Attr1)
642 )
643 ;
644 put_attr(Var,Mod,Attr2)
645 )
646 ;
647 true
648 )
649 ;
650 true
651 ),
652 RecursiveCall
653 ),
654 Clause = (Head :- Body).
655
656 %% detach_$CONSTRAINT
657 generate_attach_increment(Constraints,Mod,[Clause1,Clause2]) :-
658 generate_attach_increment_empty(Clause1),
659 length(Constraints,N),
660 ( N == 1 ->
661 generate_attach_increment_one(Mod,Clause2)
662 ;
663 generate_attach_increment_many(N,Mod,Clause2)
664 ).
665
666 generate_attach_increment_empty((attach_increment([],_) :- true)).
667
668 generate_attach_increment_one(Mod,Clause) :-
669 Head = attach_increment([Var|Vars],Susps),
670 Body =
671 (
672 'chr not_locked'(Var),
673 ( get_attr(Var,Mod,VarSusps) ->
674 sort(VarSusps,SortedVarSusps),
675 merge(Susps,SortedVarSusps,MergedSusps),
676 put_attr(Var,Mod,MergedSusps)
677 ;
678 put_attr(Var,Mod,Susps)
679 ),
680 attach_increment(Vars,Susps)
681 ),
682 Clause = (Head :- Body).
683
684 generate_attach_increment_many(N,Mod,Clause) :-
685 make_attr(N,Mask,SuspsList,Attr),
686 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
687 Head = attach_increment([Var|Vars],Attr),
688 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
689 list2conj(Gs,SortGoals),
690 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
691 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
692 Body =
693 (
694 'chr not_locked'(Var),
695 ( get_attr(Var,Mod,TOtherAttr) ->
696 TOtherAttr = OtherAttr,
697 SortGoals,
698 MergedMask is Mask \/ OtherMask,
699 put_attr(Var,Mod,NewAttr)
700 ;
701 put_attr(Var,Mod,Attr)
702 ),
703 attach_increment(Vars,Attr)
704 ),
705 Clause = (Head :- Body).
706
707 %% attr_unify_hook
708 generate_attr_unify_hook(Constraints,Mod,[Clause]) :-
709 length(Constraints,N),
710 ( N == 1 ->
711 generate_attr_unify_hook_one(Mod,Clause)
712 ;
713 generate_attr_unify_hook_many(N,Mod,Clause)
714 ).
715
716 generate_attr_unify_hook_one(Mod,Clause) :-
717 Head = attr_unify_hook(Susps,Other),
718 Body =
719 (
720 sort(Susps, SortedSusps),
721 ( var(Other) ->
722 ( get_attr(Other,Mod,OtherSusps) ->
723 true
724 ;
725 OtherSusps = []
726 ),
727 sort(OtherSusps,SortedOtherSusps),
728 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
729 put_attr(Other,Mod,NewSusps),
730 'chr run_suspensions'(NewSusps)
731 ;
732 ( compound(Other) ->
733 term_variables(Other,OtherVars),
734 attach_increment(OtherVars, SortedSusps)
735 ;
736 true
737 ),
738 'chr run_suspensions'(Susps)
739 )
740 ),
741 Clause = (Head :- Body).
742
743 generate_attr_unify_hook_many(N,Mod,Clause) :-
744 make_attr(N,Mask,SuspsList,Attr),
745 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
746 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
747 list2conj(SortGoalList,SortGoals),
748 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
749 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
750 C = (sort(E,F),
751 'chr merge_attributes'(D,F,G)) ),
752 SortMergeGoalList),
753 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
754 list2conj(SortMergeGoalList,SortMergeGoals),
755 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
756 make_attr(N,Mask,SortedSuspsList,SortedAttr),
757 Head = attr_unify_hook(Attr,Other),
758 Body =
759 (
760 SortGoals,
761 ( var(Other) ->
762 ( get_attr(Other,Mod,TOtherAttr) ->
763 TOtherAttr = OtherAttr,
764 SortMergeGoals,
765 MergedMask is Mask \/ OtherMask,
766 put_attr(Other,Mod,MergedAttr),
767 'chr run_suspensions_loop'(MergedSuspsList)
768 ;
769 put_attr(Other,Mod,SortedAttr),
770 'chr run_suspensions_loop'(SortedSuspsList)
771 )
772 ;
773 ( compound(Other) ->
774 term_variables(Other,OtherVars),
775 attach_increment(OtherVars,SortedAttr)
776 ;
777 true
778 ),
779 'chr run_suspensions_loop'(SortedSuspsList)
780 )
781 ),
782 Clause = (Head :- Body).
783
784 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
785
786 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
787 %% ____ _ ____ _ _ _ _
788 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
789 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
790 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
791 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
792 %% |_|
793
794 constraints_code(Constraints,Rules,Mod,Clauses) :-
795 constraints_code(Constraints,Rules,Mod,L,[]),
796 clean_clauses(L,Clauses).
797
798 %% Generate code for all the CHR constraints
799 constraints_code(Constraints,Rules,Mod,L,T) :-
800 length(Constraints,N),
801 constraints_code(Constraints,1,N,Constraints,Rules,Mod,L,T).
802
803 constraints_code([],_,_,_,_,_,L,L).
804 constraints_code([Constr|Constrs],I,N,Constraints,Rules,Mod,L,T) :-
805 constraint_code(Constr,I,N,Constraints,Rules,Mod,L,T1),
806 J is I + 1,
807 constraints_code(Constrs,J,N,Constraints,Rules,Mod,T1,T).
808
809 %% Generate code for a single CHR constraint
810 constraint_code(Constraint, I, N, Constraints, Rules, Mod, L, T) :-
811 constraint_prelude(Constraint,Mod,Clause),
812 L = [Clause | L1],
813 Id1 = [0],
814 rules_code(Rules,1,Constraint,I,N,Constraints,Mod,Id1,Id2,L1,L2),
815 gen_cond_attach_clause(Mod,Constraint,I,N,Constraints,Id2,L2,T).
816
817 %% Generate prelude predicate for a constraint.
818 %% f(...) :- f/a_0(...,Susp).
819 constraint_prelude(F/A, _Mod, Clause) :-
820 vars_susp(A,Vars,_Susp,VarsSusp),
821 Head =.. [ F | Vars],
822 build_head(F,A,[0],VarsSusp,Delegate),
823 Clause = ( Head :- Delegate ).
824
825 gen_cond_attach_clause(Mod,F/A,_I,_N,_Constraints,Id,L,T) :-
826 ( Id == [0] ->
827 gen_cond_attach_goal(Mod,F/A,Body,AllArgs)
828 ; vars_susp(A,_Args,Susp,AllArgs),
829 gen_uncond_attach_goal(F/A,Susp,Mod,Body,_)
830 ),
831 build_head(F,A,Id,AllArgs,Head),
832 Clause = ( Head :- Body ),
833 L = [Clause | T].
834
835 gen_cond_attach_goal(Mod,F/A,Goal,AllArgs) :-
836 vars_susp(A,Args,Susp,AllArgs),
837 build_head(F,A,[0],AllArgs,Closure),
838 atom_concat_list(['attach_',F, (/) ,A],AttachF),
839 Attach =.. [AttachF,Vars,Susp],
840 Goal =
841 (
842 ( var(Susp) ->
843 'chr insert_constraint_internal'(Vars,Susp,Mod:Closure,F,Args)
844 ;
845 'chr activate_constraint'(Vars,Susp,_)
846 ),
847 Attach
848 ).
849
850 gen_uncond_attach_goal(F/A,Susp,_Mod,AttachGoal,Generation) :-
851 atom_concat_list(['attach_',F, (/) ,A],AttachF),
852 Attach =.. [AttachF,Vars,Susp],
853 AttachGoal =
854 (
855 'chr activate_constraint'(Vars, Susp, Generation),
856 Attach
857 ).
858
859 %% Generate all the code for a constraint based on all CHR rules
860 rules_code([],_,_,_,_,_,_,Id,Id,L,L).
861 rules_code([R |Rs],RuleNb,FA,I,N,Constraints,Mod,Id1,Id3,L,T) :-
862 rule_code(R,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L,T1),
863 NextRuleNb is RuleNb + 1,
864 rules_code(Rs,NextRuleNb,FA,I,N,Constraints,Mod,Id2,Id3,T1,T).
865
866 %% Generate code for a constraint based on a single CHR rule
867 rule_code(PragmaRule,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L,T) :-
868 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name),
869 HeadIDs = ids(Head1IDs,Head2IDs),
870 Rule = rule(Head1,Head2,_,_),
871 heads1_code(Head1,[],Head1IDs,[],PragmaRule,FA,I,N,Constraints,Mod,Id1,L,L1),
872 heads2_code(Head2,[],Head2IDs,[],PragmaRule,RuleNb,FA,I,N,Constraints,Mod,Id1,Id2,L1,T).
873
874 %% Generate code based on all the removed heads of a CHR rule
875 heads1_code([],_,_,_,_,_,_,_,_,_,_,L,L).
876 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,F/A,I,N,Constraints,Mod,Id,L,T) :-
877 PragmaRule = pragma(Rule,_,Pragmas,_Name),
878 ( functor(Head,F,A),
879 \+ check_unnecessary_active(Head,RestHeads,Rule),
880 \+ memberchk_eq(passive(HeadID),Pragmas) ->
881 append(Heads,RestHeads,OtherHeads),
882 append(HeadIDs,RestIDs,OtherIDs),
883 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,N,Constraints,Mod,Id,L,L1)
884 ;
885 L = L1
886 ),
887 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,F/A,I,N,Constraints,Mod,Id,L1,T).
888
889 %% Generate code based on one removed head of a CHR rule
890 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) :-
891 PragmaRule = pragma(Rule,_,_,_Name),
892 Rule = rule(_,Head2,_,_),
893 ( Head2 == [] ->
894 reorder_heads(Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
895 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T)
896 ;
897 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T)
898 ).
899
900 %% Generate code based on all the persistent heads of a CHR rule
901 heads2_code([],_,_,_,_,_,_,_,_,_,_,Id,Id,L,L).
902 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,RuleNb,F/A,I,N,Constraints,Mod,Id1,Id3,L,T) :-
903 PragmaRule = pragma(Rule,_,Pragmas,_Name),
904 ( functor(Head,F,A),
905 \+ check_unnecessary_active(Head,RestHeads,Rule),
906 \+ memberchk_eq(passive(HeadID),Pragmas),
907 \+ set_semantics_rule(PragmaRule) ->
908 append(Heads,RestHeads,OtherHeads),
909 append(HeadIDs,RestIDs,OtherIDs),
910 length(Heads,RestHeadNb),
911 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,F/A,I,N,Constraints,Mod,Id1,L,L0),
912 inc_id(Id1,Id2),
913 gen_alloc_inc_clause(F/A,Mod,Id1,L0,L1)
914 ;
915 L = L1,
916 Id2 = Id1
917 ),
918 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,RuleNb,F/A,I,N,Constraints,Mod,Id2,Id3,L1,T).
919
920 %% Generate code based on one persistent head of a CHR rule
921 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,FA,I,N,Constraints,Mod,Id,L,T) :-
922 PragmaRule = pragma(Rule,_,_,_Name),
923 Rule = rule(Head1,_,_,_),
924 ( Head1 == [] ->
925 reorder_heads(Head,OtherHeads,NOtherHeads),
926 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T)
927 ;
928 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T)
929 ).
930
931 gen_alloc_inc_clause(F/A,Mod,Id,L,T) :-
932 vars_susp(A,Vars,Susp,VarsSusp),
933 build_head(F,A,Id,VarsSusp,Head),
934 inc_id(Id,IncId),
935 build_head(F,A,IncId,VarsSusp,CallHead),
936 ( Id == [0] ->
937 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConditionalAlloc)
938 ;
939 ConditionalAlloc = true
940 ),
941 Clause =
942 (
943 Head :-
944 ConditionalAlloc,
945 CallHead
946 ),
947 L = [Clause|T].
948
949 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConstraintAllocationGoal) :-
950 build_head(F,A,[0],VarsSusp,Term),
951 ConstraintAllocationGoal =
952 ( var(Susp) ->
953 'chr allocate_constraint'(Mod : Term, Susp, F, Vars)
954 ;
955 true
956 ).
957
958 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
959
960
961 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
962
963 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
964 ( chr_pp_flag(guard_via_reschedule,on) ->
965 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
966 ;
967 append(Retrievals,GuardList,GoalList),
968 list2conj(GoalList,Goal)
969 ).
970
971 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
972 initialize_unit_dictionary(Prelude,Dict),
973 build_units(Retrievals,GuardList,Dict,Units),
974 dependency_reorder(Units,NUnits),
975 units2goal(NUnits,Goal).
976
977 units2goal([],true).
978 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
979 units2goal(Units,Goals).
980
981 dependency_reorder(Units,NUnits) :-
982 dependency_reorder(Units,[],NUnits).
983
984 dependency_reorder([],Acc,Result) :-
985 reverse(Acc,Result).
986
987 dependency_reorder([Unit|Units],Acc,Result) :-
988 Unit = unit(_GID,_Goal,Type,GIDs),
989 ( Type == fixed ->
990 NAcc = [Unit|Acc]
991 ;
992 dependency_insert(Acc,Unit,GIDs,NAcc)
993 ),
994 dependency_reorder(Units,NAcc,Result).
995
996 dependency_insert([],Unit,_,[Unit]).
997 dependency_insert([X|Xs],Unit,GIDs,L) :-
998 X = unit(GID,_,_,_),
999 ( memberchk(GID,GIDs) ->
1000 L = [Unit,X|Xs]
1001 ;
1002 L = [X | T],
1003 dependency_insert(Xs,Unit,GIDs,T)
1004 ).
1005
1006 build_units(Retrievals,Guard,InitialDict,Units) :-
1007 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
1008 build_guard_units(Guard,N,Dict,Tail).
1009
1010 build_retrieval_units([],N,N,Dict,Dict,L,L).
1011 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
1012 term_variables(U,Vs),
1013 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1014 L = [unit(N,U,movable,GIDs)|L1],
1015 N1 is N + 1,
1016 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
1017
1018 build_retrieval_units2([],N,N,Dict,Dict,L,L).
1019 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
1020 term_variables(U,Vs),
1021 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1022 L = [unit(N,U,fixed,GIDs)|L1],
1023 N1 is N + 1,
1024 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
1025
1026 initialize_unit_dictionary(Term,Dict) :-
1027 term_variables(Term,Vars),
1028 pair_all_with(Vars,0,Dict).
1029
1030 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
1031 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1032 ( lookup_eq(Dict,V,GID) ->
1033 ( (GID == This ; memberchk(GID,GIDs) ) ->
1034 GIDs1 = GIDs
1035 ;
1036 GIDs1 = [GID|GIDs]
1037 ),
1038 Dict1 = Dict
1039 ;
1040 Dict1 = [V - This|Dict],
1041 GIDs1 = GIDs
1042 ),
1043 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1044
1045 build_guard_units(Guard,N,Dict,Units) :-
1046 ( Guard = [Goal] ->
1047 Units = [unit(N,Goal,fixed,[])]
1048 ; Guard = [Goal|Goals] ->
1049 term_variables(Goal,Vs),
1050 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
1051 Units = [unit(N,Goal,movable,GIDs)|RUnits],
1052 N1 is N + 1,
1053 build_guard_units(Goals,N1,NDict,RUnits)
1054 ).
1055
1056 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
1057 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1058 ( lookup_eq(Dict,V,GID) ->
1059 ( (GID == This ; memberchk(GID,GIDs) ) ->
1060 GIDs1 = GIDs
1061 ;
1062 GIDs1 = [GID|GIDs]
1063 ),
1064 Dict1 = [V - This|Dict]
1065 ;
1066 Dict1 = [V - This|Dict],
1067 GIDs1 = GIDs
1068 ),
1069 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1070
1071 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1072
1073 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1074 %% ____ _ ____ _ _
1075 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
1076 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
1077 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
1078 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
1079 %%
1080 %% _ _ _ ___ __
1081 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
1082 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
1083 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
1084 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
1085 %% |_|
1086 unique_analyse_optimise(Rules,N,PatternList,NRules) :-
1087 ( chr_pp_flag(unique_analyse_optimise,on) ->
1088 unique_analyse_optimise_main(Rules,N,PatternList,NRules)
1089 ;
1090 NRules = Rules
1091 ).
1092
1093 unique_analyse_optimise_main([],_,_,[]).
1094 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
1095 ( discover_unique_pattern(PRule,N,Pattern) ->
1096 NPatternList = [Pattern|PatternList]
1097 ;
1098 NPatternList = PatternList
1099 ),
1100 PRule = pragma(Rule,Ids,Pragmas,Name),
1101 Rule = rule(H1,H2,_,_),
1102 Ids = ids(Ids1,Ids2),
1103 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
1104 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
1105 append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
1106 NPRule = pragma(Rule,Ids,NPragmas,Name),
1107 N1 is N + 1,
1108 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
1109
1110 apply_unique_patterns_to_constraints([],_,_,[]).
1111 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
1112 ( member(Pattern,Patterns),
1113 apply_unique_pattern(C,Id,Pattern,Pragma) ->
1114 Pragmas = [Pragma | RPragmas]
1115 ;
1116 Pragmas = RPragmas
1117 ),
1118 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
1119
1120 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
1121 Pattern = unique(PatternConstraint,PatternKey),
1122 subsumes(Constraint,PatternConstraint,Unifier),
1123 ( setof( V,
1124 T^Term^Vs^(
1125 member(T,PatternKey),
1126 lookup_eq(Unifier,T,Term),
1127 term_variables(Term,Vs),
1128 member(V,Vs)
1129 ),
1130 Vars) ->
1131 true
1132 ;
1133 Vars = []
1134 ),
1135 Pragma = unique(Id,Vars).
1136
1137 % subsumes(+Term1, +Term2, -Unifier)
1138 %
1139 % If Term1 is a more general term than Term2 (e.g. has a larger
1140 % part instantiated), unify Unifier with a list Var-Value of
1141 % variables from Term2 and their corresponding values in Term1.
1142
1143 subsumes(Term1,Term2,Unifier) :-
1144 empty_assoc(S0),
1145 subsumes_aux(Term1,Term2,S0,S),
1146 assoc_to_list(S,L),
1147 build_unifier(L,Unifier).
1148
1149 subsumes_aux(Term1, Term2, S0, S) :-
1150 ( compound(Term2),
1151 functor(Term2, F, N)
1152 -> compound(Term1), functor(Term1, F, N),
1153 subsumes_aux(N, Term1, Term2, S0, S)
1154 ; Term1 == Term2
1155 -> S = S0
1156 ; var(Term2),
1157 get_assoc(Term1,S0,V)
1158 -> V == Term2, S = S0
1159 ; var(Term2),
1160 put_assoc(Term1, S0, Term2, S)
1161 ).
1162
1163 subsumes_aux(0, _, _, S, S) :- ! .
1164 subsumes_aux(N, T1, T2, S0, S) :-
1165 arg(N, T1, T1x),
1166 arg(N, T2, T2x),
1167 subsumes_aux(T1x, T2x, S0, S1),
1168 M is N-1,
1169 subsumes_aux(M, T1, T2, S1, S).
1170
1171 build_unifier([],[]).
1172 build_unifier([X-V|R],[V - X | T]) :-
1173 build_unifier(R,T).
1174
1175 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
1176 PragmaRule = pragma(Rule,_,Pragmas,Name),
1177 ( Rule = rule([C1],[C2],Guard,Body) ->
1178 true
1179 ;
1180 Rule = rule([C1,C2],[],Guard,Body)
1181 ),
1182 check_unique_constraints(C1,C2,Guard,Body,Pragmas,List),
1183 term_variables(C1,Vs),
1184 select_pragma_unique_variables(List,Vs,Key),
1185 Pattern0 = unique(C1,Key),
1186 copy_term(Pattern0,Pattern),
1187 ( verbosity_on ->
1188 format('Found unique pattern ~w in rule ~d~@\n',
1189 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
1190 ;
1191 true
1192 ).
1193
1194 select_pragma_unique_variables([],_,[]).
1195 select_pragma_unique_variables([X-Y|R],Vs,L) :-
1196 ( X == Y ->
1197 L = [X|T]
1198 ;
1199 once((
1200 \+ memberchk_eq(X,Vs)
1201 ;
1202 \+ memberchk_eq(Y,Vs)
1203 )),
1204 L = T
1205 ),
1206 select_pragma_unique_variables(R,Vs,T).
1207
1208 check_unique_constraints(C1,C2,G,_Body,Pragmas,List) :-
1209 \+ member(passive(_),Pragmas),
1210 variable_replacement(C1-C2,C2-C1,List),
1211 copy_with_variable_replacement(G,OtherG,List),
1212 negate(G,NotG),
1213 once(entails(NotG,OtherG)).
1214
1215 negate(true,fail).
1216 negate(fail,true).
1217 negate(X =< Y, Y < X).
1218 negate(X > Y, Y >= X).
1219 negate(X >= Y, Y > X).
1220 negate(X < Y, Y =< X).
1221 negate(var(X),nonvar(X)).
1222 negate(nonvar(X),var(X)).
1223
1224 entails(X,X1) :- X1 == X.
1225 entails(fail,_).
1226 entails(X > Y, X1 >= Y1) :- X1 == X, Y1 == Y.
1227 entails(X < Y, X1 =< Y1) :- X1 == X, Y1 == Y.
1228 entails(ground(X),var(X1)) :- X1 == X.
1229
1230 check_unnecessary_active(Constraint,Previous,Rule) :-
1231 ( chr_pp_flag(check_unnecessary_active,full) ->
1232 check_unnecessary_active_main(Constraint,Previous,Rule)
1233 ; chr_pp_flag(check_unnecessary_active,simplification),
1234 Rule = rule(_,[],_,_) ->
1235 check_unnecessary_active_main(Constraint,Previous,Rule)
1236 ;
1237 fail
1238 ).
1239
1240 check_unnecessary_active_main(Constraint,Previous,Rule) :-
1241 member(Other,Previous),
1242 variable_replacement(Other,Constraint,List),
1243 copy_with_variable_replacement(Rule,Rule2,List),
1244 identical_rules(Rule,Rule2), ! .
1245
1246 set_semantics_rule(PragmaRule) :-
1247 ( chr_pp_flag(set_semantics_rule,on) ->
1248 set_semantics_rule_main(PragmaRule)
1249 ;
1250 fail
1251 ).
1252
1253 set_semantics_rule_main(PragmaRule) :-
1254 PragmaRule = pragma(Rule,IDs,Pragmas,_),
1255 Rule = rule([C1],[C2],true,true),
1256 C1 == C2,
1257 IDs = ids([ID1],_),
1258 \+ memberchk_eq(passive(ID1),Pragmas).
1259 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1260
1261 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1262 %% ____ _ _____ _ _
1263 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
1264 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
1265 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
1266 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
1267 %% |_|
1268 % have to check for no duplicates in value list
1269
1270 % check wether two rules are identical
1271
1272 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
1273 G1 == G2,
1274 identical_bodies(B1,B2),
1275 permutation(H11,P1),
1276 P1 == H12,
1277 permutation(H21,P2),
1278 P2 == H22.
1279
1280 identical_bodies(B1,B2) :-
1281 ( B1 = (X1 = Y1),
1282 B2 = (X2 = Y2) ->
1283 ( X1 == X2,
1284 Y1 == Y2
1285 ; X1 == Y2,
1286 X2 == Y1
1287 ),
1288 !
1289 ; B1 == B2
1290 ).
1291
1292 % replace variables in list
1293
1294 copy_with_variable_replacement(X,Y,L) :-
1295 ( var(X) ->
1296 ( lookup_eq(L,X,Y) ->
1297 true
1298 ; X = Y
1299 )
1300 ; functor(X,F,A),
1301 functor(Y,F,A),
1302 X =.. [_|XArgs],
1303 Y =.. [_|YArgs],
1304 copy_with_variable_replacement_l(XArgs,YArgs,L)
1305 ).
1306
1307 copy_with_variable_replacement_l([],[],_).
1308 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
1309 copy_with_variable_replacement(X,Y,L),
1310 copy_with_variable_replacement_l(Xs,Ys,L).
1311
1312 %% build variable replacement list
1313
1314 variable_replacement(X,Y,L) :-
1315 variable_replacement(X,Y,[],L).
1316
1317 variable_replacement(X,Y,L1,L2) :-
1318 ( var(X) ->
1319 var(Y),
1320 ( lookup_eq(L1,X,Z) ->
1321 Z == Y,
1322 L2 = L1
1323 ; L2 = [X-Y|L1]
1324 )
1325 ; X =.. [F|XArgs],
1326 nonvar(Y),
1327 Y =.. [F|YArgs],
1328 variable_replacement_l(XArgs,YArgs,L1,L2)
1329 ).
1330
1331 variable_replacement_l([],[],L,L).
1332 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
1333 variable_replacement(X,Y,L1,L2),
1334 variable_replacement_l(Xs,Ys,L2,L3).
1335 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1336
1337 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1338 %% ____ _ _ _ __ _ _ _
1339 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
1340 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
1341 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
1342 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
1343 %% |_|
1344
1345 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,_I,N,Constraints,Mod,Id,L,T) :-
1346 PragmaRule = pragma(Rule,_,Pragmas,_),
1347 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1348 build_head(F,A,Id,HeadVars,ClauseHead),
1349 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1350
1351 ( RestHeads == [] ->
1352 Susps = [],
1353 VarDict = VarDict1,
1354 GetRestHeads = []
1355 ;
1356 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,Mod,N,Constraints,GetRestHeads,Susps,VarDict1,VarDict)
1357 ),
1358
1359 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1360 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1361
1362 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
1363 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1364
1365 Clause = ( ClauseHead :-
1366 FirstMatching,
1367 RescheduledTest,
1368 !,
1369 SuspsDetachments,
1370 SuspDetachment,
1371 BodyCopy
1372 ),
1373 L = [Clause | T].
1374
1375 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
1376 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
1377 list2conj(GoalList,Goal).
1378
1379 head_arg_matches_([],VarDict,[],VarDict).
1380 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
1381 ( var(Arg) ->
1382 ( lookup_eq(VarDict,Arg,OtherVar) ->
1383 GoalList = [Var == OtherVar | RestGoalList],
1384 VarDict1 = VarDict
1385 ; VarDict1 = [Arg-Var | VarDict],
1386 GoalList = RestGoalList
1387 ),
1388 Pairs = Rest
1389 ; atomic(Arg) ->
1390 GoalList = [ Var == Arg | RestGoalList],
1391 VarDict = VarDict1,
1392 Pairs = Rest
1393 ; Arg =.. [_|Args],
1394 functor(Arg,Fct,N),
1395 functor(Term,Fct,N),
1396 Term =.. [_|Vars],
1397 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
1398 pairup(Args,Vars,NewPairs),
1399 append(NewPairs,Rest,Pairs),
1400 VarDict1 = VarDict
1401 ),
1402 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
1403
1404 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict):-
1405 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,[],[],[]).
1406
1407 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
1408 ( Heads = [_|_] ->
1409 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,Mod,N,Constraints,GoalList,Susps,VarDict,NVarDict,AttrDict)
1410 ;
1411 GoalList = [],
1412 Susps = [],
1413 VarDict = NVarDict
1414 ).
1415
1416 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,_,N,_,[],[],VarDict,VarDict,AttrDict) :-
1417 instantiate_pattern_goals(AttrDict,N).
1418 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,Mod,N,Constraints,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
1419 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,Constraints,Mod,VarDict,ViaGoal,Attr,NewAttrDict),
1420 functor(H,Fct,Aty),
1421 head_info(H,Aty,Vars,_,_,Pairs),
1422 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
1423 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
1424 ( N == 1 ->
1425 VarSusps = Attr
1426 ;
1427 nth(Pos,Constraints,Fct/Aty), !,
1428 make_attr(N,_Mask,SuspsList,Attr),
1429 nth(Pos,SuspsList,VarSusps)
1430 ),
1431 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
1432 create_get_mutable_ref(active,State,GetMutable),
1433 Goal1 =
1434 (
1435 'chr sbag_member'(Susp,VarSusps),
1436 Susp = Suspension,
1437 GetMutable,
1438 DiffSuspGoals,
1439 MatchingGoal
1440 ),
1441 ( member(unique(ID,UniqueKeus),Pragmas),
1442 check_unique_keys(UniqueKeus,VarDict) ->
1443 Goal = (Goal1 -> true) % once(Goal1)
1444 ;
1445 Goal = Goal1
1446 ),
1447 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Mod,N,Constraints,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
1448
1449 instantiate_pattern_goals([],_).
1450 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest],N) :-
1451 ( N == 1 ->
1452 Goal = true
1453 ;
1454 make_attr(N,Mask,_,Attr),
1455 or_list(Bits,Pattern), !,
1456 Goal = (Mask /\ Pattern =:= Pattern)
1457 ),
1458 instantiate_pattern_goals(Rest,N).
1459
1460
1461 check_unique_keys([],_).
1462 check_unique_keys([V|Vs],Dict) :-
1463 lookup_eq(Dict,V,_),
1464 check_unique_keys(Vs,Dict).
1465
1466 % Generates tests to ensure the found constraint differs from previously found constraints
1467 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
1468 ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
1469 list2conj(DiffSuspGoalList,DiffSuspGoals)
1470 ;
1471 DiffSuspGoals = true
1472 ).
1473
1474 passive_head_via(Head,PrevHeads,AttrDict,Constraints,Mod,VarDict,Goal,Attr,NewAttrDict) :-
1475 functor(Head,F,A),
1476 nth(Pos,Constraints,F/A),!,
1477 common_variables(Head,PrevHeads,CommonVars),
1478 translate(CommonVars,VarDict,Vars),
1479 or_pattern(Pos,Bit),
1480 ( permutation(Vars,PermutedVars),
1481 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
1482 member(Bit,Positions), !,
1483 NewAttrDict = AttrDict,
1484 Goal = true
1485 ;
1486 Goal = (Goal1, PatternGoal),
1487 gen_get_mod_constraints(Mod,Vars,Goal1,Attr),
1488 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
1489 ).
1490
1491 common_variables(T,Ts,Vs) :-
1492 term_variables(T,V1),
1493 term_variables(Ts,V2),
1494 intersect_eq(V1,V2,Vs).
1495
1496 gen_get_mod_constraints(Mod,L,Goal,Susps) :-
1497 ( L == [] ->
1498 Goal =
1499 ( 'chr default_store'(Global),
1500 get_attr(Global,Mod,TSusps),
1501 TSusps = Susps
1502 )
1503 ;
1504 ( L = [A] ->
1505 VIA = 'chr via_1'(A,V)
1506 ; ( L = [A,B] ->
1507 VIA = 'chr via_2'(A,B,V)
1508 ; VIA = 'chr via'(L,V)
1509 )
1510 ),
1511 Goal =
1512 ( VIA,
1513 get_attr(V,Mod,TSusps),
1514 TSusps = Susps
1515 )
1516 ).
1517
1518 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
1519 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1520 list2conj(GuardCopyList,GuardCopy).
1521
1522 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
1523 Rule = rule(_,_,Guard,Body),
1524 conj2list(Guard,GuardList),
1525 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
1526 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
1527
1528 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
1529 term_variables(RestGuardList,GuardVars),
1530 term_variables(RestGuardListCopyCore,GuardCopyVars),
1531 ( chr_pp_flag(guard_locks,on),
1532 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
1533 X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
1534 lookup_eq(VarDict,X,Y), % translate X into new variable
1535 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
1536 ),
1537 LocksUnlocks) ->
1538 once(pairup(Locks,Unlocks,LocksUnlocks))
1539 ;
1540 Locks = [],
1541 Unlocks = []
1542 ),
1543 list2conj(Locks,LockPhase),
1544 list2conj(Unlocks,UnlockPhase),
1545 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
1546 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
1547 my_term_copy(Body,VarDict2,BodyCopy).
1548
1549
1550 split_off_simple_guard([],_,[],[]).
1551 split_off_simple_guard([G|Gs],VarDict,S,C) :-
1552 ( simple_guard(G,VarDict) ->
1553 S = [G|Ss],
1554 split_off_simple_guard(Gs,VarDict,Ss,C)
1555 ;
1556 S = [],
1557 C = [G|Gs]
1558 ).
1559
1560 % simple guard: cheap and benign (does not bind variables)
1561
1562 simple_guard(var(_), _).
1563 simple_guard(nonvar(_), _).
1564 simple_guard(ground(_), _).
1565 simple_guard(number(_), _).
1566 simple_guard(atom(_), _).
1567 simple_guard(integer(_), _).
1568 simple_guard(float(_), _).
1569
1570 simple_guard(_ > _ , _).
1571 simple_guard(_ < _ , _).
1572 simple_guard(_ =< _, _).
1573 simple_guard(_ >= _, _).
1574 simple_guard(_ =:= _, _).
1575 simple_guard(_ == _, _).
1576
1577 simple_guard(X is _, VarDict) :-
1578 \+ lookup_eq(VarDict,X,_).
1579
1580 simple_guard((G1,G2),VarDict) :-
1581 simple_guard(G1,VarDict),
1582 simple_guard(G2,VarDict).
1583
1584 simple_guard(\+ G, VarDict) :-
1585 simple_guard(G, VarDict).
1586
1587 my_term_copy(X,Dict,Y) :-
1588 my_term_copy(X,Dict,_,Y).
1589
1590 my_term_copy(X,Dict1,Dict2,Y) :-
1591 ( var(X) ->
1592 ( lookup_eq(Dict1,X,Y) ->
1593 Dict2 = Dict1
1594 ; Dict2 = [X-Y|Dict1]
1595 )
1596 ; functor(X,XF,XA),
1597 functor(Y,XF,XA),
1598 X =.. [_|XArgs],
1599 Y =.. [_|YArgs],
1600 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
1601 ).
1602
1603 my_term_copy_list([],Dict,Dict,[]).
1604 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
1605 my_term_copy(X,Dict1,Dict2,Y),
1606 my_term_copy_list(Xs,Dict2,Dict3,Ys).
1607
1608 gen_cond_susp_detachment(Susp,FA,SuspDetachment) :-
1609 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
1610 SuspDetachment =
1611 ( var(Susp) ->
1612 true
1613 ; UnCondSuspDetachment
1614 ).
1615
1616 gen_uncond_susp_detachment(Susp,CFct/CAty,SuspDetachment) :-
1617 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
1618 Detach =.. [Fct,Vars,Susp],
1619 SuspDetachment =
1620 (
1621 'chr remove_constraint_internal'(Susp, Vars),
1622 Detach
1623 ).
1624
1625 gen_uncond_susps_detachments([],[],true).
1626 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
1627 functor(Term,F,A),
1628 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
1629 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
1630
1631 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1632
1633 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1634 %% ____ _ _ _ _
1635 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
1636 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
1637 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
1638 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
1639 %% |_| |___/
1640
1641 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,_I,N,Constraints,Mod,Id,L,T) :-
1642 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name),
1643 Rule = rule(_Heads,Heads2,_Guard,_Body),
1644
1645 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1646 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1647
1648 build_head(F,A,Id,HeadVars,ClauseHead),
1649
1650 append(RestHeads,Heads2,Heads),
1651 append(OtherIDs,Heads2IDs,IDs),
1652 reorder_heads(Head,Heads,IDs,NHeads,NIDs),
1653 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,Mod,N,Constraints,GetRestHeads,Susps,VarDict1,VarDict),
1654 length(RestHeads,RN),
1655 take(RN,Susps,Susps1),
1656
1657 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1658 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1659
1660 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
1661 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1662
1663 Clause = ( ClauseHead :-
1664 FirstMatching,
1665 RescheduledTest,
1666 !,
1667 SuspsDetachments,
1668 SuspDetachment,
1669 BodyCopy
1670 ),
1671 L = [Clause | T].
1672 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1673
1674
1675 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1676 %% ____ _ _ _ ____
1677 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
1678 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
1679 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
1680 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
1681 %% |_| |___/
1682
1683 %% Genereate prelude + worker predicate
1684 %% prelude calls worker
1685 %% worker iterates over one type of removed constraints
1686 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,I,N,Constraints,Mod,Id,L,T) :-
1687 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name),
1688 Rule = rule(Heads1,_,Guard,Body),
1689 reorder_heads(Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
1690 % IDs1 = [ID1|RestIDs1],
1691 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,I,N,Constraints,Mod,Id,L,L1),
1692 extend_id(Id,Id2),
1693 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,Rule,Pragmas,FA,I,N,Constraints,Mod,Id2,L1,T).
1694
1695 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1696 simpagation_head2_prelude(Head,Head1,Rest,F/A,_I,N,Constraints,Mod,Id1,L,T) :-
1697 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
1698 build_head(F,A,Id1,VarsSusp,ClauseHead),
1699 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
1700
1701 passive_head_via(Head1,[Head],[],Constraints,Mod,VarDict,ModConstraintsGoal,Attr,AttrDict),
1702 instantiate_pattern_goals(AttrDict,N),
1703 ( N == 1 ->
1704 AllSusps = Attr
1705 ;
1706 functor(Head1,F1,A1),
1707 nth(Pos,Constraints,F1/A1), !,
1708 make_attr(N,_,SuspsList,Attr),
1709 nth(Pos,SuspsList,AllSusps)
1710 ),
1711
1712 ( Id1 == [0] -> % create suspension
1713 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,ConstraintAllocationGoal)
1714 ; ConstraintAllocationGoal = true
1715 ),
1716
1717 extend_id(Id1,DelegateId),
1718 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
1719 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
1720 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
1721
1722 PreludeClause =
1723 ( ClauseHead :-
1724 FirstMatching,
1725 ModConstraintsGoal,
1726 !,
1727 ConstraintAllocationGoal,
1728 Delegate
1729 ),
1730 L = [PreludeClause|T].
1731
1732 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
1733 Term =.. [_|Args],
1734 delegate_variables(Term,Terms,VarDict,Args,Vars).
1735
1736 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
1737 term_variables(PrevTerms,PrevVars),
1738 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
1739
1740 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
1741 term_variables(Term,V1),
1742 term_variables(Terms,V2),
1743 intersect_eq(V1,V2,V3),
1744 list_difference_eq(V3,PrevVars,V4),
1745 translate(V4,VarDict,Vars).
1746
1747
1748 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1749 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,I,N,Constraints,Mod,Id,L,T) :-
1750 Rule = rule(_,_,Guard,Body),
1751 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
1752 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,I,N,Constraints,Mod,Id,L1,T).
1753
1754 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1755 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,F/A,_I,N,Constraints,Mod,Id,L,T) :-
1756 gen_var(OtherSusp),
1757 gen_var(OtherSusps),
1758
1759 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
1760 head_arg_matches(Head2Pairs,[],_,VarDict1),
1761
1762 Rule = rule(_,_,Guard,Body),
1763 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
1764 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
1765 build_head(F,A,Id,HeadVars,ClauseHead),
1766
1767 functor(Head1,_OtherF,OtherA),
1768 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
1769 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
1770
1771 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
1772 create_get_mutable_ref(active,OtherState,GetMutable),
1773 IteratorSuspTest =
1774 ( OtherSusp = OtherSuspension,
1775 GetMutable
1776 ),
1777
1778 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
1779 append(RestHeads1,RestHeads2,RestHeads),
1780 append(IDs1,IDs2,IDs),
1781 reorder_heads(Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
1782 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],Mod,N,Constraints,RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
1783 length(RestHeads1,RH1N),
1784 take(RH1N,Susps,Susps1)
1785 ; RestSuspsRetrieval = [],
1786 Susps1 = [],
1787 VarDict = VarDict2
1788 ),
1789
1790 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
1791
1792 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
1793 build_head(F,A,Id,RecursiveVars,RecursiveCall),
1794 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
1795 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
1796
1797 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1798 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
1799 ( BodyCopy \== true ->
1800 gen_uncond_attach_goal(F/A,Susp,Mod,Attachment,Generation),
1801 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
1802 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
1803 ; Attachment = true,
1804 ConditionalRecursiveCall = RecursiveCall,
1805 ConditionalRecursiveCall2 = RecursiveCall2
1806 ),
1807
1808 ( member(unique(ID1,UniqueKeys), Pragmas),
1809 check_unique_keys(UniqueKeys,VarDict1) ->
1810 Clause =
1811 ( ClauseHead :-
1812 ( IteratorSuspTest,
1813 FirstMatching ->
1814 ( RescheduledTest ->
1815 Susps1Detachments,
1816 Attachment,
1817 BodyCopy,
1818 ConditionalRecursiveCall2
1819 ;
1820 RecursiveCall2
1821 )
1822 ;
1823 RecursiveCall
1824 )
1825 )
1826 ;
1827 Clause =
1828 ( ClauseHead :-
1829 ( IteratorSuspTest,
1830 FirstMatching,
1831 RescheduledTest ->
1832 Susps1Detachments,
1833 Attachment,
1834 BodyCopy,
1835 ConditionalRecursiveCall
1836 ;
1837 RecursiveCall
1838 )
1839 )
1840 ),
1841 L = [Clause | T].
1842
1843 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
1844 length(Args,N),
1845 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
1846 create_get_mutable_ref(active,State,GetState),
1847 create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
1848 ConditionalCall =
1849 ( Susp = Suspension,
1850 GetState,
1851 GetGeneration ->
1852 'chr update_mutable'(inactive,State),
1853 Call
1854 ; true
1855 ).
1856
1857 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1858 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
1859 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
1860 head_arg_matches(Pairs,[],_,VarDict),
1861 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
1862 append([[]|VarsSusp],ExtraVars,HeadVars),
1863 build_head(F,A,Id,HeadVars,ClauseHead),
1864 next_id(Id,ContinuationId),
1865 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
1866 Clause = ( ClauseHead :- ContinuationHead ),
1867 L = [Clause | T].
1868
1869 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1870
1871
1872 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1873 %% ____ _ _
1874 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
1875 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
1876 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
1877 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
1878 %% |_| |___/
1879
1880 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :-
1881 ( RestHeads == [] ->
1882 propagation_single_headed(Head,Rule,RuleNb,FA,Mod,Id,L,T)
1883 ;
1884 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T)
1885 ).
1886 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1887 %% Single headed propagation
1888 %% everything in a single clause
1889 propagation_single_headed(Head,Rule,RuleNb,F/A,Mod,Id,L,T) :-
1890 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
1891 build_head(F,A,Id,VarsSusp,ClauseHead),
1892
1893 inc_id(Id,NextId),
1894 build_head(F,A,NextId,VarsSusp,NextHead),
1895
1896 NextCall = NextHead,
1897
1898 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
1899 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
1900 ( Id == [0] ->
1901 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,Allocation),
1902 Allocation1 = Allocation
1903 ;
1904 Allocation1 = true
1905 ),
1906 gen_uncond_attach_goal(F/A,Susp,Mod,Attachment,Generation),
1907
1908 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
1909
1910 Clause = (
1911 ClauseHead :-
1912 HeadMatching,
1913 Allocation1,
1914 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
1915 GuardCopy,
1916 !,
1917 'chr extend_history'(Susp,RuleNb),
1918 Attachment,
1919 BodyCopy,
1920 ConditionalNextCall
1921 ),
1922 L = [Clause | T].
1923
1924 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1925 %% multi headed propagation
1926 %% prelude + predicates to accumulate the necessary combinations of suspended
1927 %% constraints + predicate to execute the body
1928 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :-
1929 RestHeads = [First|Rest],
1930 propagation_prelude(Head,RestHeads,Rule,FA,N,Constraints,Mod,Id,L,L1),
1931 extend_id(Id,ExtendedId),
1932 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,ExtendedId,L1,T).
1933
1934 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1935 propagation_prelude(Head,[First|Rest],Rule,F/A,N,Constraints,Mod,Id,L,T) :-
1936 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
1937 build_head(F,A,Id,VarsSusp,PreludeHead),
1938 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
1939 Rule = rule(_,_,Guard,Body),
1940 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
1941
1942 passive_head_via(First,[Head],[],Constraints,Mod,VarDict,FirstSuspGoal,Attr,AttrDict),
1943 instantiate_pattern_goals(AttrDict,N),
1944 ( N == 1 ->
1945 Susps = Attr
1946 ;
1947 functor(First,FirstFct,FirstAty),
1948 make_attr(N,_Mask,SuspsList,Attr),
1949 nth(Pos,Constraints,FirstFct/FirstAty), !,
1950 nth(Pos,SuspsList,Susps)
1951 ),
1952
1953 ( Id == [0] ->
1954 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Mod,CondAllocation)
1955 ; CondAllocation = true
1956 ),
1957
1958 extend_id(Id,NestedId),
1959 append([Susps|VarsSusp],ExtraVars,NestedVars),
1960 build_head(F,A,NestedId,NestedVars,NestedHead),
1961 NestedCall = NestedHead,
1962
1963 Prelude = (
1964 PreludeHead :-
1965 FirstMatching,
1966 FirstSuspGoal,
1967 !,
1968 CondAllocation,
1969 NestedCall
1970 ),
1971 L = [Prelude|T].
1972
1973 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1974 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,_,_Constraints,Mod,Id,L,T) :-
1975 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
1976 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Mod,Id,L1,T).
1977
1978 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,Id,L,T) :-
1979 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
1980 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,N,Constraints,Mod,Id,L1,L2),
1981 inc_id(Id,IncId),
1982 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,N,Constraints,Mod,IncId,L2,T).
1983
1984 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Mod,Id,L,T) :-
1985 Rule = rule(_,_,Guard,Body),
1986 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
1987 gen_var(OtherSusp),
1988 gen_var(OtherSusps),
1989 functor(CurrentHead,_OtherF,OtherA),
1990 gen_vars(OtherA,OtherVars),
1991 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
1992 create_get_mutable_ref(active,State,GetMutable),
1993 CurrentSuspTest = (
1994 OtherSusp = Suspension,
1995 GetMutable
1996 ),
1997 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
1998 build_head(F,A,Id,ClauseVars,ClauseHead),
1999 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2000 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2001 RecursiveCall = RecursiveHead,
2002 CurrentHead =.. [_|OtherArgs],
2003 pairup(OtherArgs,OtherVars,OtherPairs),
2004 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
2005
2006 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
2007
2008 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
2009 gen_uncond_attach_goal(F/A,Susp,Mod,Attach,Generation),
2010 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2011
2012 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
2013 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
2014 list2conj(NovelProductionsList,NovelProductions),
2015 Tuple =.. [t,RuleNb|HistorySusps],
2016
2017 Clause = (
2018 ClauseHead :-
2019 ( CurrentSuspTest,
2020 DiffSuspGoals,
2021 Matching,
2022 TupleVar = Tuple,
2023 NovelProductions,
2024 GuardCopy ->
2025 'chr extend_history'(Susp,TupleVar),
2026 Attach,
2027 BodyCopy,
2028 ConditionalRecursiveCall
2029 ; RecursiveCall
2030 )
2031 ),
2032 L = [Clause|T].
2033
2034
2035 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
2036 ( Count == 0 ->
2037 reverse(OtherSusps,ReversedSusps),
2038 append(ReversedSusps,[Susp|Acc],HistorySusps)
2039 ;
2040 OtherSusps = [OtherSusp|RestOtherSusps],
2041 NCount is Count - 1,
2042 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
2043 ).
2044
2045
2046 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
2047 !,
2048 functor(Head,_F,A),
2049 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
2050 head_arg_matches(Pairs,[],_,VarDict),
2051 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2052 append(VarsSusp,ExtraVars,HeadVars).
2053 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
2054 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
2055 functor(Head,_F,A),
2056 gen_var(Susps),
2057 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
2058 head_arg_matches(Pairs,VarDict,_,NVarDict),
2059 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2060 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
2061
2062 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
2063 Rule = rule(_,_,Guard,Body),
2064 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
2065
2066 Vars = [ [] | VarsAndSusps],
2067
2068 build_head(F,A,Id,Vars,Head),
2069
2070 ( Id = [0|_] ->
2071 next_id(Id,PrevId),
2072 PrevVarsAndSusps = AllButFirst
2073 ;
2074 dec_id(Id,PrevId),
2075 PrevVarsAndSusps = [FirstSusp|AllButFirst]
2076 ),
2077
2078 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
2079 PredecessorCall = PrevHead,
2080
2081 Clause = (
2082 Head :-
2083 PredecessorCall
2084 ),
2085 L = [Clause | T].
2086
2087 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
2088 !,
2089 functor(Head,_F,A),
2090 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
2091 head_arg_matches(HeadPairs,[],_,VarDict),
2092 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2093 append(VarsSusp,ExtraVars,HeadVars).
2094 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
2095 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
2096 functor(Head,_F,A),
2097 gen_var(Susps),
2098 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2099 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2100 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2101 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
2102
2103 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,N,Constraints,Mod,Id,L,T) :-
2104 Rule = rule(_,_,Guard,Body),
2105 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
2106 gen_var(OtherSusps),
2107 functor(CurrentHead,_OtherF,OtherA),
2108 gen_vars(OtherA,OtherVars),
2109 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
2110 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
2111
2112 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
2113
2114 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
2115 create_get_mutable_ref(active,State,GetMutable),
2116 CurrentSuspTest = (
2117 OtherSusp = OtherSuspension,
2118 GetMutable,
2119 DiffSuspGoals,
2120 FirstMatching
2121 ),
2122 functor(NextHead,NextF,NextA),
2123 passive_head_via(NextHead,[CurrentHead|PreHeads],[],Constraints,Mod,VarDict1,NextSuspGoal,Attr,AttrDict),
2124 instantiate_pattern_goals(AttrDict,N),
2125 ( N == 1 ->
2126 NextSusps = Attr
2127 ;
2128 nth(Position,Constraints,NextF/NextA), !,
2129 make_attr(N,_Mask,SuspsList,Attr),
2130 nth(Position,SuspsList,NextSusps)
2131 ),
2132 inc_id(Id,NestedId),
2133 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
2134 build_head(F,A,Id,ClauseVars,ClauseHead),
2135 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
2136 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
2137 build_head(F,A,NestedId,NestedVars,NestedHead),
2138
2139 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2140 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2141 Clause = (
2142 ClauseHead :-
2143 ( CurrentSuspTest,
2144 NextSuspGoal
2145 ->
2146 NestedHead
2147 ; RecursiveHead
2148 )
2149 ),
2150 L = [Clause|T].
2151
2152 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
2153 !,
2154 functor(Head,_F,A),
2155 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
2156 head_arg_matches(HeadPairs,[],_,VarDict),
2157 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2158 append(VarsSusp,ExtraVars,HeadVars).
2159 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
2160 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
2161 functor(Head,_F,A),
2162 gen_var(NextSusps),
2163 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2164 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2165 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2166 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
2167
2168 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2169
2170 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2171 %% ____ _ _ _ _
2172 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
2173 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
2174 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
2175 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
2176 %%
2177 %% ____ _ _ _
2178 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
2179 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
2180 %% | _ < __/ |_| | | | __/\ V / (_| | |
2181 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
2182 %%
2183 %% ____ _ _
2184 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
2185 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
2186 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
2187 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
2188 %% |___/
2189
2190 reorder_heads(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2191 ( chr_pp_flag(reorder_heads,on) ->
2192 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
2193 ;
2194 NRestHeads = RestHeads,
2195 NRestIDs = RestIDs
2196 ).
2197
2198 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2199 term_variables(Head,KnownVars),
2200 reorder_heads1(RestHeads,RestIDs,KnownVars,NRestHeads,NRestIDs).
2201
2202 reorder_heads1(Heads,IDs,KnownVars,NHeads,NIDs) :-
2203 ( Heads == [] ->
2204 NHeads = [],
2205 NIDs = []
2206 ;
2207 NHeads = [BestHead|BestTail],
2208 NIDs = [BestID | BestIDs],
2209 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars),
2210 reorder_heads1(RestHeads,RestIDs,NKnownVars,BestTail,BestIDs)
2211 ).
2212
2213 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars) :-
2214 ( bagof(tuple(Score,Head,ID,Rest,RIDs), (
2215 select2(Head,ID, Heads,IDs,Rest,RIDs) ,
2216 order_score(Head,KnownVars,Rest,Score)
2217 ),
2218 Scores) -> true ; Scores = []),
2219 max_go_list(Scores,tuple(_,BestHead,BestID,RestHeads,RestIDs)),
2220 term_variables(BestHead,BestHeadVars),
2221 ( setof(V, (
2222 member(V,BestHeadVars),
2223 \+ memberchk_eq(V,KnownVars)
2224 ),
2225 NewVars) -> true ; NewVars = []),
2226 append(NewVars,KnownVars,NKnownVars).
2227
2228 reorder_heads(Head,RestHeads,NRestHeads) :-
2229 term_variables(Head,KnownVars),
2230 reorder_heads1(RestHeads,KnownVars,NRestHeads).
2231
2232 reorder_heads1(Heads,KnownVars,NHeads) :-
2233 ( Heads == [] ->
2234 NHeads = []
2235 ;
2236 NHeads = [BestHead|BestTail],
2237 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars),
2238 reorder_heads1(RestHeads,NKnownVars,BestTail)
2239 ).
2240
2241 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars) :-
2242 ( bagof(tuple(Score,Head,Rest), (
2243 select(Head,Heads,Rest) ,
2244 order_score(Head,KnownVars,Rest,Score)
2245 ),
2246 Scores) -> true ; Scores = []),
2247 max_go_list(Scores,tuple(_,BestHead,RestHeads)),
2248 term_variables(BestHead,BestHeadVars),
2249 ( setof(V, (
2250 member(V,BestHeadVars),
2251 \+ memberchk_eq(V,KnownVars)
2252 ),
2253 NewVars) -> true ; NewVars = []),
2254 append(NewVars,KnownVars,NKnownVars).
2255
2256 order_score(Head,KnownVars,Rest,Score) :-
2257 term_variables(Head,HeadVars),
2258 term_variables(Rest,RestVars),
2259 order_score_vars(HeadVars,KnownVars,RestVars,0,Score).
2260
2261 order_score_vars([],_,_,Score,NScore) :-
2262 ( Score == 0 ->
2263 NScore = 99999
2264 ;
2265 NScore = Score
2266 ).
2267 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
2268 ( memberchk_eq(V,KnownVars) ->
2269 TScore is Score + 1
2270 ; memberchk_eq(V,RestVars) ->
2271 TScore is Score + 1
2272 ;
2273 TScore = Score
2274 ),
2275 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
2276
2277 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2278 %% ___ _ _ _
2279 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
2280 %% | || '_ \| | | '_ \| | '_ \ / _` |
2281 %% | || | | | | | | | | | | | | (_| |
2282 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
2283 %% |___/
2284
2285 %% SWI begin
2286 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
2287 %% SWI end
2288
2289 %% SICStus begin
2290 create_get_mutable_ref(V,M,GM) :- GM = (get_mutable(V,M)).
2291 %% SICStus end
2292
2293
2294
2295 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2296
2297 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2298 %% ____ _ ____ _ _
2299 %% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
2300 %% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
2301 %% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
2302 %% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
2303 %% |___/
2304 %%
2305 %% removes redundant 'true's and other trivial but potentially non-free constructs
2306
2307 clean_clauses([],[]).
2308 clean_clauses([C|Cs],[NC|NCs]) :-
2309 clean_clause(C,NC),
2310 clean_clauses(Cs,NCs).
2311
2312 clean_clause(Clause,NClause) :-
2313 ( Clause = (Head :- Body) ->
2314 clean_goal(Body,NBody),
2315 ( NBody == true ->
2316 NClause = Head
2317 ;
2318 NClause = (Head :- NBody)
2319 )
2320 ;
2321 NClause = Clause
2322 ).
2323
2324 clean_goal(Goal,NGoal) :-
2325 var(Goal), !,
2326 NGoal = Goal.
2327 clean_goal((G1,G2),NGoal) :-
2328 !,
2329 clean_goal(G1,NG1),
2330 clean_goal(G2,NG2),
2331 ( NG1 == true ->
2332 NGoal = NG2
2333 ; NG2 == true ->
2334 NGoal = NG1
2335 ;
2336 NGoal = (NG1,NG2)
2337 ).
2338 clean_goal((If -> Then ; Else),NGoal) :-
2339 !,
2340 clean_goal(If,NIf),
2341 ( NIf == true ->
2342 clean_goal(Then,NThen),
2343 NGoal = NThen
2344 ; NIf == fail ->
2345 clean_goal(Else,NElse),
2346 NGoal = NElse
2347 ;
2348 clean_goal(Then,NThen),
2349 clean_goal(Else,NElse),
2350 NGoal = (NIf -> NThen; NElse)
2351 ).
2352 clean_goal((G1 ; G2),NGoal) :-
2353 !,
2354 clean_goal(G1,NG1),
2355 clean_goal(G2,NG2),
2356 ( NG1 == fail ->
2357 NGoal = NG2
2358 ; NG2 == fail ->
2359 NGoal = NG1
2360 ;
2361 NGoal = (NG1 ; NG2)
2362 ).
2363 clean_goal(once(G),NGoal) :-
2364 !,
2365 clean_goal(G,NG),
2366 ( NG == true ->
2367 NGoal = true
2368 ; NG == fail ->
2369 NGoal = fail
2370 ;
2371 NGoal = once(NG)
2372 ).
2373 clean_goal((G1 -> G2),NGoal) :-
2374 !,
2375 clean_goal(G1,NG1),
2376 ( NG1 == true ->
2377 clean_goal(G2,NGoal)
2378 ; NG1 == fail ->
2379 NGoal = fail
2380 ;
2381 clean_goal(G2,NG2),
2382 NGoal = (NG1 -> NG2)
2383 ).
2384 clean_goal(Goal,Goal).
2385 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2386
2387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2388 %% _ _ _ _ _ _ _
2389 %% | | | | |_(_) (_) |_ _ _
2390 %% | | | | __| | | | __| | | |
2391 %% | |_| | |_| | | | |_| |_| |
2392 %% \___/ \__|_|_|_|\__|\__, |
2393 %% |___/
2394
2395 gen_var(_).
2396 gen_vars(N,Xs) :-
2397 length(Xs,N).
2398
2399 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
2400 vars_susp(A,Vars,Susp,VarsSusp),
2401 Head =.. [_|Args],
2402 pairup(Args,Vars,HeadPairs).
2403
2404 inc_id([N|Ns],[O|Ns]) :-
2405 O is N + 1.
2406 dec_id([N|Ns],[M|Ns]) :-
2407 M is N - 1.
2408
2409 extend_id(Id,[0|Id]).
2410
2411 next_id([_,N|Ns],[O|Ns]) :-
2412 O is N + 1.
2413
2414 build_head(F,A,Id,Args,Head) :-
2415 buildName(F,A,Id,Name),
2416 Head =.. [Name|Args].
2417
2418 buildName(Fct,Aty,List,Result) :-
2419 atom_concat(Fct, (/) ,FctSlash),
2420 atomic_concat(FctSlash,Aty,FctSlashAty),
2421 buildName_(List,FctSlashAty,Result).
2422
2423 buildName_([],Name,Name).
2424 buildName_([N|Ns],Name,Result) :-
2425 buildName_(Ns,Name,Name1),
2426 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
2427 atomic_concat(NameDash,N,Result).
2428
2429 vars_susp(A,Vars,Susp,VarsSusp) :-
2430 length(Vars,A),
2431 append(Vars,[Susp],VarsSusp).
2432
2433 make_attr(N,Mask,SuspsList,Attr) :-
2434 length(SuspsList,N),
2435 Attr =.. [v,Mask|SuspsList].
2436
2437 or_pattern(Pos,Pat) :-
2438 Pow is Pos - 1,
2439 Pat is 1 << Pow. % was 2 ** X
2440
2441 and_pattern(Pos,Pat) :-
2442 X is Pos - 1,
2443 Y is 1 << X, % was 2 ** X
2444 Pat is -(Y + 1).
2445
2446 conj2list(Conj,L) :- %% transform conjunctions to list
2447 conj2list(Conj,L,[]).
2448
2449 conj2list(Conj,L,T) :-
2450 Conj = (G1,G2), !,
2451 conj2list(G1,L,T1),
2452 conj2list(G2,T1,T).
2453 conj2list(G,[G | T],T).
2454
2455 list2conj([],true).
2456 list2conj([G],X) :- !, X = G.
2457 list2conj([G|Gs],C) :-
2458 ( G == true -> %% remove some redundant trues
2459 list2conj(Gs,C)
2460 ;
2461 C = (G,R),
2462 list2conj(Gs,R)
2463 ).
2464
2465 atom_concat_list([X],X) :- ! .
2466 atom_concat_list([X|Xs],A) :-
2467 atom_concat_list(Xs,B),
2468 atomic_concat(X,B,A).
2469
2470 atomic_concat(A,B,C) :-
2471 make_atom(A,AA),
2472 make_atom(B,BB),
2473 atom_concat(AA,BB,C).
2474
2475 make_atom(A,AA) :-
2476 (
2477 atom(A) ->
2478 AA = A
2479 ;
2480 number(A) ->
2481 number_codes(A,AL),
2482 atom_codes(AA,AL)
2483 ).
2484
2485
2486 set_elems([],_).
2487 set_elems([X|Xs],X) :-
2488 set_elems(Xs,X).
2489
2490 member2([X|_],[Y|_],X-Y).
2491 member2([_|Xs],[_|Ys],P) :-
2492 member2(Xs,Ys,P).
2493
2494 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
2495 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
2496 select2(X, Y, Xs, Ys, NXs, NYs).
2497
2498 pair_all_with([],_,[]).
2499 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
2500 pair_all_with(Xs,Y,Rest).
2501
2502 default(X,Def) :-
2503 ( var(X) -> X = Def ; true).
2504
2505 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2506
2507 %% SWI begin
2508 verbosity_on :- prolog_flag(verbose,V), V == yes.
2509 %% SWI end
2510
2511 %% SICStus begin
2512 %% verbosity_on. % at the moment
2513 %% SICStus end
copy of chr