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