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