chr_translate.chr

   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 %%
  51 %% OPEN BUGS
  52 %%
  53 %% URGENTLY TODO
  54 %%
  55 %%      * add mode checking to debug mode
  56 %%      * add groundness info to a.i.-based observation analysis
  57 %%      * proper fd/index analysis
  58 %%      * re-add generation checking
  59 %%      * untangle CHR-level and target source-level generation & optimization
  60 %%
  61 %% AGGRESSIVE OPTIMISATION IDEAS
  62 %%
  63 %%      * success continuation optimization
  64 %%      * analyze history usage to determine whether/when
  65 %%        cheaper suspension is possible:
  66 %%              don't use history when all partners are passive and self never triggers
  67 %%      * store constraint unconditionally for unconditional propagation rule,
  68 %%        if first, i.e. without checking history and set trigger cont to next occ
  69 %%      * get rid of suspension passing for never triggered constraints,
  70 %%         up to allocation occurrence
  71 %%      * get rid of call indirection for never triggered constraints
  72 %%        up to first allocation occurrence.
  73 %%      * get rid of unnecessary indirection if last active occurrence
  74 %%        before unconditional removal is head2, e.g.
  75 %%              a \ b <=> true.
  76 %%              a <=> true.
  77 %%      * Eliminate last clause of never stored constraint, if its body
  78 %%        is fail, e.g.
  79 %%              a ...
  80 %%              a <=> fail.
  81 %%      * Specialize lookup operations and indexes for functional dependencies.
  82 %%
  83 %% MORE TODO
  84 %%
  85 %%      * generate code to empty all constraint stores of a module (Bart Demoen)
  86 %%      * map A \ B <=> true | true rules
  87 %%        onto efficient code that empties the constraint stores of B
  88 %%        in O(1) time for ground constraints where A and B do not share
  89 %%        any variables
  90 %%      * ground matching seems to be not optimized for compound terms
  91 %%        in case of simpagation_head2 and propagation occurrences
  92 %%      * analysis for storage delaying (see primes for case)
  93 %%      * internal constraints declaration + analyses?
  94 %%      * Do not store in global variable store if not necessary
  95 %%              NOTE: affects show_store/1
  96 %%      * var_assoc multi-level store: variable - ground
  97 %%      * Do not maintain/check unnecessary propagation history
  98 %%              for reasons of anti-monotony
  99 %%      * Strengthen storage analysis for propagation rules
 100 %%              reason about bodies of rules only containing constraints
 101 %%              -> fixpoint with observation analysis
 102 %%      * instantiation declarations
 103 %%              COMPOUND (bound to nonvar)
 104 %%                      avoid nonvar tests
 105 %%
 106 %%      * make difference between cheap guards          for reordering
 107 %%                            and non-binding guards    for lock removal
 108 %%      * fd -> once/[] transformation for propagation
 109 %%      * cheap guards interleaved with head retrieval + faster
 110 %%        via-retrieval + non-empty checking for propagation rules
 111 %%        redo for simpagation_head2 prelude
 112 %%      * intelligent backtracking for simplification/simpagation rule
 113 %%              generator_1(X),'_$savecp'(CP_1),
 114 %%              ...
 115 %%              if( (
 116 %%                      generator_n(Y),
 117 %%                      test(X,Y)
 118 %%                  ),
 119 %%                  true,
 120 %%                  ('_$cutto'(CP_1), fail)
 121 %%              ),
 122 %%              ...
 123 %%
 124 %%        or recently developped cascading-supported approach
 125 %%      * intelligent backtracking for propagation rule
 126 %%          use additional boolean argument for each possible smart backtracking
 127 %%          when boolean at end of list true  -> no smart backtracking
 128 %%                                      false -> smart backtracking
 129 %%          only works for rules with at least 3 constraints in the head
 130 %%      * (set semantics + functional dependency) declaration + resolution
 131 %%      * identify cases where prefixes of partner lookups for subsequent occurrences can be
 132 %%        merged
 133 %%
 134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 135 :- module(chr_translate,
 136           [ chr_translate/2             % +Decls, -TranslatedDecls
 137           ]).
 138 %% SWI begin
 139 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
 140 :- use_module(library(ordsets)).
 141 %% SWI end
 142
 143 :- use_module(hprolog).
 144 :- use_module(pairlist).
 145 :- use_module(a_star).
 146 :- use_module(listmap).
 147 :- use_module(clean_code).
 148 :- use_module(builtins).
 149 :- use_module(find).
 150 :- use_module(guard_entailment).
 151 :- use_module(chr_compiler_options).
 152 :- use_module(chr_compiler_utility).
 153 :- use_module(chr_compiler_errors).
 154 :- include(chr_op).
 155 :- op(1150, fx, chr_type).
 156 :- op(1130, xfx, --->).
 157 :- op(980, fx, (+)).
 158 :- op(980, fx, (-)).
 159 :- op(980, fx, (?)).
 160 :- op(1150, fx, constraints).
 161 :- op(1150, fx, chr_constraint).
 162
 163 :- chr_option(debug,off).
 164 :- chr_option(optimize,full).
 165 :- chr_option(check_guard_bindings,off).
 166
 167 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 168
 169 :- chr_type list(T)     ---> [] ; [T|list(T)].
 170 :- chr_type list        ==   list(any).
 171
 172 :- chr_type maybe(T)    ---> yes(T) ; no.
 173
 174 :- chr_type constraint ---> any / any.
 175
 176 :- chr_type module_name == any.
 177
 178 :- chr_type pragma_rule --->    pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb).
 179 :- chr_type rule        --->    rule(list(any),list(any),goal,goal).
 180 :- chr_type idspair     --->    ids(list(id),list(id)).
 181
 182 :- chr_type pragma_type --->    passive(id)
 183                         ;       mpassive(list(id))
 184                         ;       already_in_heads
 185                         ;       already_in_heads(id)
 186                         ;       no_history
 187                         ;       history(history_name,list(id)).
 188 :- chr_type history_name==      any.
 189
 190 :- chr_type rule_name   ==      any.
 191 :- chr_type rule_nb     ==      natural.
 192 :- chr_type id          ==      natural.
 193
 194 :- chr_type goal        ==      any.
 195
 196 :- chr_type store_type  --->    default
 197                         ;       multi_store(list(store_type))
 198                         ;       multi_hash(list(list(int)))
 199                         ;       multi_inthash(list(list(int)))
 200                         ;       global_singleton
 201                         ;       global_ground
 202                         %       EXPERIMENTAL STORES
 203                         ;       var_assoc_store(int,list(int))
 204                         ;       identifier_store(int)
 205                         ;       type_indexed_identifier_store(int,any).
 206
 207 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 208
 209 %------------------------------------------------------------------------------%
 210 :- chr_constraint target_module/1.
 211 :- chr_option(mode,target_module(+)).
 212 :- chr_option(type_declaration,target_module(module_name)).
 213 %------------------------------------------------------------------------------%
 214 target_module(_) \ target_module(_) <=> true.
 215
 216 %------------------------------------------------------------------------------%
 217 :- chr_constraint get_target_module/1.
 218 :- chr_option(mode,get_target_module(-)).
 219 :- chr_option(type_declaration,get_target_module(module_name)).
 220 %------------------------------------------------------------------------------%
 221 target_module(Mod) \ get_target_module(Query)
 222         <=> Query = Mod .
 223 get_target_module(Query)
 224         <=> Query = user.
 225
 226 :- chr_constraint indexed_argument/2.                   % argument instantiation may enable applicability of rule
 227 :- chr_option(mode,indexed_argument(+,+)).
 228 :- chr_option(type_declaration,indexed_argument(constraint,int)).
 229
 230 :- chr_constraint is_indexed_argument/2.
 231 :- chr_option(mode,is_indexed_argument(+,+)).
 232 :- chr_option(type_declaration,is_indexed_argument(constraint,int)).
 233
 234 :- chr_constraint constraint_mode/2.
 235 :- chr_option(mode,constraint_mode(+,+)).
 236 :- chr_option(type_declaration,constraint_mode(constraint,list)).
 237
 238 :- chr_constraint get_constraint_mode/2.
 239 :- chr_option(mode,get_constraint_mode(+,-)).
 240 :- chr_option(type_declaration,get_constraint_mode(constraint,list)).
 241
 242 :- chr_constraint may_trigger/1.
 243 :- chr_option(mode,may_trigger(+)).
 244 :- chr_option(type_declaration,may_trigger(constraint)).
 245
 246 :- chr_constraint only_ground_indexed_arguments/1.
 247 :- chr_option(mode,only_ground_indexed_arguments(+)).
 248 :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)).
 249
 250 :- chr_constraint none_suspended_on_variables/0.
 251
 252 :- chr_constraint are_none_suspended_on_variables/0.
 253
 254 :- chr_constraint store_type/2.
 255 :- chr_option(mode,store_type(+,+)).
 256 :- chr_option(type_declaration,store_type(constraint,store_type)).
 257
 258 :- chr_constraint get_store_type/2.
 259 :- chr_option(mode,get_store_type(+,?)).
 260 :- chr_option(type_declaration,get_store_type(constraint,store_type)).
 261
 262 :- chr_constraint update_store_type/2.
 263 :- chr_option(mode,update_store_type(+,+)).
 264 :- chr_option(type_declaration,update_store_type(constraint,store_type)).
 265
 266 :- chr_constraint actual_store_types/2.
 267 :- chr_option(mode,actual_store_types(+,+)).
 268 :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))).
 269
 270 :- chr_constraint assumed_store_type/2.
 271 :- chr_option(mode,assumed_store_type(+,+)).
 272 :- chr_option(type_declaration,assumed_store_type(constraint,store_type)).
 273
 274 :- chr_constraint validate_store_type_assumption/1.
 275 :- chr_option(mode,validate_store_type_assumption(+)).
 276 :- chr_option(type_declaration,validate_store_type_assumption(constraint)).
 277
 278 :- chr_constraint rule_count/1.
 279 :- chr_option(mode,rule_count(+)).
 280 :- chr_option(type_declaration,rule_count(natural)).
 281
 282 :- chr_constraint inc_rule_count/1.
 283 :- chr_option(mode,inc_rule_count(-)).
 284 :- chr_option(type_declaration,inc_rule_count(natural)).
 285
 286 rule_count(_) \ rule_count(_)
 287         <=> true.
 288 rule_count(C), inc_rule_count(NC)
 289         <=> NC is C + 1, rule_count(NC).
 290 inc_rule_count(NC)
 291         <=> NC = 1, rule_count(NC).
 292
 293 :- chr_constraint passive/2.
 294 :- chr_option(mode,passive(+,+)).
 295
 296 :- chr_constraint is_passive/2.
 297 :- chr_option(mode,is_passive(+,+)).
 298
 299 :- chr_constraint any_passive_head/1.
 300 :- chr_option(mode,any_passive_head(+)).
 301
 302 :- chr_constraint new_occurrence/4.
 303 :- chr_option(mode,new_occurrence(+,+,+,+)).
 304
 305 :- chr_constraint occurrence/5.
 306 :- chr_option(mode,occurrence(+,+,+,+,+)).
 307
 308 :- chr_constraint get_occurrence/4.
 309 :- chr_option(mode,get_occurrence(+,+,-,-)).
 310
 311 :- chr_constraint get_occurrence_from_id/4.
 312 :- chr_option(mode,get_occurrence_from_id(+,-,+,+)).
 313
 314 :- chr_constraint max_occurrence/2.
 315 :- chr_option(mode,max_occurrence(+,+)).
 316
 317 :- chr_constraint get_max_occurrence/2.
 318 :- chr_option(mode,get_max_occurrence(+,-)).
 319
 320 :- chr_constraint allocation_occurrence/2.
 321 :- chr_option(mode,allocation_occurrence(+,+)).
 322
 323 :- chr_constraint get_allocation_occurrence/2.
 324 :- chr_option(mode,get_allocation_occurrence(+,-)).
 325
 326 :- chr_constraint rule/2.
 327 :- chr_option(mode,rule(+,+)).
 328 :- chr_option(type_declaration,rule(rule_nb,pragma_rule)).
 329
 330 :- chr_constraint get_rule/2.
 331 :- chr_option(mode,get_rule(+,-)).
 332 :- chr_option(type_declaration,get_rule(int,pragma_rule)).
 333
 334 :- chr_constraint least_occurrence/2.
 335 :- chr_option(mode,least_occurrence(+,+)).
 336
 337 :- chr_constraint is_least_occurrence/1.
 338 :- chr_option(mode,is_least_occurrence(+)).
 339
 340
 341 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
 342 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
 343 is_indexed_argument(_,_) <=> fail.
 344
 345 %%% C O N S T R A I N T   M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 346
 347 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
 348 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
 349         Q = Mode.
 350 get_constraint_mode(FA,Q) <=>
 351         FA = _ / N,
 352         replicate(N,(?),Q).
 353
 354 %%% M A Y   T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 355
 356 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
 357 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
 358   nth1(I,Mode,M),
 359   M \== (+) |
 360   is_stored(FA).
 361 may_trigger(FA) <=> chr_pp_flag(debugable,on).  % in debug mode, we assume everything can be triggered
 362
 363 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
 364         <=>
 365                 nth1(I,Mode,M),
 366                 M \== (+)
 367         |
 368                 fail.
 369 only_ground_indexed_arguments(_) <=>
 370         true.
 371
 372 none_suspended_on_variables \ none_suspended_on_variables <=> true.
 373 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
 374 are_none_suspended_on_variables <=> fail.
 375 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 376
 377 store_type(FA,Store) \ get_store_type(FA,Query)
 378         <=> Query = Store.
 379
 380 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
 381         <=> Query = Store.
 382 get_store_type(_,Query)
 383         <=> Query = default.
 384
 385 actual_store_types(C,STs) \ update_store_type(C,ST)
 386         <=> member(ST,STs) | true.
 387 update_store_type(C,ST), actual_store_types(C,STs)
 388         <=>
 389                 actual_store_types(C,[ST|STs]).
 390 update_store_type(C,ST)
 391         <=>
 392                 actual_store_types(C,[ST]).
 393
 394 % refine store type assumption
 395 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_)   % automatic assumption
 396         <=>
 397                 store_type(C,multi_store(STs)).
 398 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_)           % user assumption
 399         <=>
 400                 store_type(C,multi_store(STs)).
 401 validate_store_type_assumption(C), assumed_store_type(C,_)                              % no lookups on constraint in debug mode
 402         <=>
 403                 chr_pp_flag(debugable,on)
 404         |
 405                 store_type(C,default).
 406 validate_store_type_assumption(C), assumed_store_type(C,_)                              % no lookups on constraint
 407         <=> store_type(C,global_ground).
 408 validate_store_type_assumption(C)
 409         <=> true.
 410
 411 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 412 passive(R,ID) \ passive(R,ID) <=> true.
 413
 414 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
 415 is_passive(_,_) <=> fail.
 416
 417 passive(RuleNb,_) \ any_passive_head(RuleNb)
 418         <=> true.
 419 any_passive_head(_)
 420         <=> fail.
 421 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 422
 423 max_occurrence(C,N) \ max_occurrence(C,M)
 424         <=> N >= M | true.
 425
 426 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
 427         NO is MO + 1,
 428         occurrence(C,NO,RuleNb,ID,Type),
 429         max_occurrence(C,NO).
 430 new_occurrence(C,RuleNb,ID,_) <=>
 431         chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
 432
 433 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
 434         <=> Q = MON.
 435 get_max_occurrence(C,Q)
 436         <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
 437
 438 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
 439         <=> Rule = QRule, ID = QID.
 440 get_occurrence(C,O,_,_)
 441         <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
 442
 443 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID)
 444         <=> QC = C, QON = ON.
 445 get_occurrence_from_id(C,O,_,_)
 446         <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
 447
 448 % A L L O C C A T I O N   O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 449
 450 % cannot store constraint at passive occurrence
 451 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ allocation_occurrence(C,O)
 452         <=> NO is O + 1, allocation_occurrence(C,NO).
 453
 454 % need not store constraint that is removed,
 455 % unless it has to be stored in the guard of the rule
 456 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_) \ allocation_occurrence(C,O)
 457         <=> \+ is_stored_in_guard(C,RuleNb), Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
 458         | NO is O + 1, allocation_occurrence(C,NO).
 459
 460 % need not store constraint if does not observe itself
 461 % (for propagation rules we could have to allocate (history))
 462 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
 463         <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
 464         | NO is O + 1, allocation_occurrence(C,NO).
 465 % need not store constraint if does not observe itself and cannot trigger
 466 % (then no history is needed)
 467 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_), least_occurrence(RuleNb,[])
 468         \ allocation_occurrence(C,O)
 469         <=> Rule = pragma(rule([],_,_,_),_,_,_,_), \+ is_observed(C,O)
 470         | NO is O + 1, allocation_occurrence(C,NO).
 471
 472 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
 473         \ least_occurrence(RuleNb,[ID|IDs])
 474         <=> AO >= O, \+ may_trigger(C) |
 475         least_occurrence(RuleNb,IDs).
 476 rule(RuleNb,Rule), passive(RuleNb,ID)
 477         \ least_occurrence(RuleNb,[ID|IDs])
 478         <=> least_occurrence(RuleNb,IDs).
 479
 480 rule(RuleNb,Rule)
 481         ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
 482         least_occurrence(RuleNb,IDs).
 483
 484 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
 485         <=> true.
 486 is_least_occurrence(_)
 487         <=> fail.
 488
 489 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
 490         <=> Q = O.
 491 get_allocation_occurrence(_,Q)
 492         <=> chr_pp_flag(late_allocation,off), Q=0.
 493 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 494
 495 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
 496         <=> Q = Rule.
 497 get_rule(_,_)
 498         <=> fail.
 499
 500 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 501
 502 %%% C O N S T R A I N T   I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 503 %
 504 % Default store constraint index assignment.
 505
 506 :- chr_constraint constraint_index/2.                   % constraint_index(F/A,DefaultStoreAndAttachedIndex)
 507 :- chr_option(mode,constraint_index(+,+)).
 508 :- chr_option(type_declaration,constraint_index(constraint,int)).
 509
 510 :- chr_constraint get_constraint_index/2.
 511 :- chr_option(mode,get_constraint_index(+,-)).
 512 :- chr_option(type_declaration,get_constraint_index(constraint,int)).
 513
 514 :- chr_constraint get_indexed_constraint/2.
 515 :- chr_option(mode,get_indexed_constraint(+,-)).
 516 :- chr_option(type_declaration,get_indexed_constraint(int,constraint)).
 517
 518 :- chr_constraint max_constraint_index/1.                       % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
 519 :- chr_option(mode,max_constraint_index(+)).
 520 :- chr_option(type_declaration,max_constraint_index(int)).
 521
 522 :- chr_constraint get_max_constraint_index/1.
 523 :- chr_option(mode,get_max_constraint_index(-)).
 524 :- chr_option(type_declaration,get_max_constraint_index(int)).
 525
 526 constraint_index(C,Index) \ get_constraint_index(C,Query)
 527         <=> Query = Index.
 528 get_constraint_index(C,Query)
 529         <=> fail.
 530
 531 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
 532         <=> Q = C.
 533 get_indexed_constraint(Index,Q)
 534         <=> fail.
 535
 536 max_constraint_index(Index) \ get_max_constraint_index(Query)
 537         <=> Query = Index.
 538 get_max_constraint_index(Query)
 539         <=> Query = 0.
 540
 541 set_constraint_indices(Constraints) :-
 542         set_constraint_indices(Constraints,1).
 543 set_constraint_indices([],M) :-
 544         N is M - 1,
 545         max_constraint_index(N).
 546 set_constraint_indices([C|Cs],N) :-
 547         ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ;  is_stored(C), get_store_type(C,default)
 548           ; get_store_type(C,var_assoc_store(_,_))) ->
 549                 constraint_index(C,N),
 550                 M is N + 1,
 551                 set_constraint_indices(Cs,M)
 552         ;
 553                 set_constraint_indices(Cs,N)
 554         ).
 555
 556 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 557 % Identifier Indexes
 558
 559 :- chr_constraint identifier_size/1.
 560 :- chr_option(mode,identifier_size(+)).
 561 :- chr_option(type_declaration,identifier_size(natural)).
 562
 563 identifier_size(_) \ identifier_size(_)
 564         <=>
 565                 true.
 566
 567 :- chr_constraint get_identifier_size/1.
 568 :- chr_option(mode,get_identifier_size(-)).
 569 :- chr_option(type_declaration,get_identifier_size(natural)).
 570
 571 identifier_size(Size) \ get_identifier_size(Q)
 572         <=>
 573                 Q = Size.
 574
 575 get_identifier_size(Q)
 576         <=>
 577                 Q = 1.
 578
 579 :- chr_constraint identifier_index/3.
 580 :- chr_option(mode,identifier_index(+,+,+)).
 581 :- chr_option(type_declaration,identifier_index(constraint,natural,natural)).
 582
 583 identifier_index(C,I,_) \ identifier_index(C,I,_)
 584         <=>
 585                 true.
 586
 587 :- chr_constraint get_identifier_index/3.
 588 :- chr_option(mode,get_identifier_index(+,+,-)).
 589 :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)).
 590
 591 identifier_index(C,I,II) \ get_identifier_index(C,I,Q)
 592         <=>
 593                 Q = II.
 594 identifier_size(Size), get_identifier_index(C,I,Q)
 595         <=>
 596                 NSize is Size + 1,
 597                 identifier_index(C,I,NSize),
 598                 identifier_size(NSize),
 599                 Q = NSize.
 600 get_identifier_index(C,I,Q)
 601         <=>
 602                 identifier_index(C,I,2),
 603                 identifier_size(2),
 604                 Q = 2.
 605
 606 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 607 % Type Indexed Identifier Indexes
 608
 609 :- chr_constraint type_indexed_identifier_size/2.
 610 :- chr_option(mode,type_indexed_identifier_size(+,+)).
 611 :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)).
 612
 613 type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_)
 614         <=>
 615                 true.
 616
 617 :- chr_constraint get_type_indexed_identifier_size/2.
 618 :- chr_option(mode,get_type_indexed_identifier_size(+,-)).
 619 :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)).
 620
 621 type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q)
 622         <=>
 623                 Q = Size.
 624
 625 get_type_indexed_identifier_size(IndexType,Q)
 626         <=>
 627                 Q = 1.
 628
 629 :- chr_constraint type_indexed_identifier_index/4.
 630 :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)).
 631 :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)).
 632
 633 type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_)
 634         <=>
 635                 true.
 636
 637 :- chr_constraint get_type_indexed_identifier_index/4.
 638 :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)).
 639 :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)).
 640
 641 type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q)
 642         <=>
 643                 Q = II.
 644 type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q)
 645         <=>
 646                 NSize is Size + 1,
 647                 type_indexed_identifier_index(IndexType,C,I,NSize),
 648                 type_indexed_identifier_size(IndexType,NSize),
 649                 Q = NSize.
 650 get_type_indexed_identifier_index(IndexType,C,I,Q)
 651         <=>
 652                 type_indexed_identifier_index(IndexType,C,I,2),
 653                 type_indexed_identifier_size(IndexType,2),
 654                 Q = 2.
 655
 656 type_indexed_identifier_structure(IndexType,Structure) :-
 657         type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor),
 658         get_type_indexed_identifier_size(IndexType,Arity),
 659         functor(Structure,Functor,Arity).
 660 type_indexed_identifier_name(IndexType,Prefix,Name) :-
 661         ( atom(IndexType) ->
 662                 IndexTypeName = IndexType
 663         ;
 664                 term_to_atom(IndexType,IndexTypeName)
 665         ),
 666         atom_concat_list([Prefix,'_',IndexTypeName],Name).
 667
 668 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 669
 670
 671
 672
 673 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 674 %%
 675 %% Translation
 676
 677 chr_translate(Declarations,NewDeclarations) :-
 678         chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]),
 679         init_chr_pp_flags,
 680         partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
 681         check_declared_constraints(Constraints0),
 682         generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
 683         add_constraints(Constraints),
 684         add_rules(Rules),
 685         % start analysis
 686         check_rules(Rules,Constraints),
 687         time('type checking',chr_translate:static_type_check),
 688         add_occurrences(Rules),
 689         time('functional dependency',chr_translate:functional_dependency_analysis(Rules)),
 690         time('set semantics',chr_translate:set_semantics_rules(Rules)),
 691         time('symmetry analysis',chr_translate:symmetry_analysis(Rules)),
 692         time('guard simplification',chr_translate:guard_simplification),
 693         time('late storage',chr_translate:storage_analysis(Constraints)),
 694         time('observation',chr_translate:observation_analysis(Constraints)),
 695         time('ai observation',chr_translate:ai_observation_analysis(Constraints)),
 696         time('late allocation',chr_translate:late_allocation_analysis(Constraints)),
 697         partial_wake_analysis,
 698         time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)),
 699         time('default constraint indices',chr_translate:set_constraint_indices(Constraints)),
 700         % end analysis
 701         time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)),
 702         time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)),
 703         phase_end(validate_store_type_assumptions),
 704         used_states_known,
 705         time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)),   % depends on actual code used
 706         insert_declarations(OtherClauses, Clauses0),
 707         chr_module_declaration(CHRModuleDeclaration),
 708         append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
 709         clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
 710         append([Clauses0,GeneratedClauses], NewDeclarations).
 711
 712 store_management_preds(Constraints,Clauses) :-
 713         generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
 714         generate_attr_unify_hook(AttrUnifyHookClauses),
 715         generate_attach_increment(AttachIncrementClauses),
 716         generate_extra_clauses(Constraints,ExtraClauses),
 717         generate_insert_delete_constraints(Constraints,DeleteClauses),
 718         generate_attach_code(Constraints,StoreClauses),
 719         generate_counter_code(CounterClauses),
 720         generate_dynamic_type_check_clauses(TypeCheckClauses),
 721         append([AttachAConstraintClauses
 722                ,AttachIncrementClauses
 723                ,AttrUnifyHookClauses
 724                ,ExtraClauses
 725                ,DeleteClauses
 726                ,StoreClauses
 727                ,CounterClauses
 728                ,TypeCheckClauses
 729                ]
 730               ,Clauses).
 731
 732
 733 insert_declarations(Clauses0, Clauses) :-
 734         findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
 735         append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
 736
 737 auxiliary_module(chr_hashtable_store).
 738 auxiliary_module(chr_integertable_store).
 739 auxiliary_module(chr_assoc_store).
 740
 741 generate_counter_code(Clauses) :-
 742         ( chr_pp_flag(store_counter,on) ->
 743                 Clauses = [
 744                         ('$counter_init'(N1) :- nb_setval(N1,0)) ,
 745                         ('$counter'(N2,X1) :- nb_getval(N2,X1)),
 746                         ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
 747                         (:- '$counter_init'('$insert_counter')),
 748                         (:- '$counter_init'('$delete_counter')),
 749                         ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
 750                         ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
 751                         ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
 752                 ]
 753         ;
 754                 Clauses = []
 755         ).
 756
 757 % for systems with multifile declaration
 758 chr_module_declaration(CHRModuleDeclaration) :-
 759         get_target_module(Mod),
 760         ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
 761                 CHRModuleDeclaration = [
 762                         (:- multifile chr:'$chr_module'/1),
 763                         chr:'$chr_module'(Mod)
 764                 ]
 765         ;
 766                 CHRModuleDeclaration = []
 767         ).
 768
 769
 770 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 771 %%
 772 %% Partitioning of clauses into constraint declarations, chr rules and other
 773 %% clauses
 774
 775 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 776 %%      partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det.
 777 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 778 partition_clauses([],[],[],[]).
 779 partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :-
 780         ( parse_rule(Clause,Rule) ->
 781                 ConstraintDeclarations = RestConstraintDeclarations,
 782                 Rules = [Rule|RestRules],
 783                 OtherClauses = RestOtherClauses
 784         ; is_declaration(Clause,ConstraintDeclaration) ->
 785                 append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations),
 786                 Rules = RestRules,
 787                 OtherClauses = RestOtherClauses
 788         ; is_module_declaration(Clause,Mod) ->
 789                 target_module(Mod),
 790                 ConstraintDeclarations = RestConstraintDeclarations,
 791                 Rules = RestRules,
 792                 OtherClauses = [Clause|RestOtherClauses]
 793         ; is_type_definition(Clause) ->
 794                 ConstraintDeclarations = RestConstraintDeclarations,
 795                 Rules = RestRules,
 796                 OtherClauses = RestOtherClauses
 797         ; Clause = (handler _) ->
 798                 chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
 799                 ConstraintDeclarations = RestConstraintDeclarations,
 800                 Rules = RestRules,
 801                 OtherClauses = RestOtherClauses
 802         ; Clause = (rules _) ->
 803                 chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
 804                 ConstraintDeclarations = RestConstraintDeclarations,
 805                 Rules = RestRules,
 806                 OtherClauses = RestOtherClauses
 807         ; Clause = option(OptionName,OptionValue) ->
 808                 chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]),
 809                 handle_option(OptionName,OptionValue),
 810                 ConstraintDeclarations = RestConstraintDeclarations,
 811                 Rules = RestRules,
 812                 OtherClauses = RestOtherClauses
 813         ; Clause = (:-chr_option(OptionName,OptionValue)) ->
 814                 handle_option(OptionName,OptionValue),
 815                 ConstraintDeclarations = RestConstraintDeclarations,
 816                 Rules = RestRules,
 817                 OtherClauses = RestOtherClauses
 818         ; Clause = ('$chr_compiled_with_version'(_)) ->
 819                 ConstraintDeclarations = RestConstraintDeclarations,
 820                 Rules = RestRules,
 821                 OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses]
 822         ; ConstraintDeclarations = RestConstraintDeclarations,
 823                 Rules = RestRules,
 824                 OtherClauses = [Clause|RestOtherClauses]
 825         ),
 826         partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses).
 827
 828 '$chr_compiled_with_version'(2).
 829
 830 is_declaration(D, Constraints) :-               %% constraint declaration
 831         ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
 832                 conj2list(Cs,Constraints0)
 833         ;
 834                 ( D = (:- Decl) ->
 835                         Decl =.. [constraints,Cs]
 836                 ;
 837                         D =.. [constraints,Cs]
 838                 ),
 839                 conj2list(Cs,Constraints0),
 840                 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
 841         ),
 842         extract_type_mode(Constraints0,Constraints).
 843
 844 extract_type_mode([],[]).
 845 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
 846 extract_type_mode([C|R],[ConstraintSymbol|R2]) :-
 847         functor(C,F,A),
 848         ConstraintSymbol = F/A,
 849         C =.. [_|Args],
 850         extract_types_and_modes(Args,ArgTypes,ArgModes),
 851         constraint_type(ConstraintSymbol,ArgTypes),
 852         constraint_mode(ConstraintSymbol,ArgModes),
 853         extract_type_mode(R,R2).
 854
 855 extract_types_and_modes([],[],[]).
 856 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
 857         extract_type_and_mode(X,T,M),
 858         extract_types_and_modes(R,R2,R3).
 859
 860 extract_type_and_mode(+(T),T,(+)) :- !.
 861 extract_type_and_mode(?(T),T,(?)) :- !.
 862 extract_type_and_mode(-(T),T,(-)) :- !.
 863 extract_type_and_mode((+),any,(+)) :- !.
 864 extract_type_and_mode((?),any,(?)) :- !.
 865 extract_type_and_mode((-),any,(-)) :- !.
 866 extract_type_and_mode(Illegal,_,_) :-
 867     chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
 868
 869 is_type_definition(Declaration) :-
 870         ( Declaration = (:- TDef) ->
 871               true
 872         ;
 873               Declaration = TDef
 874         ),
 875         TDef =.. [chr_type,TypeDef],
 876         ( TypeDef = (Name ---> Def) ->
 877               tdisj2list(Def,DefList),
 878                 type_definition(Name,DefList)
 879         ; TypeDef = (Alias == Name) ->
 880                 type_alias(Alias,Name)
 881         ;
 882                 type_definition(TypeDef,[]),
 883                 chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration])
 884         ).
 885
 886 %%      tdisj2list(+Goal,-ListOfGoals) is det.
 887 %
 888 %       no removal of fails, e.g. :- type bool --->  true ; fail.
 889 tdisj2list(Conj,L) :-
 890         tdisj2list(Conj,L,[]).
 891
 892 tdisj2list(Conj,L,T) :-
 893         Conj = (G1;G2), !,
 894         tdisj2list(G1,L,T1),
 895         tdisj2list(G2,T1,T).
 896 tdisj2list(G,[G | T],T).
 897
 898
 899 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 900 %%      parse_rule(+term,-pragma_rule) is semidet.
 901 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 902 parse_rule(RI,R) :-                             %% name @ rule
 903         RI = (Name @ RI2), !,
 904         rule(RI2,yes(Name),R).
 905 parse_rule(RI,R) :-
 906         rule(RI,no,R).
 907
 908 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 909 %%      parse_rule(+term,-pragma_rule) is semidet.
 910 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
 911 rule(RI,Name,R) :-
 912         RI = (RI2 pragma P), !,                 %% pragmas
 913         ( var(P) ->
 914                 Ps = [_]                        % intercept variable
 915         ;
 916                 conj2list(P,Ps)
 917         ),
 918         inc_rule_count(RuleCount),
 919         R = pragma(R1,IDs,Ps,Name,RuleCount),
 920         is_rule(RI2,R1,IDs,R).
 921 rule(RI,Name,R) :-
 922         inc_rule_count(RuleCount),
 923         R = pragma(R1,IDs,[],Name,RuleCount),
 924         is_rule(RI,R1,IDs,R).
 925
 926 is_rule(RI,R,IDs,RC) :-                         %% propagation rule
 927    RI = (H ==> B), !,
 928    conj2list(H,Head2i),
 929    get_ids(Head2i,IDs2,Head2,RC),
 930    IDs = ids([],IDs2),
 931    (   B = (G | RB) ->
 932        R = rule([],Head2,G,RB)
 933    ;
 934        R = rule([],Head2,true,B)
 935    ).
 936 is_rule(RI,R,IDs,RC) :-                         %% simplification/simpagation rule
 937    RI = (H <=> B), !,
 938    (   B = (G | RB) ->
 939        Guard = G,
 940        Body  = RB
 941    ;   Guard = true,
 942        Body = B
 943    ),
 944    (   H = (H1 \ H2) ->
 945        conj2list(H1,Head2i),
 946        conj2list(H2,Head1i),
 947        get_ids(Head2i,IDs2,Head2,0,N,RC),
 948        get_ids(Head1i,IDs1,Head1,N,_,RC),
 949        IDs = ids(IDs1,IDs2)
 950    ;   conj2list(H,Head1i),
 951        Head2 = [],
 952        get_ids(Head1i,IDs1,Head1,RC),
 953        IDs = ids(IDs1,[])
 954    ),
 955    R = rule(Head1,Head2,Guard,Body).
 956
 957 get_ids(Cs,IDs,NCs,RC) :-
 958         get_ids(Cs,IDs,NCs,0,_,RC).
 959
 960 get_ids([],[],[],N,N,_).
 961 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
 962         ( C = (NC # N1) ->
 963                 ( var(N1) ->
 964                         N1 = N
 965                 ;
 966                         check_direct_pragma(N1,N,RC)
 967                 )
 968         ;
 969                 NC = C
 970         ),
 971         M is N + 1,
 972         get_ids(Cs,IDs,NCs, M,NN,RC).
 973
 974 check_direct_pragma(passive,Id,PragmaRule) :- !,
 975         PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
 976         passive(RuleNb,Id).
 977 check_direct_pragma(Abbrev,Id,PragmaRule) :-
 978         ( direct_pragma(FullPragma),
 979           atom_concat(Abbrev,Remainder,FullPragma) ->
 980                 chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma])
 981         ;
 982                 chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[])
 983         ).
 984
 985 direct_pragma(passive).
 986
 987 is_module_declaration((:- module(Mod)),Mod).
 988 is_module_declaration((:- module(Mod,_)),Mod).
 989
 990 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 991
 992 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 993 % Add constraints
 994 add_constraints([]).
 995 add_constraints([C|Cs]) :-
 996         max_occurrence(C,0),
 997         C = _/A,
 998         length(Mode,A),
 999         set_elems(Mode,?),
1000         constraint_mode(C,Mode),
1001         add_constraints(Cs).
1002
1003 % Add rules
1004 add_rules([]).
1005 add_rules([Rule|Rules]) :-
1006         Rule = pragma(_,_,_,_,RuleNb),
1007         rule(RuleNb,Rule),
1008         add_rules(Rules).
1009
1010 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1011
1012 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1013 %% Some input verification:
1014
1015 check_declared_constraints(Constraints) :-
1016         check_declared_constraints(Constraints,[]).
1017
1018 check_declared_constraints([],_).
1019 check_declared_constraints([C|Cs],Acc) :-
1020         ( memberchk_eq(C,Acc) ->
1021                 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
1022         ;
1023                 true
1024         ),
1025         check_declared_constraints(Cs,[C|Acc]).
1026
1027 %%  - all constraints in heads are declared constraints
1028 %%  - all passive pragmas refer to actual head constraints
1029
1030 check_rules([],_).
1031 check_rules([PragmaRule|Rest],Decls) :-
1032         check_rule(PragmaRule,Decls),
1033         check_rules(Rest,Decls).
1034
1035 check_rule(PragmaRule,Decls) :-
1036         check_rule_indexing(PragmaRule),
1037         check_trivial_propagation_rule(PragmaRule),
1038         PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
1039         Rule = rule(H1,H2,_,_),
1040         append(H1,H2,HeadConstraints),
1041         check_head_constraints(HeadConstraints,Decls,PragmaRule),
1042         check_pragmas(Pragmas,PragmaRule).
1043
1044 %       Make all heads passive in trivial propagation rule
1045 %       ... ==> ... | true.
1046 check_trivial_propagation_rule(PragmaRule) :-
1047         PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
1048         ( Rule = rule([],_,_,true) ->
1049                 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
1050                 set_all_passive(RuleNb)
1051         ;
1052                 true
1053         ).
1054
1055 check_head_constraints([],_,_).
1056 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
1057         functor(Constr,F,A),
1058         ( member(F/A,Decls) ->
1059                 check_head_constraints(Rest,Decls,PragmaRule)
1060         ;
1061                 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])
1062         ).
1063
1064 check_pragmas([],_).
1065 check_pragmas([Pragma|Pragmas],PragmaRule) :-
1066         check_pragma(Pragma,PragmaRule),
1067         check_pragmas(Pragmas,PragmaRule).
1068
1069 check_pragma(Pragma,PragmaRule) :-
1070         var(Pragma), !,
1071         chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
1072 check_pragma(passive(ID), PragmaRule) :-
1073         !,
1074         PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
1075         ( memberchk_eq(ID,IDs1) ->
1076                 true
1077         ; memberchk_eq(ID,IDs2) ->
1078                 true
1079         ;
1080                 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
1081         ),
1082         passive(RuleNb,ID).
1083
1084 check_pragma(mpassive(IDs), PragmaRule) :-
1085         !,
1086         PragmaRule = pragma(_,_,_,_,RuleNb),
1087         chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]),
1088         maplist(passive(RuleNb),IDs).
1089
1090 check_pragma(Pragma, PragmaRule) :-
1091         Pragma = already_in_heads,
1092         !,
1093         chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1094
1095 check_pragma(Pragma, PragmaRule) :-
1096         Pragma = already_in_head(_),
1097         !,
1098         chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
1099
1100 check_pragma(Pragma, PragmaRule) :-
1101         Pragma = no_history,
1102         !,
1103         chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
1104         PragmaRule = pragma(_,_,_,_,N),
1105         no_history(N).
1106
1107 check_pragma(Pragma, PragmaRule) :-
1108         Pragma = history(HistoryName,IDs),
1109         !,
1110         chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]),
1111         ( IDs == [] ->
1112                 chr_error(syntax(Pragma),'Invalid empty history.\n',[])
1113         ;
1114                 true
1115         ),
1116         PragmaRule = pragma(_,_,_,_,RuleNb),
1117         history(RuleNb,HistoryName,IDs).
1118
1119 check_pragma(Pragma,PragmaRule) :-
1120         chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
1121
1122 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1123 %%      no_history(+RuleNb) is det.
1124 :- chr_constraint no_history/1.
1125 :- chr_option(mode,no_history(+)).
1126 :- chr_option(type_declaration,no_history(int)).
1127
1128 %%      has_no_history(+RuleNb) is semidet.
1129 :- chr_constraint has_no_history/1.
1130 :- chr_option(mode,has_no_history(+)).
1131 :- chr_option(type_declaration,has_no_history(int)).
1132
1133 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
1134 has_no_history(_) <=> fail.
1135
1136 :- chr_constraint history/3.
1137 :- chr_option(mode,history(+,+,+)).
1138
1139 :- chr_constraint named_history/3.
1140
1141 history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs.
1142
1143 named_history(_,_,_) <=> fail.
1144
1145 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1146
1147
1148 format_rule(PragmaRule) :-
1149         PragmaRule = pragma(_,_,_,MaybeName,N),
1150         ( MaybeName = yes(Name) ->
1151                 write('rule '), write(Name)
1152         ;
1153                 write('rule number '), write(N)
1154         ).
1155
1156 check_rule_indexing(PragmaRule) :-
1157         PragmaRule = pragma(Rule,_,_,_,_),
1158         Rule = rule(H1,H2,G,_),
1159         term_variables(H1-H2,HeadVars),
1160         remove_anti_monotonic_guards(G,HeadVars,NG),
1161         check_indexing(H1,NG-H2),
1162         check_indexing(H2,NG-H1),
1163         % EXPERIMENT
1164         ( chr_pp_flag(term_indexing,on) ->
1165                 term_variables(NG,GuardVariables),
1166                 append(H1,H2,Heads),
1167                 check_specs_indexing(Heads,GuardVariables,Specs)
1168         ;
1169                 true
1170         ).
1171
1172 :- chr_constraint indexing_spec/2.
1173 :- chr_option(mode,indexing_spec(+,+)).
1174
1175 :- chr_constraint get_indexing_spec/2.
1176 :- chr_option(mode,get_indexing_spec(+,-)).
1177
1178
1179 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
1180 get_indexing_spec(_,Spec) <=> Spec = [].
1181
1182 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
1183         <=>
1184                 append(Specs1,Specs2,Specs),
1185                 indexing_spec(FA,Specs).
1186
1187 remove_anti_monotonic_guards(G,Vars,NG) :-
1188         conj2list(G,GL),
1189         remove_anti_monotonic_guard_list(GL,Vars,NGL),
1190         list2conj(NGL,NG).
1191
1192 remove_anti_monotonic_guard_list([],_,[]).
1193 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
1194         ( G = var(X), memberchk_eq(X,Vars) ->
1195                 NGs = RGs
1196 % TODO: this is not correct
1197 %       ; G = functor(Term,Functor,Arity),                      % isotonic
1198 %         \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
1199 %               NGs = RGs
1200         ;
1201                 NGs = [G|RGs]
1202         ),
1203         remove_anti_monotonic_guard_list(Gs,Vars,RGs).
1204
1205 check_indexing([],_).
1206 check_indexing([Head|Heads],Other) :-
1207         functor(Head,F,A),
1208         Head =.. [_|Args],
1209         term_variables(Heads-Other,OtherVars),
1210         check_indexing(Args,1,F/A,OtherVars),
1211         check_indexing(Heads,[Head|Other]).
1212
1213 check_indexing([],_,_,_).
1214 check_indexing([Arg|Args],I,FA,OtherVars) :-
1215         ( is_indexed_argument(FA,I) ->
1216                 true
1217         ; nonvar(Arg) ->
1218                 indexed_argument(FA,I)
1219         ; % var(Arg) ->
1220                 term_variables(Args,ArgsVars),
1221                 append(ArgsVars,OtherVars,RestVars),
1222                 ( memberchk_eq(Arg,RestVars) ->
1223                         indexed_argument(FA,I)
1224                 ;
1225                         true
1226                 )
1227         ),
1228         J is I + 1,
1229         term_variables(Arg,NVars),
1230         append(NVars,OtherVars,NOtherVars),
1231         check_indexing(Args,J,FA,NOtherVars).
1232
1233 check_specs_indexing([],_,[]).
1234 check_specs_indexing([Head|Heads],Variables,Specs) :-
1235         Specs = [Spec|RSpecs],
1236         term_variables(Heads,OtherVariables,Variables),
1237         check_spec_indexing(Head,OtherVariables,Spec),
1238         term_variables(Head,NVariables,Variables),
1239         check_specs_indexing(Heads,NVariables,RSpecs).
1240
1241 check_spec_indexing(Head,OtherVariables,Spec) :-
1242         functor(Head,F,A),
1243         Spec = spec(F,A,ArgSpecs),
1244         Head =.. [_|Args],
1245         check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
1246         indexing_spec(F/A,[ArgSpecs]).
1247
1248 check_args_spec_indexing([],_,_,[]).
1249 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1250         term_variables(Args,Variables,OtherVariables),
1251         ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1252                 ArgSpecs = [ArgSpec|RArgSpecs]
1253         ;
1254                 ArgSpecs = RArgSpecs
1255         ),
1256         J is I + 1,
1257         term_variables(Arg,NOtherVariables,OtherVariables),
1258         check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1259
1260 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1261         ( var(Arg) ->
1262                 memberchk_eq(Arg,Variables),
1263                 ArgSpec = specinfo(I,any,[])
1264         ;
1265                 functor(Arg,F,A),
1266                 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1267                 Arg =.. [_|Args],
1268                 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1269         ).
1270
1271 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1272
1273 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1274 % Occurrences
1275
1276 add_occurrences([]).
1277 add_occurrences([Rule|Rules]) :-
1278         Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1279         add_occurrences(H1,IDs1,simplification,Nb),
1280         add_occurrences(H2,IDs2,propagation,Nb),
1281         add_occurrences(Rules).
1282
1283 add_occurrences([],[],_,_).
1284 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1285         functor(H,F,A),
1286         FA = F/A,
1287         new_occurrence(FA,RuleNb,ID,Type),
1288         add_occurrences(Hs,IDs,Type,RuleNb).
1289
1290 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1291
1292 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1293 % Observation Analysis
1294 %
1295 % CLASSIFICATION
1296 %
1297 %
1298 %
1299 %
1300 %
1301 %
1302
1303 :- chr_constraint observation_analysis/1.
1304 :- chr_option(mode, observation_analysis(+)).
1305
1306 observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==>
1307         PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_),
1308         ( chr_pp_flag(store_in_guards, on) ->
1309                 observation_analysis(RuleNb, Guard, guard, Cs)
1310         ;
1311                 true
1312         ),
1313         observation_analysis(RuleNb, Body, body, Cs)
1314
1315         pragma passive(Id).
1316 observation_analysis(_) <=> true.
1317
1318 observation_analysis(RuleNb, Term, GB, Cs) :-
1319         ( all_spawned(RuleNb,GB) ->
1320                 true
1321         ; var(Term) ->
1322                 spawns_all(RuleNb,GB)
1323         ; Term = true ->
1324                 true
1325         ; Term = fail ->
1326                 true
1327         ; Term = '!' ->
1328                 true
1329         ; Term = (T1,T2) ->
1330                 observation_analysis(RuleNb,T1,GB,Cs),
1331                 observation_analysis(RuleNb,T2,GB,Cs)
1332         ; Term = (T1;T2) ->
1333                 observation_analysis(RuleNb,T1,GB,Cs),
1334                 observation_analysis(RuleNb,T2,GB,Cs)
1335         ; Term = (T1->T2) ->
1336                 observation_analysis(RuleNb,T1,GB,Cs),
1337                 observation_analysis(RuleNb,T2,GB,Cs)
1338         ; Term = (\+ T) ->
1339                 observation_analysis(RuleNb,T,GB,Cs)
1340         ; functor(Term,F,A), member(F/A,Cs) ->
1341                 spawns(RuleNb,GB,F/A)
1342         ; Term = (_ = _) ->
1343                 spawns_all_triggers(RuleNb,GB)
1344         ; Term = (_ is _) ->
1345                 spawns_all_triggers(RuleNb,GB)
1346         ; builtin_binds_b(Term,Vars) ->
1347                 (  Vars == [] ->
1348                         true
1349                 ;
1350                         spawns_all_triggers(RuleNb,GB)
1351                 )
1352         ;
1353                 spawns_all(RuleNb,GB)
1354         ).
1355
1356 :- chr_constraint spawns/3.
1357 :- chr_option(mode, spawns(+,+,+)).
1358
1359 :- chr_constraint spawns_all/2, spawns_all_triggers/2.
1360 :- chr_option(mode, spawns_all(+,+)).
1361 :- chr_option(mode, spawns_all_triggers(+,+)).
1362
1363 spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true.
1364 spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true.
1365 spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1366 spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1367 spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true.
1368 spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true.
1369
1370 spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true.
1371 spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true.
1372 spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true.
1373 spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true.
1374
1375 spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true.
1376 spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true.
1377
1378 spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1379          \
1380                 spawns(RuleNb1,GB,C1)
1381         <=>
1382                 \+ is_passive(RuleNb2,O)
1383          |
1384                 spawns_all(RuleNb1,GB)
1385         pragma
1386                 passive(Id).
1387
1388 occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_)
1389         ==>
1390                 \+(\+ spawns_all_triggers_implies_spawns_all),  % in the hope it schedules this guard early...
1391                 \+ is_passive(RuleNb2,O), may_trigger(C1)
1392          |
1393                 spawns_all_triggers_implies_spawns_all
1394         pragma
1395                 passive(Id).
1396
1397 :- chr_constraint spawns_all_triggers_implies_spawns_all/0.
1398 spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail.
1399 spawns_all_triggers_implies_spawns_all \
1400         spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB).
1401
1402 spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id
1403          \
1404                 spawns(RuleNb1,GB,C1)
1405         <=>
1406                 \+ is_passive(RuleNb2,O)
1407          |
1408                 spawns_all_triggers(RuleNb1,GB)
1409         pragma
1410                 passive(Id).
1411
1412 % a bit dangerous this rule: could start propagating too much too soon?
1413 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1414                 spawns(RuleNb1,GB,C1)
1415         ==>
1416                 RuleNb1 \== RuleNb2, C1 \== C2,
1417                 \+ is_passive(RuleNb2,O)
1418         |
1419                 spawns(RuleNb1,GB,C2)
1420         pragma
1421                 passive(Id).
1422
1423 spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id,
1424                 spawns_all_triggers(RuleNb1,GB)
1425         ==>
1426                 \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2)
1427          |
1428                 spawns(RuleNb1,GB,C2)
1429         pragma
1430                 passive(Id).
1431
1432
1433 :- chr_constraint all_spawned/2.
1434 :- chr_option(mode, all_spawned(+,+)).
1435 spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true.
1436 spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true.
1437 all_spawned(RuleNb,GB) <=> fail.
1438
1439 :- chr_constraint is_observed/3.
1440 :- chr_option(mode, is_observed(+,+,+)).
1441 occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB).
1442 is_observed(_,_,_) <=> throw('this cannot happen?').
1443
1444 :- chr_constraint do_is_observed/3.
1445 :- chr_option(mode, do_is_observed(+,+,?)).
1446
1447 spawns_all(RuleNb,GB),
1448                 occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1449          \
1450                 do_is_observed(C,RuleNb,Q)
1451          <=>
1452                 \+ is_passive(RuleNb2,O)
1453           |
1454                 Q = GB.
1455
1456 spawns(RuleNb,GB,C2),
1457                 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1458          \
1459                 do_is_observed(C,RuleNb,Q)
1460         <=>
1461                 \+ is_passive(RuleNb2,O)
1462          |
1463                 Q = GB.
1464
1465 spawns_all_triggers(RuleNb,GB),
1466                 occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_)
1467          \
1468                 do_is_observed(C,RuleNb,Q)
1469         <=>
1470                 \+ is_passive(RuleNb2,O), may_trigger(C2)
1471          |
1472                 Q = GB.
1473
1474 do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off).
1475
1476
1477 is_observed(C,O) :-
1478         is_observed(C,O,_),
1479         ai_is_observed(C,O).
1480
1481 is_stored_in_guard(C,RuleNb) :-
1482         chr_pp_flag(store_in_guards, on),
1483         do_is_observed(C,RuleNb,guard).
1484
1485 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1486
1487 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1488 % Late allocation
1489
1490 late_allocation_analysis(Cs) :-
1491         ( chr_pp_flag(late_allocation,on) ->
1492                 late_allocation(Cs)
1493         ;
1494                 true
1495         ).
1496
1497 late_allocation([]).
1498 late_allocation([C|Cs]) :-
1499         allocation_occurrence(C,1),
1500         late_allocation(Cs).
1501 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1502
1503 %%
1504 %% Generated predicates
1505 %%      attach_$CONSTRAINT
1506 %%      attach_increment
1507 %%      detach_$CONSTRAINT
1508 %%      attr_unify_hook
1509
1510 %%      attach_$CONSTRAINT
1511 generate_attach_detach_a_constraint_all([],[]).
1512 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1513         ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1514                 generate_attach_a_constraint(Constraint,Clauses1),
1515                 generate_detach_a_constraint(Constraint,Clauses2)
1516         ;
1517                 Clauses1 = [],
1518                 Clauses2 = []
1519         ),
1520         generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1521         append([Clauses1,Clauses2,Clauses3],Clauses).
1522
1523 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1524         generate_attach_a_constraint_nil(Constraint,Clause1),
1525         generate_attach_a_constraint_cons(Constraint,Clause2).
1526
1527 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1528         make_name('attach_',FA,Name),
1529         Atom =.. [Name,Vars,Susp].
1530
1531 generate_attach_a_constraint_nil(FA,Clause) :-
1532         Clause = (Head :- true),
1533         attach_constraint_atom(FA,[],_,Head).
1534
1535 generate_attach_a_constraint_cons(FA,Clause) :-
1536         Clause = (Head :- Body),
1537         attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1538         attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1539         Body = ( AttachBody, Subscribe, RecursiveCall ),
1540         get_max_constraint_index(N),
1541         ( N == 1 ->
1542                 generate_attach_body_1(FA,Var,Susp,AttachBody)
1543         ;
1544                 generate_attach_body_n(FA,Var,Susp,AttachBody)
1545         ),
1546         % SWI-Prolog specific code
1547         chr_pp_flag(solver_events,NMod),
1548         ( NMod \== none ->
1549                 Args = [[Var|_],Susp],
1550                 get_target_module(Mod),
1551                 use_auxiliary_predicate(run_suspensions),
1552                 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1553         ;
1554                 Subscribe = true
1555         ).
1556
1557 generate_attach_body_1(FA,Var,Susp,Body) :-
1558         get_target_module(Mod),
1559         Body =
1560         (   get_attr(Var, Mod, Susps) ->
1561             put_attr(Var, Mod, [Susp|Susps])
1562         ;
1563             put_attr(Var, Mod, [Susp])
1564         ).
1565
1566 generate_attach_body_n(F/A,Var,Susp,Body) :-
1567         get_constraint_index(F/A,Position),
1568         or_pattern(Position,Pattern),
1569         get_max_constraint_index(Total),
1570         make_attr(Total,Mask,SuspsList,Attr),
1571         nth1(Position,SuspsList,Susps),
1572         substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1573         make_attr(Total,Mask,SuspsList1,NewAttr1),
1574         substitute(Susps,SuspsList,[Susp],SuspsList2),
1575         make_attr(Total,NewMask,SuspsList2,NewAttr2),
1576         copy_term(SuspsList,SuspsList3),
1577         nth1(Position,SuspsList3,[Susp]),
1578         chr_delete(SuspsList3,[Susp],RestSuspsList),
1579         set_elems(RestSuspsList,[]),
1580         make_attr(Total,Pattern,SuspsList3,NewAttr3),
1581         get_target_module(Mod),
1582         Body =
1583         ( get_attr(Var,Mod,TAttr) ->
1584                 TAttr = Attr,
1585                 ( Mask /\ Pattern =:= Pattern ->
1586                         put_attr(Var, Mod, NewAttr1)
1587                 ;
1588                         NewMask is Mask \/ Pattern,
1589                         put_attr(Var, Mod, NewAttr2)
1590                 )
1591         ;
1592                 put_attr(Var,Mod,NewAttr3)
1593         ), !.
1594
1595 %%      detach_$CONSTRAINT
1596 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1597         generate_detach_a_constraint_nil(Constraint,Clause1),
1598         generate_detach_a_constraint_cons(Constraint,Clause2).
1599
1600 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1601         make_name('detach_',FA,Name),
1602         Atom =.. [Name,Vars,Susp].
1603
1604 generate_detach_a_constraint_nil(FA,Clause) :-
1605         Clause = ( Head :- true),
1606         detach_constraint_atom(FA,[],_,Head).
1607
1608 generate_detach_a_constraint_cons(FA,Clause) :-
1609         Clause = (Head :- Body),
1610         detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1611         detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1612         Body = ( DetachBody, RecursiveCall ),
1613         get_max_constraint_index(N),
1614         ( N == 1 ->
1615                 generate_detach_body_1(FA,Var,Susp,DetachBody)
1616         ;
1617                 generate_detach_body_n(FA,Var,Susp,DetachBody)
1618         ).
1619
1620 generate_detach_body_1(FA,Var,Susp,Body) :-
1621         get_target_module(Mod),
1622         Body =
1623         ( get_attr(Var,Mod,Susps) ->
1624                 'chr sbag_del_element'(Susps,Susp,NewSusps),
1625                 ( NewSusps == [] ->
1626                         del_attr(Var,Mod)
1627                 ;
1628                         put_attr(Var,Mod,NewSusps)
1629                 )
1630         ;
1631                 true
1632         ).
1633
1634 generate_detach_body_n(F/A,Var,Susp,Body) :-
1635         get_constraint_index(F/A,Position),
1636         or_pattern(Position,Pattern),
1637         and_pattern(Position,DelPattern),
1638         get_max_constraint_index(Total),
1639         make_attr(Total,Mask,SuspsList,Attr),
1640         nth1(Position,SuspsList,Susps),
1641         substitute(Susps,SuspsList,[],SuspsList1),
1642         make_attr(Total,NewMask,SuspsList1,Attr1),
1643         substitute(Susps,SuspsList,NewSusps,SuspsList2),
1644         make_attr(Total,Mask,SuspsList2,Attr2),
1645         get_target_module(Mod),
1646         Body =
1647         ( get_attr(Var,Mod,TAttr) ->
1648                 TAttr = Attr,
1649                 ( Mask /\ Pattern =:= Pattern ->
1650                         'chr sbag_del_element'(Susps,Susp,NewSusps),
1651                         ( NewSusps == [] ->
1652                                 NewMask is Mask /\ DelPattern,
1653                                 ( NewMask == 0 ->
1654                                         del_attr(Var,Mod)
1655                                 ;
1656                                         put_attr(Var,Mod,Attr1)
1657                                 )
1658                         ;
1659                                 put_attr(Var,Mod,Attr2)
1660                         )
1661                 ;
1662                         true
1663                 )
1664         ;
1665                 true
1666         ), !.
1667
1668 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1669 %-------------------------------------------------------------------------------
1670 %%      generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det.
1671 :- chr_constraint generate_indexed_variables_body/4.
1672 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1673 %-------------------------------------------------------------------------------
1674 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1675         get_indexing_spec(F/A,Specs),
1676         ( chr_pp_flag(term_indexing,on) ->
1677                 spectermvars(Specs,Args,F,A,Body,Vars)
1678         ;
1679                 get_constraint_type_det(F/A,ArgTypes),
1680                 create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N),
1681                 ( MaybeBody == empty ->
1682                         Body = true,
1683                         Vars = []
1684                 ; N == 0 ->
1685                         ( Args = [Term] ->
1686                                 true
1687                         ;
1688                                 Term =.. [term|Args]
1689                         ),
1690                         Body = term_variables(Term,Vars)
1691                 ;
1692                         MaybeBody = Body
1693                 )
1694         ).
1695 generate_indexed_variables_body(FA,_,_,_) <=>
1696         chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1697 %===============================================================================
1698
1699 create_indexed_variables_body([],[],[],_,_,_,empty,0).
1700 create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :-
1701         J is I + 1,
1702         create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M),
1703         ( Mode == (?),
1704           is_indexed_argument(FA,I) ->
1705                 ( atomic_type(Type) ->
1706                         Body =
1707                         (
1708                                 ( var(V) ->
1709                                         Vars = [V|Tail]
1710                                 ;
1711                                         Vars = Tail
1712                                 ),
1713                                 Continuation
1714                         ),
1715                         ( RBody == empty ->
1716                                 Continuation = true, Tail = []
1717                         ;
1718                                 Continuation = RBody
1719                         )
1720                 ;
1721                         ( RBody == empty ->
1722                                 Body = term_variables(V,Vars)
1723                         ;
1724                                 Body = (term_variables(V,Vars,Tail),RBody)
1725                         )
1726                 ),
1727                 N = M
1728         ; Mode == (-), is_indexed_argument(FA,I) ->
1729                 ( RBody == empty ->
1730                         Body = (Vars = [V])
1731                 ;
1732                         Body = (Vars = [V|Tail],RBody)
1733                 ),
1734                 N is M + 1
1735         ;
1736                 Vars = Tail,
1737                 Body = RBody,
1738                 N is M + 1
1739         ).
1740 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1741 % EXPERIMENTAL
1742 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1743         spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1744
1745 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1746 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1747         Goal = (ArgGoal,RGoal),
1748         argspecs(Specs,I,TempArgSpecs,RSpecs),
1749         merge_argspecs(TempArgSpecs,ArgSpecs),
1750         arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1751         J is I + 1,
1752         spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1753
1754 argspecs([],_,[],[]).
1755 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1756         argspecs(Rest,I,ArgSpecs,RestSpecs).
1757 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1758         ( I == J ->
1759                 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1760                 ( Specs = [] ->
1761                         RRestSpecs = RestSpecs
1762                 ;
1763                         RestSpecs = [Specs|RRestSpecs]
1764                 )
1765         ;
1766                 ArgSpecs = RArgSpecs,
1767                 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1768         ),
1769         argspecs(Rest,I,RArgSpecs,RRestSpecs).
1770
1771 merge_argspecs(In,Out) :-
1772         sort(In,Sorted),
1773         merge_argspecs_(Sorted,Out).
1774
1775 merge_argspecs_([],[]).
1776 merge_argspecs_([X],R) :- !, R = [X].
1777 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1778         ( (F1 == any ; F2 == any) ->
1779                 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1780         ; F1 == F2 ->
1781                 append(A1,A2,A),
1782                 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1783         ;
1784                 R = [specinfo(I,F1,A1)|RR],
1785                 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1786         ).
1787
1788 arggoal(List,Arg,Goal,L,T) :-
1789         ( List == [] ->
1790                 L = T,
1791                 Goal = true
1792         ; List = [specinfo(_,any,_)] ->
1793                 Goal = term_variables(Arg,L,T)
1794         ;
1795                 Goal =
1796                 ( var(Arg) ->
1797                         L = [Arg|T]
1798                 ;
1799                         Cases
1800                 ),
1801                 arggoal_cases(List,Arg,L,T,Cases)
1802         ).
1803
1804 arggoal_cases([],_,L,T,L=T).
1805 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1806         ( ArgSpecs == [] ->
1807                 Cases = RCases
1808         ; ArgSpecs == [[]] ->
1809                 Cases = RCases
1810         ; FA = F/A ->
1811                 Cases = (Case ; RCases),
1812                 functor(Term,F,A),
1813                 Term =.. [_|Args],
1814                 Case = (Arg = Term -> ArgsGoal),
1815                 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1816         ),
1817         arggoal_cases(Rest,Arg,L,T,RCases).
1818 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1819
1820 generate_extra_clauses(Constraints,List) :-
1821         generate_activate_clauses(Constraints,List,Tail0),
1822         generate_remove_clauses(Constraints,Tail0,Tail1),
1823         generate_allocate_clauses(Constraints,Tail1,Tail2),
1824         generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
1825         generate_novel_production(Tail3,Tail4),
1826         generate_extend_history(Tail4,Tail5),
1827         generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
1828         Tail6 = [].
1829
1830 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1831 % remove_constraint_internal/[1/3]
1832
1833 generate_remove_clauses([],List,List).
1834 generate_remove_clauses([C|Cs],List,Tail) :-
1835         generate_remove_clause(C,List,List1),
1836         generate_remove_clauses(Cs,List1,Tail).
1837
1838 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :-
1839         uses_state(Constraint,removed),
1840         ( chr_pp_flag(inline_insertremove,off) ->
1841                 use_auxiliary_predicate(remove_constraint_internal,Constraint),
1842                 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
1843                 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
1844         ;
1845                 delay_phase_end(validate_store_type_assumptions,
1846                         generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal)
1847                 )
1848         ).
1849
1850 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
1851         make_name('$remove_constraint_internal_',Constraint,Name),
1852         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1853                 Goal =.. [Name, Susp,Delete]
1854         ;
1855                 Goal =.. [Name,Susp,Agenda,Delete]
1856         ).
1857
1858 generate_remove_clause(Constraint,List,Tail) :-
1859         ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
1860                 List = [RemoveClause|Tail],
1861                 RemoveClause = (Head :- RemoveBody),
1862                 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
1863                 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody)
1864         ;
1865                 List = Tail
1866         ).
1867
1868 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :-
1869         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1870                 ( Role == active ->
1871                         get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
1872                         if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1873                         if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete)
1874                 ; Role == partner ->
1875                         get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState),
1876                         GetStateValue = true,
1877                         MaybeDelete = DeleteYes
1878                 ),
1879                 RemoveBody =
1880                 (
1881                         GetState,
1882                         GetStateValue,
1883                         UpdateState,
1884                         MaybeDelete
1885                 )
1886         ;
1887                 static_suspension_term(Constraint,Susp2),
1888                 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
1889                 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
1890                 ( chr_pp_flag(debugable,on) ->
1891                         Constraint = Functor / _,
1892                         get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
1893                 ;
1894                         true
1895                 ),
1896                 ( Role == active ->
1897                         get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
1898                         if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1899                         if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete)
1900                 ; Role == partner ->
1901                         get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState),
1902                         GetStateValue = true,
1903                         MaybeDelete = (IndexedVariablesBody, DeleteYes)
1904                 ),
1905                 RemoveBody =
1906                 (
1907                         Susp = Susp2,
1908                         GetStateValue,
1909                         UpdateState,
1910                         MaybeDelete
1911                 )
1912         ).
1913
1914 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1915 % activate_constraint/4
1916
1917 generate_activate_clauses([],List,List).
1918 generate_activate_clauses([C|Cs],List,Tail) :-
1919         generate_activate_clause(C,List,List1),
1920         generate_activate_clauses(Cs,List1,Tail).
1921
1922 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
1923         ( chr_pp_flag(inline_insertremove,off) ->
1924                 use_auxiliary_predicate(activate_constraint,Constraint),
1925                 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
1926                 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
1927         ;
1928                 delay_phase_end(validate_store_type_assumptions,
1929                         activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
1930                 )
1931         ).
1932
1933 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
1934         make_name('$activate_constraint_',Constraint,Name),
1935         ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1936                 Goal =.. [Name,Store, Susp]
1937         ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1938                 Goal =.. [Name,Store, Susp, Generation]
1939         ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1940                 Goal =.. [Name,Store, Vars, Susp, Generation]
1941         ;
1942                 Goal =.. [Name,Store, Vars, Susp]
1943         ).
1944
1945 generate_activate_clause(Constraint,List,Tail) :-
1946         ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
1947                 List = [Clause|Tail],
1948                 Clause = (Head :- Body),
1949                 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
1950                 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
1951         ;
1952                 List = Tail
1953         ).
1954
1955 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
1956         ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
1957                 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
1958                 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
1959         ;
1960                 GenerationHandling = true
1961         ),
1962         get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
1963         if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1964         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1965                 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
1966         ;
1967                 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
1968                 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
1969                 ( chr_pp_flag(guard_locks,off) ->
1970                         NoneLocked = true
1971                 ;
1972                         NoneLocked = 'chr none_locked'( Vars)
1973                 ),
1974                 if_used_state(Constraint,not_stored_yet,
1975                                           ( State == not_stored_yet ->
1976                                                   ArgumentsGoal,
1977                                                     IndexedVariablesBody,
1978                                                     NoneLocked,
1979                                                     StoreYes
1980                                                 ;
1981                                                     % Vars = [],
1982                                                     StoreNo
1983                                                 ),
1984                                 % (Vars = [],StoreNo),StoreVarsGoal)
1985                                 StoreNo,StoreVarsGoal)
1986         ),
1987         Body =
1988         (
1989                 GetState,
1990                 GetStateValue,
1991                 UpdateState,
1992                 GenerationHandling,
1993                 StoreVarsGoal
1994         ).
1995 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1996 % allocate_constraint/4
1997
1998 generate_allocate_clauses([],List,List).
1999 generate_allocate_clauses([C|Cs],List,Tail) :-
2000         generate_allocate_clause(C,List,List1),
2001         generate_allocate_clauses(Cs,List1,Tail).
2002
2003 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
2004         uses_state(Constraint,not_stored_yet),
2005         ( chr_pp_flag(inline_insertremove,off) ->
2006                 use_auxiliary_predicate(allocate_constraint,Constraint),
2007                 allocate_constraint_atom(Constraint,Susp,Args,Goal)
2008         ;
2009                 Goal = (Susp = Suspension, Goal0),
2010                 delay_phase_end(validate_store_type_assumptions,
2011                         allocate_constraint_body(Constraint,Suspension,Args,Goal0)
2012                 )
2013         ).
2014
2015 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
2016         make_name('$allocate_constraint_',Constraint,Name),
2017         Goal =.. [Name,Susp|Args].
2018
2019 generate_allocate_clause(Constraint,List,Tail) :-
2020         ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
2021                 List = [Clause|Tail],
2022                 Clause = (Head :- Body),
2023                 Constraint = _/A,
2024                 length(Args,A),
2025                 allocate_constraint_atom(Constraint,Susp,Args,Head),
2026                 allocate_constraint_body(Constraint,Susp,Args,Body)
2027         ;
2028                 List = Tail
2029         ).
2030
2031 allocate_constraint_body(Constraint,Susp,Args,Body) :-
2032         static_suspension_term(Constraint,Suspension),
2033         get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2034         ( chr_pp_flag(debugable,on) ->
2035                 Constraint = Functor / _,
2036                 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2037         ;
2038                 true
2039         ),
2040         ( chr_pp_flag(debugable,on) ->
2041                 ( may_trigger(Constraint) ->
2042                         append(Args,[Susp],VarsSusp),
2043                         build_head(F,A,[0],VarsSusp, ContinuationGoal),
2044                         get_target_module(Mod),
2045                         Continuation = Mod : ContinuationGoal
2046                 ;
2047                         Continuation = true
2048                 ),
2049                 Init = (Susp = Suspension),
2050                 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
2051                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2052         ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2053                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
2054                 Susp = Suspension, Init = true, CreateContinuation = true
2055         ;
2056                 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
2057         ),
2058         ( uses_history(Constraint) ->
2059                 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2060         ;
2061                 CreateHistory = true
2062         ),
2063         create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
2064         ( has_suspension_field(Constraint,id) ->
2065                 get_static_suspension_term_field(id,Constraint,Suspension,Id),
2066                 GenID = 'chr gen_id'(Id)
2067         ;
2068                 GenID = true
2069         ),
2070         Body =
2071         (
2072                 Init,
2073                 CreateContinuation,
2074                 CreateGeneration,
2075                 CreateHistory,
2076                 CreateState,
2077                 GenID
2078         ).
2079
2080 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2081 % insert_constraint_internal
2082
2083 generate_insert_constraint_internal_clauses([],List,List).
2084 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
2085         generate_insert_constraint_internal_clause(C,List,List1),
2086         generate_insert_constraint_internal_clauses(Cs,List1,Tail).
2087
2088 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
2089         ( chr_pp_flag(inline_insertremove,off) ->
2090                 use_auxiliary_predicate(remove_constraint_internal,Constraint),
2091                 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
2092         ;
2093                 delay_phase_end(validate_store_type_assumptions,
2094                         generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
2095                 )
2096         ).
2097
2098
2099 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
2100         insert_constraint_internal_constraint_name(Constraint,Name),
2101         ( chr_pp_flag(debugable,on) ->
2102                 Goal =.. [Name, Vars, Self, Closure | Args]
2103         ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2104                 Goal =.. [Name,Self | Args]
2105         ;
2106                 Goal =.. [Name,Vars, Self | Args]
2107         ).
2108
2109 insert_constraint_internal_constraint_name(Constraint,Name) :-
2110         make_name('$insert_constraint_internal_',Constraint,Name).
2111
2112 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
2113         ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
2114                 List = [Clause|Tail],
2115                 Clause = (Head :- Body),
2116                 Constraint = _/A,
2117                 length(Args,A),
2118                 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
2119                 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
2120         ;
2121                 List = Tail
2122         ).
2123
2124
2125 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
2126         static_suspension_term(Constraint,Suspension),
2127         create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
2128         ( chr_pp_flag(debugable,on) ->
2129                 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
2130                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2131         ; may_trigger(Constraint), uses_field(Constraint,generation) ->
2132                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
2133         ;
2134                 CreateGeneration = true
2135         ),
2136         ( chr_pp_flag(debugable,on) ->
2137                 Constraint = Functor / _,
2138                 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
2139         ;
2140                 true
2141         ),
2142         ( uses_history(Constraint) ->
2143                 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
2144         ;
2145                 CreateHistory = true
2146         ),
2147         get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
2148         List = [Clause|Tail],
2149         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
2150                 suspension_term_base_fields(Constraint,BaseFields),
2151                 ( has_suspension_field(Constraint,id) ->
2152                         get_static_suspension_term_field(id,Constraint,Suspension,Id),
2153                         GenID = 'chr gen_id'(Id)
2154                 ;
2155                         GenID = true
2156                 ),
2157                 Body =
2158                     (
2159                         Susp = Suspension,
2160                         CreateState,
2161                         CreateGeneration,
2162                         CreateHistory,
2163                         GenID
2164                     )
2165         ;
2166                 ( has_suspension_field(Constraint,id) ->
2167                         get_static_suspension_term_field(id,Constraint,Suspension,Id),
2168                         GenID = 'chr gen_id'(Id)
2169                 ;
2170                         GenID = true
2171                 ),
2172                 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
2173                 ( chr_pp_flag(guard_locks,off) ->
2174                         NoneLocked = true
2175                 ;
2176                         NoneLocked = 'chr none_locked'( Vars)
2177                 ),
2178                 Body =
2179                 (
2180                         Susp = Suspension,
2181                         IndexedVariablesBody,
2182                         NoneLocked,
2183                         CreateState,
2184                         CreateGeneration,
2185                         CreateHistory,
2186                         GenID
2187                 )
2188         ).
2189
2190 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2191 % novel_production/2
2192
2193 generate_novel_production(List,Tail) :-
2194         ( is_used_auxiliary_predicate(novel_production) ->
2195                 List = [Clause|Tail],
2196                 Clause =
2197                 (
2198                         '$novel_production'( Self, Tuple) :-
2199                                 % arg( 3, Self, Ref), % ARGXXX
2200                                 % 'chr get_mutable'( History, Ref),
2201                                 arg( 3, Self, History), % ARGXXX
2202                                 ( hprolog:get_ds( Tuple, History, _) ->
2203                                         fail
2204                                 ;
2205                                         true
2206                                 )
2207                 )
2208         ;
2209                 List = Tail
2210         ).
2211
2212 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2213 % extend_history/2
2214
2215 generate_extend_history(List,Tail) :-
2216         ( is_used_auxiliary_predicate(extend_history) ->
2217                 List = [Clause|Tail],
2218                 Clause =
2219                 (
2220                         '$extend_history'( Self, Tuple) :-
2221                                 % arg( 3, Self, Ref), % ARGXXX
2222                                 % 'chr get_mutable'( History, Ref),
2223                                 arg( 3, Self, History), % ARGXXX
2224                                 hprolog:put_ds( Tuple, History, x, NewHistory),
2225                                 setarg( 3, Self, NewHistory) % ARGXXX
2226                 )
2227         ;
2228                 List = Tail
2229         ).
2230
2231 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2232 % run_suspensions/2
2233
2234 generate_run_suspensions_clauses([],List,List).
2235 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
2236         generate_run_suspensions_clause(C,List,List1),
2237         generate_run_suspensions_clauses(Cs,List1,Tail).
2238
2239 run_suspensions_goal(Constraint,Suspensions,Goal) :-
2240         make_name('$run_suspensions_',Constraint,Name),
2241         Goal =.. [Name,Suspensions].
2242
2243 generate_run_suspensions_clause(Constraint,List,Tail) :-
2244         ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
2245                 List = [Clause1,Clause2|Tail],
2246                 run_suspensions_goal(Constraint,[],Clause1),
2247                 ( chr_pp_flag(debugable,on) ->
2248                         run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2249                         get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
2250                         get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
2251                         get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
2252                         get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
2253                         run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2254                         Clause2 =
2255                         (
2256                                 Clause2Head :-
2257                                         GetState,
2258                                         GetStateValue,
2259                                         ( State==active ->
2260                                             UpdateState,
2261                                             GetGeneration,
2262                                             GetGenerationValue,
2263                                             Generation is Gen+1,
2264                                             UpdateGeneration,
2265                                             GetContinuation,
2266                                             (
2267                                                 'chr debug_event'(wake(Suspension)),
2268                                                 call(Continuation)
2269                                             ;
2270                                                 'chr debug_event'(fail(Suspension)), !,
2271                                                 fail
2272                                             ),
2273                                             (
2274                                                 'chr debug_event'(exit(Suspension))
2275                                             ;
2276                                                 'chr debug_event'(redo(Suspension)),
2277                                                 fail
2278                                             ),
2279                                             GetPost,
2280                                             GetPostValue,
2281                                             ( Post==triggered ->
2282                                                 UpdatePost   % catching constraints that did not do anything
2283                                             ;
2284                                                 true
2285                                             )
2286                                         ;
2287                                             true
2288                                         ),
2289                                         Clause2Recursion
2290                         )
2291                 ;
2292                         run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
2293                         static_suspension_term(Constraint,SuspensionTerm),
2294                         get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
2295                         append(Arguments,[Suspension],VarsSusp),
2296                         make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
2297                         run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
2298                         ( uses_field(Constraint,generation) ->
2299                                 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
2300                                 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
2301                         ;
2302                                 GenerationHandling = true
2303                         ),
2304                         get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
2305                         get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
2306                         if_used_state(Constraint,removed,
2307                                 ( GetState,
2308                                         ( State==active
2309                                         -> ReactivateConstraint
2310                                         ;  true)
2311                                 ),ReactivateConstraint,CondReactivate),
2312                         ReactivateConstraint =
2313                         (
2314                                 UpdateState,
2315                                 GenerationHandling,
2316                                 Continuation,
2317                                 GetPostState,
2318                                 ( Post==triggered ->
2319                                     UpdatePostState     % catching constraints that did not do anything
2320                                 ;
2321                                     true
2322                                 )
2323                         ),
2324                         Clause2 =
2325                         (
2326                                 Clause2Head :-
2327                                         Suspension = SuspensionTerm,
2328                                         CondReactivate,
2329                                         Clause2Recursion
2330                         )
2331                 )
2332         ;
2333                 List = Tail
2334         ).
2335
2336 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
2337
2338 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2339 generate_attach_increment(Clauses) :-
2340         get_max_constraint_index(N),
2341         ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2342                 Clauses = [Clause1,Clause2],
2343                 generate_attach_increment_empty(Clause1),
2344                 ( N == 1 ->
2345                         generate_attach_increment_one(Clause2)
2346                 ;
2347                         generate_attach_increment_many(N,Clause2)
2348                 )
2349         ;
2350                 Clauses = []
2351         ).
2352
2353 generate_attach_increment_empty((attach_increment([],_) :- true)).
2354
2355 generate_attach_increment_one(Clause) :-
2356         Head = attach_increment([Var|Vars],Susps),
2357         get_target_module(Mod),
2358         ( chr_pp_flag(guard_locks,off) ->
2359                 NotLocked = true
2360         ;
2361                 NotLocked = 'chr not_locked'( Var)
2362         ),
2363         Body =
2364         (
2365                 NotLocked,
2366                 ( get_attr(Var,Mod,VarSusps) ->
2367                         sort(VarSusps,SortedVarSusps),
2368                         'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2369                         put_attr(Var,Mod,MergedSusps)
2370                 ;
2371                         put_attr(Var,Mod,Susps)
2372                 ),
2373                 attach_increment(Vars,Susps)
2374         ),
2375         Clause = (Head :- Body).
2376
2377 generate_attach_increment_many(N,Clause) :-
2378         make_attr(N,Mask,SuspsList,Attr),
2379         make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2380         Head = attach_increment([Var|Vars],Attr),
2381         bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
2382         list2conj(Gs,SortGoals),
2383         bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
2384         make_attr(N,MergedMask,MergedSuspsList,NewAttr),
2385         get_target_module(Mod),
2386         ( chr_pp_flag(guard_locks,off) ->
2387                 NotLocked = true
2388         ;
2389                 NotLocked = 'chr not_locked'( Var)
2390         ),
2391         Body =
2392         (
2393                 NotLocked,
2394                 ( get_attr(Var,Mod,TOtherAttr) ->
2395                         TOtherAttr = OtherAttr,
2396                         SortGoals,
2397                         MergedMask is Mask \/ OtherMask,
2398                         put_attr(Var,Mod,NewAttr)
2399                 ;
2400                         put_attr(Var,Mod,Attr)
2401                 ),
2402                 attach_increment(Vars,Attr)
2403         ),
2404         Clause = (Head :- Body).
2405
2406 %%      attr_unify_hook
2407 generate_attr_unify_hook(Clauses) :-
2408         get_max_constraint_index(N),
2409         ( N == 0 ->
2410                 Clauses = []
2411         ;
2412                 Clauses = [Clause],
2413                 ( N == 1 ->
2414                         generate_attr_unify_hook_one(Clause)
2415                 ;
2416                         generate_attr_unify_hook_many(N,Clause)
2417                 )
2418         ).
2419
2420 generate_attr_unify_hook_one(Clause) :-
2421         Head = attr_unify_hook(Susps,Other),
2422         get_target_module(Mod),
2423         get_indexed_constraint(1,C),
2424         ( get_store_type(C,default) ->
2425                 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2426                 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2427                 ( atomic_types_suspended_constraint(C) ->
2428                         SortGoal1   = true,
2429                         SortedSusps = Susps,
2430                         SortGoal2   = true,
2431                         SortedOtherSusps = OtherSusps,
2432                         MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2433                         NonvarBody = true
2434                 ;
2435                         SortGoal1 = sort(Susps, SortedSusps),
2436                         SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2437                         MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2438                         use_auxiliary_predicate(attach_increment),
2439                         NonvarBody =
2440                                 ( compound(Other) ->
2441                                         term_variables(Other,OtherVars),
2442                                         attach_increment(OtherVars, SortedSusps)
2443                                 ;
2444                                         true
2445                                 )
2446                 ),
2447                 Body =
2448                 (
2449                         SortGoal1,
2450                         ( var(Other) ->
2451                                 ( get_attr(Other,Mod,OtherSusps) ->
2452                                         SortGoal2,
2453                                         MergeGoal,
2454                                         put_attr(Other,Mod,NewSusps),
2455                                         WakeNewSusps
2456                                 ;
2457                                         put_attr(Other,Mod,SortedSusps),
2458                                         WakeSusps
2459                                 )
2460                         ;
2461                                 NonvarBody,
2462                                 WakeSusps
2463                         )
2464                 ),
2465                 Clause = (Head :- Body)
2466         ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2467                 make_run_suspensions(List,List,WakeNewSusps),
2468                 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2469                 Body =
2470                         ( get_attr(Other,Mod,OtherSusps) ->
2471                                 MergeGoal,
2472                                 WakeNewSusps
2473                         ;
2474                                 put_attr(Other,Mod,Susps)
2475                         ),
2476                 Clause = (Head :- Body)
2477         ).
2478
2479
2480 generate_attr_unify_hook_many(N,Clause) :-
2481         make_attr(N,Mask,SuspsList,Attr),
2482         make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2483         bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2484         list2conj(SortGoalList,SortGoals),
2485         bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2486         bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
2487                                   C = (sort(E,F),
2488                                        'chr merge_attributes'(D,F,G)) ),
2489               SortMergeGoalList),
2490         bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
2491         list2conj(SortMergeGoalList,SortMergeGoals),
2492         make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
2493         make_attr(N,Mask,SortedSuspsList,SortedAttr),
2494         Head = attr_unify_hook(Attr,Other),
2495         get_target_module(Mod),
2496         make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2497         make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2498         ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2499                 NonvarBody = true
2500         ;
2501                 use_auxiliary_predicate(attach_increment),
2502                 NonvarBody =
2503                         ( compound(Other) ->
2504                                 term_variables(Other,OtherVars),
2505                                 attach_increment(OtherVars,SortedAttr)
2506                         ;
2507                                 true
2508                         )
2509         ),
2510         Body =
2511         (
2512                 SortGoals,
2513                 ( var(Other) ->
2514                         ( get_attr(Other,Mod,TOtherAttr) ->
2515                                 TOtherAttr = OtherAttr,
2516                                 SortMergeGoals,
2517                                 MergedMask is Mask \/ OtherMask,
2518                                 put_attr(Other,Mod,MergedAttr),
2519                                 WakeMergedSusps
2520                         ;
2521                                 put_attr(Other,Mod,SortedAttr),
2522                                 WakeSortedSusps
2523                         )
2524                 ;
2525                         NonvarBody,
2526                         WakeSortedSusps
2527                 )
2528         ),
2529         Clause = (Head :- Body).
2530
2531 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2532         make_run_suspensions(1,AllSusps,OneSusps,Goal).
2533
2534 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2535         ( get_indexed_constraint(Index,C), may_trigger(C) ->
2536                 use_auxiliary_predicate(run_suspensions,C),
2537                 ( wakes_partially(C) ->
2538                         run_suspensions_goal(C,OneSusps,Goal)
2539                 ;
2540                         run_suspensions_goal(C,AllSusps,Goal)
2541                 )
2542         ;
2543                 Goal = true
2544         ).
2545
2546 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2547         make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2548
2549 make_run_suspensions_loop([],[],_,true).
2550 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2551         make_run_suspensions(I,AllSusps,OneSusps,Goal),
2552         J is I + 1,
2553         make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2554
2555 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2556 % $insert_in_store_F/A
2557 % $delete_from_store_F/A
2558
2559 generate_insert_delete_constraints([],[]).
2560 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2561         ( is_stored(FA) ->
2562                 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2563         ;
2564                 Clauses = RestClauses
2565         ),
2566         generate_insert_delete_constraints(Rest,RestClauses).
2567
2568 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2569         insert_constraint_clause(FA,Clauses,RestClauses1),
2570         delete_constraint_clause(FA,RestClauses1,RestClauses).
2571
2572 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2573 % insert_in_store
2574
2575 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2576         ( chr_pp_flag(inline_insertremove,off) ->
2577                 use_auxiliary_predicate(insert_in_store,FA),
2578                 insert_constraint_atom(FA,Susp,Goal)
2579         ;
2580                 delay_phase_end(validate_store_type_assumptions,
2581                         ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2582                           insert_constraint_direct_used_vars(UsedVars,Vars)
2583                         )
2584                 )
2585         ).
2586
2587 insert_constraint_direct_used_vars([],_).
2588 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2589         nth1(Index,Vars,Var),
2590         insert_constraint_direct_used_vars(Rest,Vars).
2591
2592 insert_constraint_atom(FA,Susp,Call) :-
2593         make_name('$insert_in_store_',FA,Functor),
2594         Call =.. [Functor,Susp].
2595
2596 insert_constraint_clause(C,Clauses,RestClauses) :-
2597         ( is_used_auxiliary_predicate(insert_in_store,C) ->
2598                 Clauses = [Clause|RestClauses],
2599                 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2600                 insert_constraint_atom(C,Susp,Head),
2601                 insert_constraint_body(C,Susp,UsedVars,Body),
2602                 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2603                 ( chr_pp_flag(store_counter,on) ->
2604                         InsertCounterInc = '$insert_counter_inc'
2605                 ;
2606                         InsertCounterInc = true
2607                 )
2608         ;
2609                 Clauses = RestClauses
2610         ).
2611
2612 insert_constraint_used_vars([],_,_,true).
2613 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2614         get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2615         insert_constraint_used_vars(Rest,C,Susp,Goals).
2616
2617 insert_constraint_body(C,Susp,UsedVars,Body) :-
2618         get_store_type(C,StoreType),
2619         insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2620
2621 insert_constraint_body(default,C,Susp,[],Body) :-
2622         global_list_store_name(C,StoreName),
2623         make_get_store_goal(StoreName,Store,GetStoreGoal),
2624         make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2625         ( chr_pp_flag(debugable,on) ->
2626                 Cell = [Susp|Store],
2627                 Body =
2628                 (
2629                         GetStoreGoal,
2630                         UpdateStoreGoal
2631                 )
2632         ;
2633                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2634                 Body =
2635                 (
2636                         GetStoreGoal,
2637                         Cell = [Susp|Store],
2638                         UpdateStoreGoal,
2639                         ( Store = [NextSusp|_] ->
2640                                 SetGoal
2641                         ;
2642                                 true
2643                         )
2644                 )
2645         ).
2646 %       get_target_module(Mod),
2647 %       get_max_constraint_index(Total),
2648 %       ( Total == 1 ->
2649 %               generate_attach_body_1(C,Store,Susp,AttachBody)
2650 %       ;
2651 %               generate_attach_body_n(C,Store,Susp,AttachBody)
2652 %       ),
2653 %       Body =
2654 %       (
2655 %               'chr default_store'(Store),
2656 %               AttachBody
2657 %       ).
2658 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2659         generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2660 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2661         generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2662         sort_out_used_vars(MixedUsedVars,UsedVars).
2663 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2664         global_ground_store_name(C,StoreName),
2665         make_get_store_goal(StoreName,Store,GetStoreGoal),
2666         make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2667         ( chr_pp_flag(debugable,on) ->
2668                 Cell = [Susp|Store],
2669                 Body =
2670                 (
2671                         GetStoreGoal,
2672                         UpdateStoreGoal
2673                 )
2674         ;
2675                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2676                 Body =
2677                 (
2678                         GetStoreGoal,
2679                         Cell = [Susp|Store],
2680                         UpdateStoreGoal,
2681                         ( Store = [NextSusp|_] ->
2682                                 SetGoal
2683                         ;
2684                                 true
2685                         )
2686                 )
2687         ).
2688 %       global_ground_store_name(C,StoreName),
2689 %       make_get_store_goal(StoreName,Store,GetStoreGoal),
2690 %       make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
2691 %       Body =
2692 %       (
2693 %               GetStoreGoal,    % nb_getval(StoreName,Store),
2694 %               UpdateStoreGoal  % b_setval(StoreName,[Susp|Store])
2695 %       ).
2696 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
2697         % TODO: generalize to more than one !!!
2698         get_target_module(Module),
2699         Body = ( get_attr(Variable,Module,AssocStore) ->
2700                         insert_assoc_store(AssocStore,Key,Susp)
2701                 ;
2702                         new_assoc_store(AssocStore),
2703                         put_attr(Variable,Module,AssocStore),
2704                         insert_assoc_store(AssocStore,Key,Susp)
2705                 ).
2706
2707 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
2708         global_singleton_store_name(C,StoreName),
2709         make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
2710         Body =
2711         (
2712                 UpdateStoreGoal
2713         ).
2714 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
2715         find_with_var_identity(
2716                 B-UV,
2717                 [Susp],
2718                 (
2719                         member(ST,StoreTypes),
2720                         chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
2721                 ),
2722                 BodiesUsedVars
2723                 ),
2724         once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
2725         list2conj(Bodies,Body),
2726         sort_out_used_vars(NestedUsedVars,UsedVars).
2727 insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :-
2728         UsedVars = [Index-Var],
2729         get_identifier_size(ISize),
2730         functor(Struct,struct,ISize),
2731         get_identifier_index(C,Index,IIndex),
2732         arg(IIndex,Struct,Susps),
2733         Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
2734 insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :-
2735         UsedVars = [Index-Var],
2736         type_indexed_identifier_structure(IndexType,Struct),
2737         get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
2738         arg(IIndex,Struct,Susps),
2739         Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])).
2740
2741 sort_out_used_vars(NestedUsedVars,UsedVars) :-
2742         flatten(NestedUsedVars,FlatUsedVars),
2743         sort(FlatUsedVars,SortedFlatUsedVars),
2744         sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
2745
2746 sort_out_used_vars1([],[]).
2747 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
2748 sort_out_used_vars1([I-X,J-Y|R],L) :-
2749         ( I == J ->
2750                 X = Y,
2751                 sort_out_used_vars1([I-X|R],L)
2752         ;
2753                 L = [I-X|T],
2754                 sort_out_used_vars1([J-Y|R],T)
2755         ).
2756
2757 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
2758 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2759         multi_hash_store_name(FA,Index,StoreName),
2760         multi_hash_key(FA,Index,Susp,KeyBody,Key),
2761         Body =
2762         (
2763                 KeyBody,
2764                 nb_getval(StoreName,Store),
2765                 insert_iht(Store,Key,Susp)
2766         ),
2767         generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
2768
2769 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
2770 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
2771         multi_hash_store_name(FA,Index,StoreName),
2772         multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
2773         make_get_store_goal(StoreName,Store,GetStoreGoal),
2774         Body =
2775         (
2776                 GetStoreGoal,
2777                 insert_ht(Store,Key,Susp)
2778         ),
2779         generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
2780
2781 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2782 % Delete
2783
2784 delete_constraint_clause(C,Clauses,RestClauses) :-
2785         ( is_used_auxiliary_predicate(delete_from_store,C) ->
2786                 Clauses = [Clause|RestClauses],
2787                 Clause = (Head :- Body),
2788                 delete_constraint_atom(C,Susp,Head),
2789                 C = F/A,
2790                 functor(Head,F,A),
2791                 delete_constraint_body(C,Head,Susp,[],Body)
2792         ;
2793                 Clauses = RestClauses
2794         ).
2795
2796 delete_constraint_goal(Head,Susp,VarDict,Goal) :-
2797         functor(Head,F,A),
2798         C = F/A,
2799         ( chr_pp_flag(inline_insertremove,off) ->
2800                 use_auxiliary_predicate(delete_from_store,C),
2801                 delete_constraint_atom(C,Susp,Goal)
2802         ;
2803                 delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal))
2804         ).
2805
2806 delete_constraint_atom(C,Susp,Atom) :-
2807         make_name('$delete_from_store_',C,Functor),
2808         Atom =.. [Functor,Susp].
2809
2810
2811 delete_constraint_body(C,Head,Susp,VarDict,Body) :-
2812         Body = (CounterBody,DeleteBody),
2813         ( chr_pp_flag(store_counter,on) ->
2814                 CounterBody = '$delete_counter_inc'
2815         ;
2816                 CounterBody = true
2817         ),
2818         get_store_type(C,StoreType),
2819         delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody).
2820
2821 delete_constraint_body(default,C,_,Susp,_,Body) :-
2822         ( chr_pp_flag(debugable,on) ->
2823                 global_list_store_name(C,StoreName),
2824                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2825                 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2826                 Body =
2827                 (
2828                         GetStoreGoal, % nb_getval(StoreName,Store),
2829                         'chr sbag_del_element'(Store,Susp,NStore),
2830                         UpdateStoreGoal % b_setval(StoreName,NStore)
2831                 )
2832         ;
2833                 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2834                 global_list_store_name(C,StoreName),
2835                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2836                 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2837                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2838                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2839                 Body =
2840                 (
2841                         GetGoal,
2842                         ( var(PredCell) ->
2843                                 GetStoreGoal, % nb_getval(StoreName,Store),
2844                                 Store = [_|Tail],
2845                                 UpdateStoreGoal,
2846                                 ( Tail = [NextSusp|_] ->
2847                                         SetGoal1
2848                                 ;
2849                                         true
2850                                 )
2851                         ;
2852                                 PredCell = [_,_|Tail],
2853                                 setarg(2,PredCell,Tail),
2854                                 ( Tail = [NextSusp|_] ->
2855                                         SetGoal2
2856                                 ;
2857                                         true
2858                                 )
2859                         )
2860                 )
2861         ).
2862 %       get_target_module(Mod),
2863 %       get_max_constraint_index(Total),
2864 %       ( Total == 1 ->
2865 %               generate_detach_body_1(C,Store,Susp,DetachBody),
2866 %               Body =
2867 %               (
2868 %                       'chr default_store'(Store),
2869 %                       DetachBody
2870 %               )
2871 %       ;
2872 %               generate_detach_body_n(C,Store,Susp,DetachBody),
2873 %               Body =
2874 %               (
2875 %                       'chr default_store'(Store),
2876 %                       DetachBody
2877 %               )
2878 %       ).
2879 delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :-
2880         generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
2881 delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :-
2882         generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body).
2883 delete_constraint_body(global_ground,C,_,Susp,_,Body) :-
2884         ( chr_pp_flag(debugable,on) ->
2885                 global_ground_store_name(C,StoreName),
2886                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2887                 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2888                 Body =
2889                 (
2890                         GetStoreGoal, % nb_getval(StoreName,Store),
2891                         'chr sbag_del_element'(Store,Susp,NStore),
2892                         UpdateStoreGoal % b_setval(StoreName,NStore)
2893                 )
2894         ;
2895                 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2896                 global_ground_store_name(C,StoreName),
2897                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2898                 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2899                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2900                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2901                 Body =
2902                 (
2903                         GetGoal,
2904                         ( var(PredCell) ->
2905                                 GetStoreGoal, % nb_getval(StoreName,Store),
2906                                 Store = [_|Tail],
2907                                 UpdateStoreGoal,
2908                                 ( Tail = [NextSusp|_] ->
2909                                         SetGoal1
2910                                 ;
2911                                         true
2912                                 )
2913                         ;
2914                                 PredCell = [_,_|Tail],
2915                                 setarg(2,PredCell,Tail),
2916                                 ( Tail = [NextSusp|_] ->
2917                                         SetGoal2
2918                                 ;
2919                                         true
2920                                 )
2921                         )
2922                 )
2923         ).
2924 %       global_ground_store_name(C,StoreName),
2925 %       make_get_store_goal(StoreName,Store,GetStoreGoal),
2926 %       make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2927 %       Body =
2928 %       (
2929 %               GetStoreGoal, % nb_getval(StoreName,Store),
2930 %               'chr sbag_del_element'(Store,Susp,NStore),
2931 %               UpdateStoreGoal % b_setval(StoreName,NStore)
2932 %       ).
2933 delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :-
2934         get_target_module(Module),
2935         get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
2936         get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
2937         Body = (
2938                 VariableGoal,
2939                 get_attr(Variable,Module,AssocStore),
2940                 KeyGoal,
2941                 delete_assoc_store(AssocStore,Key,Susp)
2942         ).
2943 delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :-
2944         global_singleton_store_name(C,StoreName),
2945         make_update_store_goal(StoreName,[],UpdateStoreGoal),
2946         Body =
2947         (
2948                 UpdateStoreGoal  % b_setval(StoreName,[])
2949         ).
2950 delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :-
2951         find_with_var_identity(
2952                 B,
2953                 [Susp/VarDict/Head],
2954                 (
2955                         member(ST,StoreTypes),
2956                         chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B)
2957                 ),
2958                 Bodies
2959         ),
2960         list2conj(Bodies,Body).
2961 delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :-
2962         get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
2963         get_identifier_size(ISize),
2964         functor(Struct,struct,ISize),
2965         get_identifier_index(C,Index,IIndex),
2966         arg(IIndex,Struct,Susps),
2967         Body = (
2968                 VariableGoal,
2969                 Variable = Struct,
2970                 'chr sbag_del_element'(Susps,Susp,NSusps),
2971                 setarg(IIndex,Variable,NSusps)
2972         ).
2973 delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :-
2974         get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal),
2975         type_indexed_identifier_structure(IndexType,Struct),
2976         get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
2977         arg(IIndex,Struct,Susps),
2978         Body = (
2979                 VariableGoal,
2980                 Variable = Struct,
2981                 'chr sbag_del_element'(Susps,Susp,NSusps),
2982                 setarg(IIndex,Variable,NSusps)
2983         ).
2984
2985 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
2986 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2987         multi_hash_store_name(FA,Index,StoreName),
2988         multi_hash_key(FA,Index,Susp,KeyBody,Key),
2989         Body =
2990         (
2991                 KeyBody,
2992                 nb_getval(StoreName,Store),
2993                 delete_iht(Store,Key,Susp)
2994         ),
2995         generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2996 generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true).
2997 generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :-
2998         multi_hash_store_name(C,Index,StoreName),
2999         multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key),
3000         make_get_store_goal(StoreName,Store,GetStoreGoal),
3001         Body =
3002         (
3003                 KeyBody,
3004                 GetStoreGoal, % nb_getval(StoreName,Store),
3005                 delete_ht(Store,Key,Susp)
3006         ),
3007         generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies).
3008
3009 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3010
3011 :- chr_constraint
3012         module_initializer/1,
3013         module_initializers/1.
3014
3015 module_initializers(G), module_initializer(Initializer) <=>
3016         G = (Initializer,Initializers),
3017         module_initializers(Initializers).
3018
3019 module_initializers(G) <=>
3020         G = true.
3021
3022 generate_attach_code(Constraints,[Enumerate|L]) :-
3023         enumerate_stores_code(Constraints,Enumerate),
3024         generate_attach_code(Constraints,L,T),
3025         module_initializers(Initializers),
3026         prolog_global_variables_code(PrologGlobalVariables),
3027         T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables].
3028
3029 generate_attach_code([],L,L).
3030 generate_attach_code([C|Cs],L,T) :-
3031         get_store_type(C,StoreType),
3032         generate_attach_code(StoreType,C,L,L1),
3033         generate_attach_code(Cs,L1,T).
3034
3035 generate_attach_code(default,C,L,T) :-
3036         global_list_store_initialisation(C,L,T).
3037 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
3038         multi_inthash_store_initialisations(Indexes,C,L,L1),
3039         multi_inthash_via_lookups(Indexes,C,L1,T).
3040 generate_attach_code(multi_hash(Indexes),C,L,T) :-
3041         multi_hash_store_initialisations(Indexes,C,L,L1),
3042         multi_hash_via_lookups(Indexes,C,L1,T).
3043 generate_attach_code(global_ground,C,L,T) :-
3044         global_ground_store_initialisation(C,L,T).
3045 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
3046         use_auxiliary_module(chr_assoc_store).
3047 generate_attach_code(global_singleton,C,L,T) :-
3048         global_singleton_store_initialisation(C,L,T).
3049 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
3050         multi_store_generate_attach_code(StoreTypes,C,L,T).
3051 generate_attach_code(identifier_store(Index),C,L,T) :-
3052         get_identifier_index(C,Index,IIndex),
3053         ( IIndex == 2 ->
3054                 get_identifier_size(ISize),
3055                 functor(Struct,struct,ISize),
3056                 Struct =.. [_,Label|Stores],
3057                 set_elems(Stores,[]),
3058                 Clause1 = new_identifier(Label,Struct),
3059                 functor(Struct2,struct,ISize),
3060                 arg(1,Struct2,Label2),
3061                 Clause2 =
3062                 ( user:portray(Struct2) :-
3063                         write('<id:'),
3064                         print(Label2),
3065                         write('>')
3066                 ),
3067                 functor(Struct3,struct,ISize),
3068                 arg(1,Struct3,Label3),
3069                 Clause3 = identifier_label(Struct3,Label3),
3070                 L = [Clause1,Clause2,Clause3|T]
3071         ;
3072                 L = T
3073         ).
3074 generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :-
3075         get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
3076         ( IIndex == 2 ->
3077                 identifier_store_initialization(IndexType,L,L1),
3078                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3079                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3080                 get_type_indexed_identifier_size(IndexType,ISize),
3081                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3082                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3083                 type_indexed_identifier_structure(IndexType,Struct),
3084                 Struct =.. [_,Label|Stores],
3085                 set_elems(Stores,[]),
3086                 type_indexed_identifier_name(IndexType,new_identifier,Name1),
3087                 Clause1 =.. [Name1,Label,Struct],
3088                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3089                 Goal1 =.. [Name1,Label1b,S1b],
3090                 type_indexed_identifier_structure(IndexType,Struct1b),
3091                 Struct1b =.. [_,Label1b|Stores1b],
3092                 set_elems(Stores1b,[]),
3093                 Expansion1 = (S1b = Struct1b),
3094                 Clause1b = user:goal_expansion(Goal1,Expansion1),
3095                 writeln(Clause1-Clause1b),
3096                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3097                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3098                 type_indexed_identifier_structure(IndexType,Struct2),
3099                 arg(1,Struct2,Label2),
3100                 Clause2 =
3101                 ( user:portray(Struct2) :-
3102                         write('<id:'),
3103                         print(Label2),
3104                         write('>')
3105                 ),
3106                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3107                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3108                 type_indexed_identifier_structure(IndexType,Struct3),
3109                 arg(1,Struct3,Label3),
3110                 type_indexed_identifier_name(IndexType,identifier_label,Name3),
3111                 Clause3 =.. [Name3,Struct3,Label3],
3112                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3113                 Goal3b =.. [Name3,S3b,L3b],
3114                 type_indexed_identifier_structure(IndexType,Struct3b),
3115                 arg(1,Struct3b,L3b),
3116                 Expansion3b = (S3 = Struct3b),
3117                 Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)),
3118                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3119                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3120                 identifier_store_name(IndexType,GlobalVariable),
3121                 lookup_identifier_atom(IndexType,X,IX,LookupAtom),
3122                 type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor),
3123                 NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX],
3124                 Clause4 =
3125                         ( LookupAtom :-
3126                                 nb_getval(GlobalVariable,HT),
3127                                 ( lookup_ht(HT,X,[IX]) ->
3128                                         true
3129                                 ;
3130                                         NewIdentifierGoal,
3131                                         insert_ht(HT,X,IX)
3132                                 )
3133                         ),
3134                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3135                 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
3136                 L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T]
3137         ;
3138                 L = T
3139         ).
3140
3141 lookup_identifier_atom(Key,X,IX,Atom) :-
3142         atom_concat('lookup_identifier_',Key,LookupFunctor),
3143         Atom =.. [LookupFunctor,X,IX].
3144
3145 identifier_label_atom(IndexType,IX,X,Atom) :-
3146         type_indexed_identifier_name(IndexType,identifier_label,Name),
3147         Atom =.. [Name,IX,X].
3148
3149 multi_store_generate_attach_code([],_,L,L).
3150 multi_store_generate_attach_code([ST|STs],C,L,T) :-
3151         generate_attach_code(ST,C,L,L1),
3152         multi_store_generate_attach_code(STs,C,L1,T).
3153
3154 multi_inthash_store_initialisations([],_,L,L).
3155 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
3156         use_auxiliary_module(chr_integertable_store),
3157         multi_hash_store_name(FA,Index,StoreName),
3158         module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
3159         % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
3160         L1 = L,
3161         multi_inthash_store_initialisations(Indexes,FA,L1,T).
3162 multi_hash_store_initialisations([],_,L,L).
3163 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
3164         use_auxiliary_module(chr_hashtable_store),
3165         multi_hash_store_name(FA,Index,StoreName),
3166         prolog_global_variable(StoreName),
3167         make_init_store_goal(StoreName,HT,InitStoreGoal),
3168         module_initializer((new_ht(HT),InitStoreGoal)),
3169         L1 = L,
3170         multi_hash_store_initialisations(Indexes,FA,L1,T).
3171
3172 global_list_store_initialisation(C,L,T) :-
3173         ( is_stored(C) ->
3174                 global_list_store_name(C,StoreName),
3175                 prolog_global_variable(StoreName),
3176                 make_init_store_goal(StoreName,[],InitStoreGoal),
3177                 module_initializer(InitStoreGoal)
3178         ;
3179                 true
3180         ),
3181         L = T.
3182 global_ground_store_initialisation(C,L,T) :-
3183         global_ground_store_name(C,StoreName),
3184         prolog_global_variable(StoreName),
3185         make_init_store_goal(StoreName,[],InitStoreGoal),
3186         module_initializer(InitStoreGoal),
3187         L = T.
3188 global_singleton_store_initialisation(C,L,T) :-
3189         global_singleton_store_name(C,StoreName),
3190         prolog_global_variable(StoreName),
3191         make_init_store_goal(StoreName,[],InitStoreGoal),
3192         module_initializer(InitStoreGoal),
3193         L = T.
3194 identifier_store_initialization(IndexType,L,T) :-
3195         use_auxiliary_module(chr_hashtable_store),
3196         identifier_store_name(IndexType,StoreName),
3197         prolog_global_variable(StoreName),
3198         make_init_store_goal(StoreName,HT,InitStoreGoal),
3199         module_initializer((new_ht(HT),InitStoreGoal)),
3200         L = T.
3201
3202
3203 multi_inthash_via_lookups([],_,L,L).
3204 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
3205         multi_hash_via_lookup_goal(C,Index,Key,SuspsList,Head),
3206         multi_hash_store_name(C,Index,StoreName),
3207         Body =
3208         (
3209                 nb_getval(StoreName,HT),
3210                 lookup_iht(HT,Key,SuspsList)
3211         ),
3212         L = [(Head :- Body)|L1],
3213         multi_inthash_via_lookups(Indexes,C,L1,T).
3214 multi_hash_via_lookups([],_,L,L).
3215 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
3216         multi_hash_via_lookup_goal(C,Index,Key,SuspsList,Head),
3217         multi_hash_store_name(C,Index,StoreName),
3218         make_get_store_goal(StoreName,HT,GetStoreGoal),
3219         Body =
3220         (
3221                 GetStoreGoal, % nb_getval(StoreName,HT),
3222                 lookup_ht(HT,Key,SuspsList)
3223         ),
3224         L = [(Head :- Body)|L1],
3225         multi_hash_via_lookups(Indexes,C,L1,T).
3226
3227 %%      multi_hash_via_lookup_goal(+ConstraintSymbol,+Index,+Key,+SuspsList,-Goal) is det.
3228 %
3229 %       Returns goal that performs hash table lookup.
3230 multi_hash_via_lookup_goal(ConstraintSymbol,Index,Key,SuspsList,Goal) :-
3231         multi_hash_via_lookup_name(ConstraintSymbol,Index,Name),
3232         Goal =.. [Name,Key,SuspsList].
3233
3234 %%      multi_hash_via_lookup_name(+ConstraintSymbol,+Index,-Name)
3235 %
3236 %       Returns predicate name of hash table lookup predicate.
3237 multi_hash_via_lookup_name(F/A,Index,Name) :-
3238         ( integer(Index) ->
3239                 IndexName = Index
3240         ; is_list(Index) ->
3241                 atom_concat_list(Index,IndexName)
3242         ),
3243         atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
3244
3245 multi_hash_store_name(F/A,Index,Name) :-
3246         get_target_module(Mod),
3247         ( integer(Index) ->
3248                 IndexName = Index
3249         ; is_list(Index) ->
3250                 atom_concat_list(Index,IndexName)
3251         ),
3252         atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
3253
3254 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
3255         ( ( integer(Index) ->
3256                 I = Index
3257           ;
3258                 Index = [I]
3259           ) ->
3260                 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
3261         ; is_list(Index) ->
3262                 sort(Index,Indexes),
3263                 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
3264                 once(pairup(Bodies,Keys,ArgKeyPairs)),
3265                 Key =.. [k|Keys],
3266                 list2conj(Bodies,KeyBody)
3267         ).
3268
3269 multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :-
3270         ( ( integer(Index) ->
3271                 I = Index
3272           ;
3273                 Index = [I]
3274           ) ->
3275                 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody)
3276         ; is_list(Index) ->
3277                 sort(Index,Indexes),
3278                 find_with_var_identity(
3279                         Goal-KeyI,
3280                         [Susp/Head/VarDict],
3281                         (
3282                                 member(I,Indexes),
3283                                 get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal)
3284                         ),
3285                         ArgKeyPairs
3286                 ),
3287                 once(pairup(Bodies,Keys,ArgKeyPairs)),
3288                 Key =.. [k|Keys],
3289                 list2conj(Bodies,KeyBody)
3290         ).
3291
3292 get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :-
3293                 arg(Index,Head,OriginalArg),
3294                 ( lookup_eq(VarDict,OriginalArg,Arg) ->
3295                         Goal = true
3296                 ;
3297                         functor(Head,F,A),
3298                         C = F/A,
3299                         get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal)
3300                 ).
3301
3302 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
3303         ( ( integer(Index) ->
3304                 I = Index
3305           ;
3306                 Index = [I]
3307           ) ->
3308                 UsedVars = [I-Key]
3309         ; is_list(Index) ->
3310                 sort(Index,Indexes),
3311                 pairup(Indexes,Keys,UsedVars),
3312                 Key =.. [k|Keys]
3313         ).
3314
3315 multi_hash_key_args(Index,Head,KeyArgs) :-
3316         ( integer(Index) ->
3317                 arg(Index,Head,Arg),
3318                 KeyArgs = [Arg]
3319         ; is_list(Index) ->
3320                 sort(Index,Indexes),
3321                 term_variables(Head,Vars),
3322                 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
3323         ).
3324
3325 global_list_store_name(F/A,Name) :-
3326         get_target_module(Mod),
3327         atom_concat_list(['$chr_store_global_list_',Mod,(:),F,(/),A],Name).
3328 global_ground_store_name(F/A,Name) :-
3329         get_target_module(Mod),
3330         atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
3331 global_singleton_store_name(F/A,Name) :-
3332         get_target_module(Mod),
3333         atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
3334
3335 identifier_store_name(TypeName,Name) :-
3336         get_target_module(Mod),
3337         atom_concat_list(['$chr_identifier_lookup_',Mod,(:),TypeName],Name).
3338
3339 :- chr_constraint prolog_global_variable/1.
3340 :- chr_option(mode,prolog_global_variable(+)).
3341
3342 :- chr_constraint prolog_global_variables/1.
3343 :- chr_option(mode,prolog_global_variables(-)).
3344
3345 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
3346
3347 prolog_global_variables(List), prolog_global_variable(Name) <=>
3348         List = [Name|Tail],
3349         prolog_global_variables(Tail).
3350 prolog_global_variables(List) <=> List = [].
3351
3352 %% SWI begin
3353 prolog_global_variables_code(Code) :-
3354         prolog_global_variables(Names),
3355         ( Names == [] ->
3356                 Code = []
3357         ;
3358                 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
3359                 Code = [(:- dynamic user:exception/3),
3360                         (:- multifile user:exception/3),
3361                         (user:exception(undefined_global_variable,Name,retry) :-
3362                                 (
3363                                 '$chr_prolog_global_variable'(Name),
3364                                 '$chr_initialization'
3365                                 )
3366                         )
3367                         |
3368                         NameDeclarations
3369                         ]
3370         ).
3371 %% SWI end
3372 %% SICStus begin
3373 % prolog_global_variables_code([]).
3374 %% SICStus end
3375 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3376 %sbag_member_call(S,L,sysh:mem(S,L)).
3377 sbag_member_call(S,L,'chr sbag_member'(S,L)).
3378 %sbag_member_call(S,L,member(S,L)).
3379 update_mutable_call(A,B,'chr update_mutable'( A, B)).
3380 %update_mutable_call(A,B,setarg(1, B, A)).
3381 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
3382 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
3383
3384 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
3385 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
3386 %       create_get_mutable(Value,Field,Get1).
3387 %
3388 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
3389 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
3390 %         update_mutable_call(NewValue,Field,Set).
3391 %
3392 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
3393 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
3394 %       create_get_mutable_ref(Value,Field,Get1),
3395 %         update_mutable_call(NewValue,Field,Set).
3396 %
3397 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
3398 %       get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
3399 %       create_mutable_call(Value,Field,Create).
3400 %
3401 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
3402 %       get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
3403 %       create_get_mutable(Value,Field,Get).
3404 %
3405 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
3406 %       get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
3407 %       create_get_mutable_ref(Value,Field,Get),
3408 %       update_mutable_call(NewValue,Field,Set).
3409
3410 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
3411         get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
3412
3413 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
3414         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3415
3416 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
3417         get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
3418         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3419
3420 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
3421         get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
3422
3423 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
3424         get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
3425
3426 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
3427         get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
3428         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
3429
3430 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3431
3432 enumerate_stores_code(Constraints,Clause) :-
3433         Head = '$enumerate_constraints'(Constraint),
3434         enumerate_store_bodies(Constraints,Constraint,Bodies),
3435         list2disj(Bodies,Body),
3436         Clause = (Head :- Body).
3437
3438 enumerate_store_bodies([],_,[]).
3439 enumerate_store_bodies([C|Cs],Constraint,L) :-
3440         ( is_stored(C) ->
3441                 get_store_type(C,StoreType),
3442                 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
3443                 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
3444                 C = F/_,
3445                 Constraint0 =.. [F|Arguments],
3446                 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
3447                 L = [Body|T]
3448         ;
3449                 L = T
3450         ),
3451         enumerate_store_bodies(Cs,Constraint,T).
3452
3453 enumerate_store_body(default,C,Susp,Body) :-
3454         global_list_store_name(C,StoreName),
3455         sbag_member_call(Susp,List,Sbag),
3456         make_get_store_goal(StoreName,List,GetStoreGoal),
3457         Body =
3458         (
3459                 GetStoreGoal, % nb_getval(StoreName,List),
3460                 Sbag
3461         ).
3462 %       get_constraint_index(C,Index),
3463 %       get_target_module(Mod),
3464 %       get_max_constraint_index(MaxIndex),
3465 %       Body1 =
3466 %       (
3467 %               'chr default_store'(GlobalStore),
3468 %               get_attr(GlobalStore,Mod,Attr)
3469 %       ),
3470 %       ( MaxIndex > 1 ->
3471 %               NIndex is Index + 1,
3472 %               sbag_member_call(Susp,List,Sbag),
3473 %               Body2 =
3474 %               (
3475 %                       arg(NIndex,Attr,List),
3476 %                       Sbag
3477 %               )
3478 %       ;
3479 %               sbag_member_call(Susp,Attr,Sbag),
3480 %               Body2 = Sbag
3481 %       ),
3482 %       Body = (Body1,Body2).
3483 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
3484         multi_inthash_enumerate_store_body(Index,C,Susp,Body).
3485 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
3486         multi_hash_enumerate_store_body(Index,C,Susp,Body).
3487 enumerate_store_body(global_ground,C,Susp,Body) :-
3488         global_ground_store_name(C,StoreName),
3489         sbag_member_call(Susp,List,Sbag),
3490         make_get_store_goal(StoreName,List,GetStoreGoal),
3491         Body =
3492         (
3493                 GetStoreGoal, % nb_getval(StoreName,List),
3494                 Sbag
3495         ).
3496 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
3497         Body = fail.
3498 enumerate_store_body(global_singleton,C,Susp,Body) :-
3499         global_singleton_store_name(C,StoreName),
3500         make_get_store_goal(StoreName,Susp,GetStoreGoal),
3501         Body =
3502         (
3503                 GetStoreGoal, % nb_getval(StoreName,Susp),
3504                 Susp \== []
3505         ).
3506 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
3507         once((
3508                 member(ST,STs),
3509                 enumerate_store_body(ST,C,Susp,Body)
3510         )).
3511 enumerate_store_body(identifier_store(Index),C,Susp,Body) :-
3512         Body = fail.
3513 enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :-
3514         Body = fail.
3515
3516 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
3517         multi_hash_store_name(C,I,StoreName),
3518         B =
3519         (
3520                 nb_getval(StoreName,HT),
3521                 value_iht(HT,Susp)
3522         ).
3523 multi_hash_enumerate_store_body(I,C,Susp,B) :-
3524         multi_hash_store_name(C,I,StoreName),
3525         make_get_store_goal(StoreName,HT,GetStoreGoal),
3526         B =
3527         (
3528                 GetStoreGoal, % nb_getval(StoreName,HT),
3529                 value_ht(HT,Susp)
3530         ).
3531
3532 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3533
3534
3535 :- chr_constraint
3536         prev_guard_list/7,
3537         simplify_guards/1,
3538         set_all_passive/1.
3539
3540 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
3541 :- chr_option(mode,simplify_guards(+)).
3542 :- chr_option(mode,set_all_passive(+)).
3543
3544 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3545 %    GUARD SIMPLIFICATION
3546 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3547 % If the negation of the guards of earlier rules entails (part of)
3548 % the current guard, the current guard can be simplified. We can only
3549 % use earlier rules with a head that matches if the head of the current
3550 % rule does, and which make it impossible for the current rule to match
3551 % if they fire (i.e. they shouldn't be propagation rules and their
3552 % head constraints must be subsets of those of the current rule).
3553 % At this point, we know for sure that the negation of the guard
3554 % of such a rule has to be true (otherwise the earlier rule would have
3555 % fired, because of the refined operational semantics), so we can use
3556 % that information to simplify the guard by replacing all entailed
3557 % conditions by true/0. As a consequence, the never-stored analysis
3558 % (in a further phase) will detect more cases of never-stored constraints.
3559 %
3560 % e.g.      c(X),d(Y) <=> X > 0 | ...
3561 %           e(X) <=> X < 0 | ...
3562 %           c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
3563 %                                \____________/
3564 %                                    true
3565
3566 guard_simplification :-
3567         ( chr_pp_flag(guard_simplification,on) ->
3568                 simplify_guards(1)
3569         ;
3570                 true
3571         ).
3572
3573 %       for every rule, we create a prev_guard_list where the last argument
3574 %       eventually is a list of the negations of earlier guards
3575 rule(RuleNb,Rule) \ simplify_guards(RuleNb)
3576         <=>
3577                 Rule = pragma(rule(Head1,Head2,Guard,_B),_Ids,_Pragmas,_Name,RuleNb),
3578                 append(Head1,Head2,Heads),
3579                 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings),
3580                 multiple_occ_constraints_checked([]),
3581                 apply_guard_wrt_term(Heads,Guard,SubstitutedHeads),
3582                 PrevRuleNb is RuleNb-1,
3583                 prev_guard_list(RuleNb,PrevRuleNb,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]),
3584                 NextRule is RuleNb+1,
3585                 simplify_guards(NextRule).
3586
3587 %       no more rule
3588 simplify_guards(_)
3589         <=>
3590                 true.
3591
3592 %       The negation of the guard of a non-propagation rule is added
3593 %       if its kept head constraints are a subset of the kept constraints of
3594 %       the rule we're working on, and its removed head constraints (at least one)
3595 %       are a subset of the removed constraints.
3596
3597 rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,CurrentHeads,G,GuardList,Matchings,GH)
3598         <=>
3599                 PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,PrevRuleNb),
3600                 H1 \== [],
3601                 append(H1,H2,Heads),
3602                 make_head_matchings_explicit(Heads,MatchingFreeHeads,PrevMatchings),
3603                 setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings)
3604     |
3605                 compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1),
3606                 append(GuardList,DerivedInfo,GL1),
3607                 normalize_conj_list(GL1,GL),
3608                 append(GH_New1,GH,GH1),
3609                 normalize_conj_list(GH1,GH_New),
3610                 PrevPrevRuleNb is PrevRuleNb-1,
3611                 prev_guard_list(RuleNb,PrevPrevRuleNb,CurrentHeads,G,GL,Matchings,GH_New).
3612
3613 %       if this isn't the case, we skip this one and try the next rule
3614 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH)
3615         <=>
3616                 N > 0
3617         |
3618                 N1 is N-1,
3619                 prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
3620
3621 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH)
3622         <=>
3623                 GH \== []
3624         |
3625                 head_types_modes_condition(GH,H,TypeInfo),
3626                 conj2list(TypeInfo,TI),
3627                 term_variables(H,HeadVars),
3628                 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
3629                 normalize_conj_list(Info,InfoL),
3630                 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
3631
3632 head_types_modes_condition([],H,true).
3633 head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :-
3634         types_modes_condition(H,GH,TI1),
3635         head_types_modes_condition(GHs,H,TI2).
3636
3637 %%
3638 %
3639 %       when all earlier guards are added or skipped, we simplify the guard.
3640 %       if it's different from the original one, we change the rule
3641
3642 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule)
3643         <=>
3644                 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3645                 G \== true,             % let's not try to simplify this ;)
3646                 append(M,GuardList,Info),
3647                 simplify_guard(G,B,Info,SimpleGuard,NB),
3648                 G \== SimpleGuard
3649         |
3650                 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
3651                 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
3652
3653 %%      normalize_conj_list(+List,-NormalList) is det.
3654 %
3655 %       Removes =true= elements and flattens out conjunctions.
3656
3657 normalize_conj_list(List,NormalList) :-
3658         list2conj(List,Conj),
3659         conj2list(Conj,NormalList).
3660
3661 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3662 %    AUXILIARY PREDICATES       (GUARD SIMPLIFICATION)
3663 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3664
3665 compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]).
3666 compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :-
3667         copy_term(PrevMatchings-PrevGuard,FreshMatchings),
3668         variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming),
3669         append(Renaming1,ExtraRenaming,Renaming2),
3670         list2conj(PrevMatchings,Match),
3671         negate_b(Match,HeadsDontMatch),
3672         make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch),
3673         list2conj(HeadsMatch,HeadsMatchBut),
3674         term_variables(Renaming2,RenVars),
3675         term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars),
3676         new_vars(MGVars,RenVars,ExtraRenaming2),
3677         append(Renaming2,ExtraRenaming2,Renaming),
3678         ( PrevGuard == true ->          % true can't fail
3679                 Info_ = HeadsDontMatch
3680         ;
3681                 negate_b(PrevGuard,TheGuardFailed),
3682                 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
3683         ),
3684         copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
3685         copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming),
3686         copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming),
3687         list2conj(RenamedMatchings_,RenamedMatchings),
3688         apply_guard_wrt_term(H,RenamedG2,GH2),
3689         apply_guard_wrt_term(GH2,RenamedMatchings,GH3),
3690         compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2).
3691
3692 simplify_guard(G,B,Info,SG,NB) :-
3693     conj2list(G,LG),
3694     guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
3695     list2conj(SGL,SG).
3696
3697
3698 new_vars([],_,[]).
3699 new_vars([A|As],RV,ER) :-
3700     ( memberchk_eq(A,RV) ->
3701         new_vars(As,RV,ER)
3702     ;
3703         ER = [A-NewA,NewA-A|ER2],
3704         new_vars(As,RV,ER2)
3705     ).
3706
3707 %%      head_subset(+Subset,+MultiSet,-Renaming) is nondet.
3708 %
3709 %       check if a list of constraints is a subset of another list of constraints
3710 %       (multiset-subset), meanwhile computing a variable renaming to convert
3711 %       one into the other.
3712 head_subset(H,Head,Renaming) :-
3713         head_subset(H,Head,Renaming,[],_).
3714
3715 head_subset([],Remainder,Renaming,Renaming,Remainder).
3716 head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :-
3717         head_member(X,MultiSet,NAcc,Acc,Remainder1),
3718         head_subset(Xs,Remainder1,Renaming,NAcc,Remainder).
3719
3720 %       check if A is in the list, remove it from Headleft
3721 head_member(A,[X|Xs],Renaming,Acc,Remainder) :-
3722         ( variable_replacement(A,X,Acc,Renaming),
3723                 Remainder = Xs
3724         ;
3725                 head_member(A,Xs,Renaming,Acc,RRemainder),
3726                 Remainder = [X|RRemainder]
3727         ).
3728
3729 make_head_matchings_explicit(Heads,MatchingFreeHeads,Matchings) :-
3730         extract_arguments(Heads,Arguments),
3731         make_matchings_explicit(Arguments,H1_,[],[],_,Matchings),
3732         substitute_arguments(Heads,H1_,MatchingFreeHeads).
3733
3734 make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :-
3735         extract_arguments(Heads,Arguments),
3736         make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings),
3737         substitute_arguments(Heads,FreshVariables,MatchingFreeHeads).
3738
3739 make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :-
3740     extract_arguments(Heads,Arguments1),
3741     extract_arguments(MatchingFreeHeads,Arguments2),
3742     make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings).
3743
3744 %%      extract_arguments(+ListOfConstraints,-ListOfVariables) is det.
3745 %
3746 %       Returns list of arguments of given list of constraints.
3747
3748 extract_arguments([],[]).
3749 extract_arguments([C|Cs],AllArguments) :-
3750         C =.. [_|Arguments],
3751         append(Arguments,RestArguments,AllArguments),
3752         extract_arguments(Cs,RestArguments).
3753
3754 %%      substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det.
3755 %
3756 %       Substitutes arguments of constraints with those in the given list.
3757
3758 substitute_arguments([],[],[]).
3759 substitute_arguments([C|Cs],Variables,[NC|NCs]) :-
3760         functor(C,F,N),
3761         split_at(N,Variables,Arguments,RestVariables),
3762         NC =.. [F|Arguments],
3763         substitute_arguments(Cs,RestVariables,NCs).
3764
3765 make_matchings_explicit([],[],_,MC,MC,[]).
3766 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
3767     ( var(X) ->
3768         ( memberchk_eq(X,C) ->
3769             list2disj(MC,MC_disj),
3770             M = [(MC_disj ; NewVar == X)|M2],           % or only =    ??
3771             C2 = C
3772         ;
3773             M = M2,
3774             NewVar = X,
3775             C2 = [X|C]
3776         ),
3777         MC2 = MC
3778     ;
3779         functor(X,F,A),
3780         X =.. [F|Args],
3781         make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
3782         X_ =.. [F|NewArgs],
3783         (ArgM == [] ->
3784             M = [functor(NewVar,F,A) |M2]
3785         ;
3786             list2conj(ArgM,ArgM_conj),
3787             list2disj(MC,MC_disj),
3788             ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
3789             M = [ functor(NewVar,F,A) , ArgM_|M2]
3790         ),
3791         MC2 = [ NewVar \= X_ |MC_],
3792         term_variables(Args,ArgVars),
3793         append(C,ArgVars,C2)
3794     ),
3795     make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
3796
3797
3798 %%      make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det.
3799 %
3800 %       Returns list of new variables and list of pairwise unifications between given list and variables.
3801
3802 make_matchings_explicit_not_negated([],[],[]).
3803 make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :-
3804         Matchings = [Var = X|RMatchings],
3805         make_matchings_explicit_not_negated(Xs,Vars,RMatchings).
3806
3807 %%      apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det.
3808 %
3809 %       (Partially) applies substitutions of =Goal= to given list.
3810
3811 apply_guard_wrt_term([],_Guard,[]).
3812 apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :-
3813         ( var(Term) ->
3814                 apply_guard_wrt_variable(Guard,Term,NTerm)
3815         ;
3816                 Term =.. [F|HArgs],
3817                 apply_guard_wrt_term(HArgs,Guard,NewHArgs),
3818                 NTerm =.. [F|NewHArgs]
3819         ),
3820         apply_guard_wrt_term(RH,Guard,RGH).
3821
3822 %%      apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det.
3823 %
3824 %       (Partially) applies goal =Guard= wrt variable.
3825
3826 apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !,
3827         apply_guard_wrt_variable(Guard1,Variable,NVariable1),
3828         apply_guard_wrt_variable(Guard2,NVariable1,NVariable).
3829 apply_guard_wrt_variable(Guard,Variable,NVariable) :-
3830         ( Guard = (X = Y), Variable == X ->
3831                 NVariable = Y
3832         ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) ->
3833                 functor(NVariable,Functor,Arity)
3834         ;
3835                 NVariable = Variable
3836         ).
3837
3838 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3839 %    ALWAYS FAILING HEADS
3840 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3841
3842 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[])
3843         <=>
3844                 chr_pp_flag(check_impossible_rules,on),
3845                 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3846                 append(M,GuardList,Info),
3847                 guard_entailment:entails_guard(Info,fail)
3848         |
3849                 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3850                 set_all_passive(RuleNb).
3851
3852 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3853 %    HEAD SIMPLIFICATION
3854 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3855
3856 % now we check the head matchings  (guard may have been simplified meanwhile)
3857 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule)
3858         <=>
3859                 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3860                 simplify_heads(M,GuardList,G,B,NewM,NewB),
3861                 NewM \== [],
3862                 extract_arguments(Head1,VH1),
3863                 extract_arguments(Head2,VH2),
3864                 extract_arguments(H,VH),
3865                 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
3866                 substitute_arguments(Head1,H1,NewH1),
3867                 substitute_arguments(Head2,H2,NewH2),
3868                 append(NewB,NewB_,NewBody),
3869                 list2conj(NewBody,BodyMatchings),
3870                 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
3871                 (Head1 \== NewH1 ; Head2 \== NewH2 )
3872         |
3873                 rule(RuleNb,NewRule).
3874
3875 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3876 %    AUXILIARY PREDICATES       (HEAD SIMPLIFICATION)
3877 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3878
3879 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
3880 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
3881     ( NH == M ->
3882         H2_ = M,
3883         replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
3884     ;
3885         (M = functor(X,F,A), NH == X ->
3886             length(A_args,A),
3887             (var(H2) ->
3888                 NewB1 = [],
3889                 H2_ =.. [F|A_args]
3890             ;
3891                 H2 =.. [F|OrigArgs],
3892                 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3893                 H2_ =.. [F|A_args_]
3894             ),
3895             replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
3896             append(NewB1,NewB2,NewB)
3897         ;
3898             H2_ = H2,
3899             replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
3900         )
3901     ).
3902
3903 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
3904     ( NH == M ->
3905         H1_ = M,
3906         replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
3907     ;
3908         (M = functor(X,F,A), NH == X ->
3909             length(A_args,A),
3910             (var(H1) ->
3911                 NewB1 = [],
3912                 H1_ =.. [F|A_args]
3913             ;
3914                 H1 =.. [F|OrigArgs],
3915                 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3916                 H1_ =.. [F|A_args_]
3917             ),
3918             replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
3919             append(NewB1,NewB2,NewB)
3920         ;
3921             H1_ = H1,
3922             replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
3923         )
3924     ).
3925
3926 use_same_args([],[],[],_,_,[]).
3927 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3928     var(OA),!,
3929     Out = OA,
3930     use_same_args(ROA,RNA,ROut,G,Body,NewB).
3931 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3932     nonvar(OA),!,
3933     ( vars_occur_in(OA,Body) ->
3934         NewB = [NA = OA|NextB]
3935     ;
3936         NewB = NextB
3937     ),
3938     Out = NA,
3939     use_same_args(ROA,RNA,ROut,G,Body,NextB).
3940
3941
3942 simplify_heads([],_GuardList,_G,_Body,[],[]).
3943 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
3944     M = (A = B),
3945     ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
3946         guard_entailment:entails_guard(GuardList,(A=B)) ->
3947         ( vars_occur_in(B,G-RM-GuardList) ->
3948             NewB = NextB,
3949             NewM = NextM
3950         ;
3951             ( vars_occur_in(B,Body) ->
3952                 NewB = [A = B|NextB]
3953             ;
3954                 NewB = NextB
3955             ),
3956             NewM = [A|NextM]
3957         )
3958     ;
3959         ( nonvar(B), functor(B,BFu,BAr),
3960           guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
3961             NewB = NextB,
3962             ( vars_occur_in(B,G-RM-GuardList) ->
3963                 NewM = NextM
3964             ;
3965                 NewM = [functor(A,BFu,BAr)|NextM]
3966             )
3967         ;
3968             NewM = NextM,
3969             NewB = NextB
3970         )
3971     ),
3972     simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
3973
3974 vars_occur_in(B,G) :-
3975     term_variables(B,BVars),
3976     term_variables(G,GVars),
3977     intersect_eq(BVars,GVars,L),
3978     L \== [].
3979
3980
3981 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3982 %    ALWAYS FAILING GUARDS
3983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3984
3985 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
3986 set_all_passive(_) <=> true.
3987
3988 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule)
3989         ==>
3990                 chr_pp_flag(check_impossible_rules,on),
3991                 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
3992                 conj2list(G,GL),
3993                 guard_entailment:entails_guard(GL,fail)
3994         |
3995                 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3996                 set_all_passive(RuleNb).
3997
3998
3999
4000 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4001 %    OCCURRENCE SUBSUMPTION
4002 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4003
4004 :- chr_constraint
4005         first_occ_in_rule/4,
4006         next_occ_in_rule/6.
4007
4008 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
4009 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
4010
4011 :- chr_constraint multiple_occ_constraints_checked/1.
4012 :- chr_option(mode,multiple_occ_constraints_checked(+)).
4013
4014 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), occurrence(C,O,RuleNb,ID,_),
4015                 occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule) \ multiple_occ_constraints_checked(Done)
4016         <=>
4017                 O < O2,
4018                 chr_pp_flag(occurrence_subsumption,on),
4019                 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
4020                 H1 \== [],
4021                 \+ memberchk_eq(C,Done)
4022         |
4023                 first_occ_in_rule(RuleNb,C,O,ID),
4024                 multiple_occ_constraints_checked([C|Done]).
4025
4026 %       Find first occurrence of  constraint =C= in rule =RuleNb=
4027 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_)
4028         <=>
4029                 O < O2
4030         |
4031                 first_occ_in_rule(RuleNb,C,O,ID).
4032
4033 first_occ_in_rule(RuleNb,C,O,ID_o1)
4034         <=>
4035                 C = F/A,
4036                 functor(FreshHead,F,A),
4037                 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
4038
4039 %       Skip passive occurrences.
4040 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4041         <=>
4042                 O2 is O+1
4043         |
4044                 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
4045
4046 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH)
4047         <=>
4048                 O2 is O+1,
4049                 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
4050     |
4051                 append(H1,H2,Heads),
4052                 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
4053                 ( ExtraCond == [chr_pp_void_info] ->
4054                         next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
4055                 ;
4056                         append(ExtraCond,Cond,NewCond),
4057                         add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
4058                         copy_term(GuardList,FGuardList),
4059                         variable_replacement(GuardList,FGuardList,GLRepl),
4060                         copy_with_variable_replacement(GuardList,GuardList2,Repl),
4061                         copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
4062                         copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
4063                         append(NewCond,GuardList2,BigCond),
4064                         append(BigCond,GuardList3,BigCond2),
4065                         copy_with_variable_replacement(M,M2,Repl),
4066                         copy_with_variable_replacement(M,M3,Repl2),
4067                         append(M3,BigCond2,BigCond3),
4068                         append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
4069                         list2conj(CheckCond,OccSubsum),
4070                         copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
4071 %                       term_variables(NewCond2-FH2,InfoVars),
4072 %                       flatten_stuff(Info2,Info3),
4073 %                       flatten_stuff(OccSubsum2,OccSubsum3),
4074                         ( OccSubsum \= chr_pp_void_info
4075 %                         unify_stuff(InfoVars,Info3,OccSubsum3)
4076 ->
4077                                 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
4078                                         passive(RuleNb,ID_o2)
4079                                 ;
4080                                         true
4081                                 )
4082                         ;
4083                                 true
4084                         ),!,
4085                         next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
4086                 ).
4087
4088
4089 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args)
4090         <=>
4091                 true.
4092
4093 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done)
4094         <=>
4095                 true.
4096
4097 flatten_stuff([A|B],C) :- !,
4098     flatten_stuff(A,C1),
4099     flatten_stuff(B,C2),
4100     append(C1,C2,C).
4101 flatten_stuff((A;B),C) :- !,
4102     flatten_stuff(A,C1),
4103     flatten_stuff(B,C2),
4104     append(C1,C2,C).
4105 flatten_stuff((A,B),C) :- !,
4106     flatten_stuff(A,C1),
4107     flatten_stuff(B,C2),
4108     append(C1,C2,C).
4109
4110 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
4111 flatten_stuff(X,[]).
4112
4113 unify_stuff(AllInfo,[],[]).
4114
4115 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
4116     H \== I,
4117     term_variables(H,HVars),
4118     term_variables(I,IVars),
4119     intersect_eq(HVars,IVars,SharedVars),
4120     check_safe_unif(H,I,SharedVars),
4121     variable_replacement(H,I,Repl),
4122     check_replacement(Repl),
4123     term_variables(Repl,ReplVars),
4124     list_difference_eq(ReplVars,HVars,LDiff),
4125     intersect_eq(AllInfo,LDiff,LDiff2),
4126     LDiff2 == [],
4127     H = I,
4128     unify_stuff(AllInfo,RInfo,ROS),!.
4129
4130 unify_stuff(AllInfo,X,[Y|ROS]) :-
4131     unify_stuff(AllInfo,X,ROS).
4132
4133 unify_stuff(AllInfo,[Y|RInfo],X) :-
4134     unify_stuff(AllInfo,RInfo,X).
4135
4136 check_safe_unif(H,I,SV) :- var(H), !, var(I),
4137     ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
4138         H == I
4139     ;
4140         true
4141     ).
4142
4143 check_safe_unif([],[],SV) :- !.
4144 check_safe_unif([H|Hs],[I|Is],SV) :-  !,
4145     check_safe_unif(H,I,SV),!,
4146     check_safe_unif(Hs,Is,SV).
4147
4148 check_safe_unif(H,I,SV) :-
4149     nonvar(H),!,nonvar(I),
4150     H =.. [F|HA],
4151     I =.. [F|IA],
4152     check_safe_unif(HA,IA,SV).
4153
4154 check_safe_unif2(H,I) :- var(H), !.
4155
4156 check_safe_unif2([],[]) :- !.
4157 check_safe_unif2([H|Hs],[I|Is]) :-  !,
4158     check_safe_unif2(H,I),!,
4159     check_safe_unif2(Hs,Is).
4160
4161 check_safe_unif2(H,I) :-
4162     nonvar(H),!,nonvar(I),
4163     H =.. [F|HA],
4164     I =.. [F|IA],
4165     check_safe_unif2(HA,IA).
4166
4167
4168 check_replacement(Repl) :-
4169         check_replacement(Repl,FirstVars),
4170         sort(FirstVars,Sorted),
4171         length(Sorted,L),!,
4172         length(FirstVars,L).
4173
4174 check_replacement([],[]).
4175 check_replacement([A-B|R],[A|RC]) :-
4176         check_replacement(R,RC).
4177
4178 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
4179     Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
4180     append(ID2,ID1,IDs),
4181     missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
4182     copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
4183     variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
4184     copy_with_variable_replacement(G,FG,Repl),
4185     extract_explicit_matchings(FG,FG2),
4186     negate_b(FG2,NotFG),
4187     copy_with_variable_replacement(MPCond,FMPCond,Repl),
4188     ( check_safe_unif2(FH,FH2),    FH=FH2 ->
4189         FailCond = [(NotFG;FMPCond)]
4190     ;
4191         % in this case, not much can be done
4192         % e.g.    c(f(...)), c(g(...)) <=> ...
4193         FailCond = [chr_pp_void_info]
4194     ).
4195
4196
4197
4198 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
4199 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
4200     missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
4201 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
4202     Cond = (chr_pp_not_in_store(H);Cond1),
4203     missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
4204
4205 extract_explicit_matchings(A=B) :-
4206     var(A), var(B), !, A=B.
4207 extract_explicit_matchings(A==B) :-
4208     var(A), var(B), !, A=B.
4209
4210 extract_explicit_matchings((A,B),D) :- !,
4211         ( extract_explicit_matchings(A) ->
4212                 extract_explicit_matchings(B,D)
4213         ;
4214                 D = (A,E),
4215                 extract_explicit_matchings(B,E)
4216         ).
4217 extract_explicit_matchings(A,D) :- !,
4218         ( extract_explicit_matchings(A) ->
4219                 D = true
4220         ;
4221                 D = A
4222         ).
4223
4224
4225
4226
4227 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4228 %    TYPE INFORMATION
4229 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4230
4231 :- chr_constraint
4232         type_definition/2,
4233         type_alias/2,
4234         constraint_type/2,
4235         get_type_definition/2,
4236         get_constraint_type/2.
4237
4238
4239 :- chr_option(mode,type_definition(?,?)).
4240 :- chr_option(mode,get_type_definition(?,?)).
4241 :- chr_option(mode,type_alias(?,?)).
4242 :- chr_option(mode,constraint_type(+,+)).
4243 :- chr_option(mode,get_constraint_type(+,-)).
4244
4245 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4246 % Consistency checks of type aliases
4247
4248 type_alias(T,T2) <=>
4249    nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4250    copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
4251    chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
4252
4253 type_alias(T1,A1), type_alias(T2,A2) <=>
4254    nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
4255    \+ (T1\=T2) |
4256    copy_term_nat(T1,T1_),
4257    copy_term_nat(T2,T2_),
4258    T1_ = T2_,
4259    chr_error(type_error,
4260    'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]).
4261
4262 type_alias(T,B) \ type_alias(X,T2) <=>
4263         nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4264         copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
4265         chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
4266         type_alias(X2,D1).
4267
4268 oneway_unification(X,Y) :-
4269         term_variables(X,XVars),
4270         chr_runtime:lockv(XVars),
4271         X=Y,
4272         chr_runtime:unlockv(XVars).
4273
4274 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4275 % Consistency checks of type definitions
4276
4277 type_definition(T1,_), type_definition(T2,_)
4278         <=>
4279                 functor(T1,F,A), functor(T2,F,A)
4280         |
4281                 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
4282
4283 type_definition(T1,_), type_alias(T2,_)
4284         <=>
4285                 functor(T1,F,A), functor(T2,F,A)
4286         |
4287                 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
4288
4289 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4290 %%      get_type_definition(+Type,-Definition) is semidet.
4291 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4292
4293 get_type_definition(T,Def)
4294         <=>
4295                 \+ ground(T)
4296         |
4297                 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
4298
4299 type_alias(T,D) \ get_type_definition(T2,Def)
4300         <=>
4301                 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4302                 copy_term_nat((T,D),(T1,D1)),T1=T2
4303         |
4304                 ( get_type_definition(D1,Def) ->
4305                         true
4306                 ;
4307                         chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
4308                 ).
4309
4310 type_definition(T,D) \ get_type_definition(T2,Def)
4311         <=>
4312                 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
4313                 copy_term_nat((T,D),(T1,D1)),T1=T2
4314         |
4315                 Def = D1.
4316
4317 get_type_definition(Type,Def)
4318         <=>
4319                 atomic_builtin_type(Type,_,_)
4320         |
4321                 Def = [Type].
4322
4323 get_type_definition(Type,Def)
4324         <=>
4325                 compound_builtin_type(Type,_,_)
4326         |
4327                 Def = [Type].
4328
4329 get_type_definition(X,Y) <=> fail.
4330
4331 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4332 %%      get_type_definition_det(+Type,-Definition) is det.
4333 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4334 get_type_definition_det(Type,Definition) :-
4335         ( get_type_definition(Type,Definition) ->
4336                 true
4337         ;
4338                 chr_error(type,'Could not find type definition for type `~w\'.\n',[Type])
4339         ).
4340
4341 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4342 %%      get_constraint_type(+ConstraintSymbol,-Types) is semidet.
4343 %
4344 %       Return argument types of =ConstraintSymbol=, but fails if none where
4345 %       declared.
4346 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4347 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
4348 get_constraint_type(_,_) <=> fail.
4349
4350 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4351 %%      get_constraint_type_det(+ConstraintSymbol,-Types) is det.
4352 %
4353 %       Like =get_constraint_type/2=, but returns list of =any= types when
4354 %       no types are declared.
4355 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4356 get_constraint_type_det(ConstraintSymbol,Types) :-
4357         ( get_constraint_type(ConstraintSymbol,Types) ->
4358                 true
4359         ;
4360                 ConstraintSymbol = _ / N,
4361                 replicate(N,any,Types)
4362         ).
4363 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4364 %%      unalias_type(+Alias,-Type) is det.
4365 %
4366 %       Follows alias chain until base type is reached.
4367 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4368 :- chr_constraint unalias_type/2.
4369
4370 unalias_var @
4371 unalias_type(Alias,BaseType)
4372         <=>
4373                 var(Alias)
4374         |
4375                 BaseType = Alias.
4376
4377 unalias_alias @
4378 type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType)
4379         <=>
4380                 nonvar(AliasProtoType),
4381                 nonvar(Alias),
4382                 functor(AliasProtoType,F,A),
4383                 functor(Alias,F,A),
4384                 copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)),
4385                 Alias = AliasInstance
4386         |
4387                 unalias_type(Type,BaseType).
4388
4389 unalias_type_definition @
4390 type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType)
4391         <=>
4392                 nonvar(ProtoType),
4393                 nonvar(Alias),
4394                 functor(ProtoType,F,A),
4395                 functor(Alias,F,A)
4396         |
4397                 BaseType = Alias.
4398
4399 unalias_atomic_builtin @
4400 unalias_type(Alias,BaseType)
4401         <=>
4402                 atomic_builtin_type(Alias,_,_)
4403         |
4404                 BaseType = Alias.
4405
4406 unalias_compound_builtin @
4407 unalias_type(Alias,BaseType)
4408         <=>
4409                 compound_builtin_type(Alias,_,_)
4410         |
4411                 BaseType = Alias.
4412
4413 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4414 %%      types_modes_condition(+Heads,+UnrollHeads,-Condition) is det.
4415 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4416 :- chr_constraint types_modes_condition/3.
4417 :- chr_option(mode,types_modes_condition(+,+,?)).
4418 :- chr_option(type_declaration,types_modes_condition(list,list,goal)).
4419
4420 types_modes_condition([],[],T) <=> T=true.
4421
4422 constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition)
4423         <=>
4424                 functor(Head,F,A)
4425         |
4426                 Head =.. [_|Args],
4427                 Condition = (ModesCondition, TypesCondition, RestCondition),
4428                 modes_condition(Modes,Args,ModesCondition),
4429                 get_constraint_type_det(F/A,Types),
4430                 UnrollHead =.. [_|RealArgs],
4431                 types_condition(Types,Args,RealArgs,Modes,TypesCondition),
4432                 types_modes_condition(Heads,UnrollHeads,RestCondition).
4433
4434 types_modes_condition([Head|_],_,_)
4435         <=>
4436                 functor(Head,F,A),
4437                 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
4438
4439
4440 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4441 %%      modes_condition(+Modes,+Args,-Condition) is det.
4442 %
4443 %       Return =Condition= on =Args= that checks =Modes=.
4444 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4445 modes_condition([],[],true).
4446 modes_condition([Mode|Modes],[Arg|Args],Condition) :-
4447         ( Mode == (+) ->
4448                 Condition = ( ground(Arg) , RCondition )
4449         ; Mode == (-) ->
4450                 Condition = ( var(Arg) , RCondition )
4451         ;
4452                 Condition = RCondition
4453         ),
4454         modes_condition(Modes,Args,RCondition).
4455
4456 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4457 %%      types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det.
4458 %
4459 %       Return =Condition= on =Args= that checks =Types= given =Modes=.
4460 %       =UnrollArgs= controls the depth of type definition unrolling.
4461 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4462 types_condition([],[],[],[],true).
4463 types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :-
4464         ( Mode == (-) ->
4465                 TypeConditionList = [true]      % TypeConditionList = [var(Arg)] already encoded in modes_condition
4466         ;
4467                 get_type_definition_det(Type,Def),
4468                 type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1),
4469                 ( Mode == (+) ->
4470                         TypeConditionList = TypeConditionList1
4471                 ;
4472                         TypeConditionList = [(\+ ground(Arg))|TypeConditionList1]
4473                 )
4474         ),
4475         list2disj(TypeConditionList,DisjTypeConditionList),
4476         types_condition(Types,Args,UnrollArgs,Modes,RCondition).
4477
4478 type_condition([],_,_,_,[]).
4479 type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :-
4480         ( var(DefCase) ->
4481                 chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true
4482         ; atomic_builtin_type(DefCase,Arg,Condition) ->
4483                 true
4484         ; compound_builtin_type(DefCase,Arg,Condition) ->
4485                 true
4486         ;
4487                 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition)
4488         ),
4489         type_condition(DefCases,Arg,UnrollArg,Mode,Conditions).
4490
4491 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4492 :- chr_type atomic_builtin_type --->    any
4493                                 ;       number
4494                                 ;       float
4495                                 ;       int
4496                                 ;       natural
4497                                 ;       dense_int
4498                                 ;       chr_identifier
4499                                 ;       chr_identifier(any).
4500 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4501
4502 atomic_builtin_type(any,_Arg,true).
4503 atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)).
4504 atomic_builtin_type(int,Arg,integer(Arg)).
4505 atomic_builtin_type(number,Arg,number(Arg)).
4506 atomic_builtin_type(float,Arg,float(Arg)).
4507 atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)).
4508 atomic_builtin_type(chr_identifier,_Arg,true).
4509
4510 compound_builtin_type(chr_identifier(_),_Arg,true).
4511
4512 type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :-
4513         ( nonvar(DefCase) ->
4514                 functor(DefCase,F,A),
4515                 ( A == 0 ->
4516                         Condition = (Arg = DefCase)
4517                 ; var(UnrollArg) ->
4518                         Condition = functor(Arg,F,A)
4519                 ; functor(UnrollArg,F,A) ->
4520                         Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition),
4521                         DefCase =.. [_|ArgTypes],
4522                         UnrollArg =.. [_|UnrollArgs],
4523                         functor(Template,F,A),
4524                         Template =.. [_|TemplateArgs],
4525                         replicate(A,Mode,ArgModes),
4526                         types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition)
4527                 ;
4528                         Condition = functor(Arg,F,A)
4529                 )
4530         ;
4531                 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
4532         ).
4533
4534
4535 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4536 % Static type checking
4537 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4538 % Checks head constraints and CHR constraint calls in bodies.
4539 %
4540 % TODO:
4541 %       - type clashes involving built-in types
4542 %       - Prolog built-ins in guard and body
4543 %       - indicate position in terms in error messages
4544 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4545 :- chr_constraint
4546         static_type_check/0.
4547
4548 :- chr_type type_error_src ---> head(any) ; body(any).
4549
4550 rule(_,Rule), static_type_check
4551         ==>
4552                 copy_term_nat(Rule,RuleCopy),
4553                 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
4554                 (
4555                         catch(
4556                                 ( static_type_check_heads(Head1),
4557                                   static_type_check_heads(Head2),
4558                                   conj2list(Body,GoalList),
4559                                   static_type_check_body(GoalList)
4560                                 ),
4561                                 type_error(Error),
4562                                 ( Error = invalid_functor(Src,Term,Type) ->
4563                                         chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
4564                                                 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
4565                                 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
4566                                         chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
4567                                                 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
4568                                 )
4569                         ),
4570                         fail % cleanup constraints
4571                 ;
4572                         true
4573                 ).
4574
4575
4576 static_type_check <=> true.
4577
4578 static_type_check_heads([]).
4579 static_type_check_heads([Head|Heads]) :-
4580         static_type_check_head(Head),
4581         static_type_check_heads(Heads).
4582
4583 static_type_check_head(Head) :-
4584         functor(Head,F,A),
4585         get_constraint_type_det(F/A,Types),
4586         Head =..[_|Args],
4587         maplist(static_type_check_term(head(Head)),Args,Types).
4588
4589 static_type_check_body([]).
4590 static_type_check_body([Goal|Goals]) :-
4591         functor(Goal,F,A),
4592         get_constraint_type_det(F/A,Types),
4593         Goal =..[_|Args],
4594         maplist(static_type_check_term(body(Goal)),Args,Types),
4595         static_type_check_body(Goals).
4596
4597 :- chr_constraint static_type_check_term/3.
4598 :- chr_option(mode,static_type_check_term(?,?,?)).
4599 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
4600
4601 static_type_check_term(Src,Term,Type)
4602         <=>
4603                 var(Term)
4604         |
4605                 static_type_check_var(Src,Term,Type).
4606 static_type_check_term(Src,Term,Type)
4607         <=>
4608                 atomic_builtin_type(Type,Term,Goal)
4609         |
4610                 ( call(Goal) ->
4611                         true
4612                 ;
4613                         throw(type_error(invalid_functor(Src,Term,Type)))
4614                 ).
4615 static_type_check_term(Src,Term,Type)
4616         <=>
4617                 compound_builtin_type(Type,Term,Goal)
4618         |
4619                 ( call(Goal) ->
4620                         true
4621                 ;
4622                         throw(type_error(invalid_functor(Src,Term,Type)))
4623                 ).
4624 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
4625         <=>
4626                 functor(Type,F,A),
4627                 functor(AType,F,A)
4628         |
4629                 copy_term_nat(AType-ADef,Type-Def),
4630                 static_type_check_term(Src,Term,Def).
4631
4632 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
4633         <=>
4634                 functor(Type,F,A),
4635                 functor(AType,F,A)
4636         |
4637                 copy_term_nat(AType-ADef,Type-Variants),
4638                 functor(Term,TF,TA),
4639                 ( member(Variant,Variants), functor(Variant,TF,TA) ->
4640                         Term =.. [_|Args],
4641                         Variant =.. [_|Types],
4642                         maplist(static_type_check_term(Src),Args,Types)
4643                 ;
4644                         throw(type_error(invalid_functor(Src,Term,Type)))
4645                 ).
4646
4647 static_type_check_term(Src,Term,Type)
4648         <=>
4649                 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
4650
4651 :- chr_constraint static_type_check_var/3.
4652 :- chr_option(mode,static_type_check_var(?,-,?)).
4653 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)).
4654
4655 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
4656         <=>
4657                 functor(AType,F,A),
4658                 functor(Type,F,A)
4659         |
4660                 copy_term_nat(AType-ADef,Type-Def),
4661                 static_type_check_var(Src,Var,Def).
4662
4663 static_type_check_var(Src,Var,Type)
4664         <=>
4665                 atomic_builtin_type(Type,_,_)
4666         |
4667                 static_atomic_builtin_type_check_var(Src,Var,Type).
4668
4669 static_type_check_var(Src,Var,Type)
4670         <=>
4671                 compound_builtin_type(Type,_,_)
4672         |
4673                 true.
4674
4675
4676 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
4677         <=>
4678                 Type1 \== Type2
4679         |
4680                 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
4681
4682 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4683 %%      static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type)
4684 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4685 :- chr_constraint static_atomic_builtin_type_check_var/3.
4686 :- chr_option(mode,static_type_check_var(?,-,+)).
4687 :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)).
4688
4689 static_atomic_builtin_type_check_var(_,_,any) <=> true.
4690 static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType)
4691         <=>
4692                 true.
4693 static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number)
4694         <=>
4695                 true.
4696 static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number)
4697         <=>
4698                 true.
4699 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number)
4700         <=>
4701                 true.
4702 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number)
4703         <=>
4704                 true.
4705 static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int)
4706         <=>
4707                 true.
4708 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int)
4709         <=>
4710                 true.
4711 static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural)
4712         <=>
4713                 true.
4714 static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2)
4715         <=>
4716                 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
4717
4718 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4719 %%      format_src(+type_error_src) is det.
4720 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4721 format_src(head(Head)) :- format('head ~w',[Head]).
4722 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
4723
4724 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4725 % Dynamic type checking
4726 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4727
4728 :- chr_constraint
4729         dynamic_type_check/0,
4730         dynamic_type_check_clauses/1,
4731         get_dynamic_type_check_clauses/1.
4732
4733 generate_dynamic_type_check_clauses(Clauses) :-
4734         ( chr_pp_flag(debugable,on) ->
4735                 dynamic_type_check,
4736                 get_dynamic_type_check_clauses(Clauses0),
4737                 append(Clauses0,
4738                                 [('$dynamic_type_check'(Type,Term) :-
4739                                         throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
4740                                 )],
4741                                 Clauses)
4742         ;
4743                 Clauses = []
4744         ).
4745
4746 type_definition(T,D), dynamic_type_check
4747         ==>
4748                 copy_term_nat(T-D,Type-Definition),
4749                 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
4750                 dynamic_type_check_clauses(DynamicChecks).
4751 type_alias(A,B), dynamic_type_check
4752         ==>
4753                 copy_term_nat(A-B,Alias-Body),
4754                 dynamic_type_check_alias_clause(Alias,Body,Clause),
4755                 dynamic_type_check_clauses([Clause]).
4756
4757 dynamic_type_check <=>
4758         findall(
4759                         ('$dynamic_type_check'(Type,Term) :- Goal),
4760                         ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ),
4761                         BuiltinChecks
4762         ),
4763         dynamic_type_check_clauses(BuiltinChecks).
4764
4765 dynamic_type_check_clause(T,DC,Clause) :-
4766         copy_term(T-DC,Type-DefinitionClause),
4767         functor(DefinitionClause,F,A),
4768         functor(Term,F,A),
4769         DefinitionClause =.. [_|DCArgs],
4770         Term =.. [_|TermArgs],
4771         maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
4772         list2conj(RecursiveCallList,RecursiveCalls),
4773         Clause = (
4774                         '$dynamic_type_check'(Type,Term) :-
4775                                 RecursiveCalls
4776         ).
4777
4778 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
4779         Clause = (
4780                         '$dynamic_type_check'(Alias,Term) :-
4781                                 '$dynamic_type_check'(Body,Term)
4782         ).
4783
4784 dynamic_type_check_call(Type,Term,Call) :-
4785         % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) ->
4786         %       Call = when(nonvar(Term),Goal)
4787         % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) ->
4788         %       Call = when(nonvar(Term),Goal)
4789         % ;
4790                 ( Type == any ->
4791                         Call = true
4792                 ;
4793                         Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term)))
4794                 )
4795         % )
4796         .
4797
4798 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
4799         <=>
4800                 append(C1,C2,C),
4801                 dynamic_type_check_clauses(C).
4802
4803 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
4804         <=>
4805                 Q = C.
4806 get_dynamic_type_check_clauses(Q)
4807         <=>
4808                 Q = [].
4809
4810 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4811 % Atomic Types
4812 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4813 % Some optimizations can be applied for atomic types...
4814 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4815
4816 atomic_types_suspended_constraint(C) :-
4817         C = _/N,
4818         get_constraint_type(C,ArgTypes),
4819         get_constraint_mode(C,ArgModes),
4820         findall(I,between(1,N,I),Indexes),
4821         maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
4822
4823 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
4824         ( is_indexed_argument(C,Index) ->
4825                 ( Mode == (?) ->
4826                         atomic_type(Type)
4827                 ;
4828                         true
4829                 )
4830         ;
4831                 true
4832         ).
4833
4834 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4835 %%      atomic_type(+Type) is semidet.
4836 %
4837 %       Succeeds when all values of =Type= are atomic.
4838 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
4839 :- chr_constraint atomic_type/1.
4840
4841 atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any.
4842
4843 type_definition(TypePat,Def) \ atomic_type(Type)
4844         <=>
4845                 functor(Type,F,A), functor(TypePat,F,A)
4846         |
4847                 forall(member(Term,Def),atomic(Term)).
4848
4849 type_alias(TypePat,Alias) \ atomic_type(Type)
4850         <=>
4851                 functor(Type,F,A), functor(TypePat,F,A)
4852         |
4853                 atomic(Alias),
4854                 copy_term_nat(TypePat-Alias,Type-NType),
4855                 atomic_type(NType).
4856
4857 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4858
4859 :- chr_constraint
4860         stored/3, % constraint,occurrence,(yes/no/maybe)
4861         stored_completing/3,
4862         stored_complete/3,
4863         is_stored/1,
4864         is_finally_stored/1,
4865         check_all_passive/2.
4866
4867 :- chr_option(mode,stored(+,+,+)).
4868 :- chr_option(type_declaration,stored(any,int,storedinfo)).
4869 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
4870 :- chr_option(mode,stored_complete(+,+,+)).
4871 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
4872 :- chr_option(mode,guard_list(+,+,+,+)).
4873 :- chr_option(mode,check_all_passive(+,+)).
4874
4875 % change yes in maybe when yes becomes passive
4876 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
4877         stored(C,O,yes), stored_complete(C,RO,Yesses)
4878         <=> O < RO | NYesses is Yesses - 1,
4879         stored(C,O,maybe), stored_complete(C,RO,NYesses).
4880 % change yes in maybe when not observed
4881 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
4882         <=> O < RO |
4883         NYesses is Yesses - 1,
4884         stored(C,O,maybe), stored_complete(C,RO,NYesses).
4885
4886 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
4887         ==> RO =< MO2 |  % C2 is never stored
4888         passive(RuleNb,ID).
4889
4890
4891
4892
4893 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4894
4895 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4896     Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
4897     append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
4898
4899 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4900     Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
4901     check_all_passive(RuleNb,IDs2).
4902
4903 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
4904     check_all_passive(RuleNb,IDs).
4905
4906 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
4907     chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
4908
4909 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4910
4911 % collect the storage information
4912 stored(C,O,yes) \ stored_completing(C,O,Yesses)
4913         <=> NO is O + 1, NYesses is Yesses + 1,
4914             stored_completing(C,NO,NYesses).
4915 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
4916         <=> NO is O + 1,
4917             stored_completing(C,NO,Yesses).
4918
4919 stored(C,O,no) \ stored_completing(C,O,Yesses)
4920         <=> stored_complete(C,O,Yesses).
4921 stored_completing(C,O,Yesses)
4922         <=> stored_complete(C,O,Yesses).
4923
4924 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
4925         O2 > O | passive(RuleNb,Id).
4926
4927 % decide whether a constraint is stored
4928 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
4929         <=> RO =< MO | fail.
4930 is_stored(C) <=>  true.
4931
4932 % decide whether a constraint is suspends after occurrences
4933 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
4934         <=> RO =< MO | fail.
4935 is_finally_stored(C) <=>  true.
4936
4937 storage_analysis(Constraints) :-
4938         ( chr_pp_flag(storage_analysis,on) ->
4939                 check_constraint_storages(Constraints)
4940         ;
4941                 true
4942         ).
4943
4944 check_constraint_storages([]).
4945 check_constraint_storages([C|Cs]) :-
4946         check_constraint_storage(C),
4947         check_constraint_storages(Cs).
4948
4949 check_constraint_storage(C) :-
4950         get_max_occurrence(C,MO),
4951         check_occurrences_storage(C,1,MO).
4952
4953 check_occurrences_storage(C,O,MO) :-
4954         ( O > MO ->
4955                 stored_completing(C,1,0)
4956         ;
4957                 check_occurrence_storage(C,O),
4958                 NO is O + 1,
4959                 check_occurrences_storage(C,NO,MO)
4960         ).
4961
4962 check_occurrence_storage(C,O) :-
4963         get_occurrence(C,O,RuleNb,ID),
4964         ( is_passive(RuleNb,ID) ->
4965                 stored(C,O,maybe)
4966         ;
4967                 get_rule(RuleNb,PragmaRule),
4968                 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
4969                 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4970                         check_storage_head1(Head1,O,Heads1,Heads2,Guard)
4971                 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4972                         check_storage_head2(Head2,O,Heads1,Body)
4973                 )
4974         ).
4975
4976 check_storage_head1(Head,O,H1,H2,G) :-
4977         functor(Head,F,A),
4978         C = F/A,
4979         ( H1 == [Head],
4980           H2 == [],
4981           guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
4982           Head =.. [_|L],
4983           no_matching(L,[]) ->
4984                 stored(C,O,no)
4985         ;
4986                 stored(C,O,maybe)
4987         ).
4988
4989 no_matching([],_).
4990 no_matching([X|Xs],Prev) :-
4991         var(X),
4992         \+ memberchk_eq(X,Prev),
4993         no_matching(Xs,[X|Prev]).
4994
4995 check_storage_head2(Head,O,H1,B) :-
4996         functor(Head,F,A),
4997         C = F/A,
4998         ( %(
4999                 ( H1 \== [], B == true )
5000           %;
5001           % \+ is_observed(F/A,O)  % always fails because observation analysis has not been performed yet
5002           %)
5003         ->
5004                 stored(C,O,maybe)
5005         ;
5006                 stored(C,O,yes)
5007         ).
5008
5009 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5010
5011 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5012 %%  ____        _         ____                      _ _       _   _
5013 %% |  _ \ _   _| | ___   / ___|___  _ __ ___  _ __ (_) | __ _| |_(_) ___  _ __
5014 %% | |_) | | | | |/ _ \ | |   / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
5015 %% |  _ <| |_| | |  __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
5016 %% |_| \_\\__,_|_|\___|  \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
5017 %%                                           |_|
5018
5019 constraints_code(Constraints,Clauses) :-
5020         (chr_pp_flag(reduced_indexing,on),
5021                     \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
5022             none_suspended_on_variables
5023         ;
5024             true
5025         ),
5026         constraints_code1(Constraints,Clauses,[]).
5027
5028 %===============================================================================
5029 :- chr_constraint constraints_code1/3.
5030 :- chr_option(mode,constraints_code1(+,+,+)).
5031 :- chr_option(type_declaration,constraints_code(list,any,any)).
5032 %-------------------------------------------------------------------------------
5033 constraints_code1([],L,T) <=> L = T.
5034 constraints_code1([C|RCs],L,T)
5035         <=>
5036                 constraint_code(C,L,T1),
5037                 constraints_code1(RCs,T1,T).
5038 %===============================================================================
5039 :- chr_constraint constraint_code/3.
5040 :- chr_option(mode,constraint_code(+,+,+)).
5041 %-------------------------------------------------------------------------------
5042 %%      Generate code for a single CHR constraint
5043 constraint_code(Constraint, L, T)
5044         <=>     true
5045         |       ( (chr_pp_flag(debugable,on) ;
5046                   is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
5047                   ( may_trigger(Constraint) ;
5048                     get_allocation_occurrence(Constraint,AO),
5049                     get_max_occurrence(Constraint,MO), MO >= AO ) )
5050                    ->
5051                         constraint_prelude(Constraint,Clause),
5052                         L = [Clause | L1]
5053                 ;
5054                         L = L1
5055                 ),
5056                 Id = [0],
5057                 occurrences_code(Constraint,1,Id,NId,L1,L2),
5058                 gen_cond_attach_clause(Constraint,NId,L2,T).
5059
5060 %===============================================================================
5061 %%      Generate prelude predicate for a constraint.
5062 %%      f(...) :- f/a_0(...,Susp).
5063 constraint_prelude(F/A, Clause) :-
5064         vars_susp(A,Vars,Susp,VarsSusp),
5065         Head =.. [ F | Vars],
5066         make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
5067         build_head(F,A,[0],VarsSusp,Delegate),
5068         ( chr_pp_flag(debugable,on) ->
5069                 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
5070                 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
5071                 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5072                 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
5073
5074                 ( get_constraint_type(F/A,ArgTypeList) ->
5075                         maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
5076                         list2conj(DynamicTypeCheckList,DynamicTypeChecks)
5077                 ;
5078                         DynamicTypeChecks = true
5079                 ),
5080
5081                 Clause =
5082                         ( Head :-
5083                                 DynamicTypeChecks,
5084                                 InsertGoal,
5085                                 InsertCall,
5086                                 AttachCall,
5087                                 Inactive,
5088                                 'chr debug_event'(insert(Head#Susp)),
5089                                 (
5090                                         'chr debug_event'(call(Susp)),
5091                                         Delegate
5092                                 ;
5093                                         'chr debug_event'(fail(Susp)), !,
5094                                         fail
5095                                 ),
5096                                 (
5097                                         'chr debug_event'(exit(Susp))
5098                                 ;
5099                                         'chr debug_event'(redo(Susp)),
5100                                         fail
5101                                 )
5102                         )
5103         ; get_allocation_occurrence(F/A,0) ->
5104                 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
5105                 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
5106                 Clause = ( Head  :- Goal, Inactive, Delegate )
5107         ;
5108                 Clause = ( Head  :- Delegate )
5109         ).
5110
5111 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
5112         ( may_trigger(F/A) ->
5113                 build_head(F,A,[0],VarsSusp,Delegate),
5114                 ( chr_pp_flag(debugable,off) ->
5115                         Goal = Delegate
5116                 ;
5117                         get_target_module(Mod),
5118                         Goal = Mod:Delegate
5119                 )
5120         ;
5121                 Goal = true
5122         ).
5123
5124 %===============================================================================
5125 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
5126 :- chr_option(mode,has_active_occurrence(+)).
5127 :- chr_option(mode,has_active_occurrence(+,+)).
5128 %-------------------------------------------------------------------------------
5129 has_active_occurrence(C) <=> has_active_occurrence(C,1).
5130
5131 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
5132         O > MO | fail.
5133 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
5134         has_active_occurrence(C,O) <=>
5135         NO is O + 1,
5136         has_active_occurrence(C,NO).
5137 has_active_occurrence(C,O) <=> true.
5138 %===============================================================================
5139
5140 gen_cond_attach_clause(F/A,Id,L,T) :-
5141         ( is_finally_stored(F/A) ->
5142                 get_allocation_occurrence(F/A,AllocationOccurrence),
5143                 get_max_occurrence(F/A,MaxOccurrence),
5144                 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
5145                         ( only_ground_indexed_arguments(F/A) ->
5146                                 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
5147                         ;
5148                                 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
5149                         )
5150                 ;       vars_susp(A,Args,Susp,AllArgs),
5151                         gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
5152                 ),
5153                 build_head(F,A,Id,AllArgs,Head),
5154                 Clause = ( Head :- Body ),
5155                 L = [Clause | T]
5156         ;
5157                 L = T
5158         ).
5159
5160 :- chr_constraint use_auxiliary_predicate/1.
5161 :- chr_option(mode,use_auxiliary_predicate(+)).
5162
5163 :- chr_constraint use_auxiliary_predicate/2.
5164 :- chr_option(mode,use_auxiliary_predicate(+,+)).
5165
5166 :- chr_constraint is_used_auxiliary_predicate/1.
5167 :- chr_option(mode,is_used_auxiliary_predicate(+)).
5168
5169 :- chr_constraint is_used_auxiliary_predicate/2.
5170 :- chr_option(mode,is_used_auxiliary_predicate(+,+)).
5171
5172
5173 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
5174
5175 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
5176
5177 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
5178
5179 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
5180
5181 is_used_auxiliary_predicate(P) <=> fail.
5182
5183 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
5184 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
5185
5186 is_used_auxiliary_predicate(P,C) <=> fail.
5187
5188 %------------------------------------------------------------------------------%
5189 % Only generate import statements for actually used modules.
5190 %------------------------------------------------------------------------------%
5191
5192 :- chr_constraint use_auxiliary_module/1.
5193 :- chr_option(mode,use_auxiliary_module(+)).
5194
5195 :- chr_constraint is_used_auxiliary_module/1.
5196 :- chr_option(mode,is_used_auxiliary_module(+)).
5197
5198
5199 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
5200
5201 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
5202
5203 is_used_auxiliary_module(P) <=> fail.
5204
5205         % only called for constraints with
5206         % at least one
5207         % non-ground indexed argument
5208 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
5209         vars_susp(A,Args,Susp,AllArgs),
5210         make_suspension_continuation_goal(F/A,AllArgs,Closure),
5211         ( get_store_type(F/A,var_assoc_store(_,_)) ->
5212                 Attach = true
5213         ;
5214                 attach_constraint_atom(F/A,Vars,Susp,Attach)
5215         ),
5216         FTerm =.. [F|Args],
5217         insert_constraint_goal(F/A,Susp,Args,InsertCall),
5218         insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
5219         ( may_trigger(F/A) ->
5220                 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
5221                 Goal =
5222                 (
5223                         ( var(Susp) ->
5224                                 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
5225                                 InsertCall,
5226                                 Attach
5227                         ;
5228                                 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
5229                         )
5230                 )
5231         ;
5232                 Goal =
5233                 (
5234                         InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
5235                         InsertCall,
5236                         Attach
5237                 )
5238         ).
5239
5240 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
5241         vars_susp(A,Args,Susp,AllArgs),
5242         make_suspension_continuation_goal(F/A,AllArgs,Cont),
5243         ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
5244                 attach_constraint_atom(F/A,Vars,Susp,Attach)
5245         ;
5246                 Attach = true
5247         ),
5248         FTerm =.. [F|Args],
5249         insert_constraint_goal(F/A,Susp,Args,InsertCall),
5250         insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
5251         ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
5252             Goal =
5253             (
5254                 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
5255                 InsertCall
5256             )
5257         ;
5258             Goal =
5259             (
5260                 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
5261                 InsertCall,
5262                 Attach
5263             )
5264         ).
5265
5266 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
5267         ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5268                 attach_constraint_atom(FA,Vars,Susp,Attach)
5269         ;
5270                 Attach = true
5271         ),
5272         insert_constraint_goal(FA,Susp,Args,InsertCall),
5273         ( chr_pp_flag(late_allocation,on) ->
5274                 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
5275         ;
5276                 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
5277         ).
5278
5279 %-------------------------------------------------------------------------------
5280 :- chr_constraint occurrences_code/6.
5281 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
5282 %-------------------------------------------------------------------------------
5283 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
5284          <=>    O > MO
5285         |       NId = Id, L = T.
5286 occurrences_code(C,O,Id,NId,L,T)
5287         <=>
5288                 occurrence_code(C,O,Id,Id1,L,L1),
5289                 NO is O + 1,
5290                 occurrences_code(C,NO,Id1,NId,L1,T).
5291 %-------------------------------------------------------------------------------
5292 :- chr_constraint occurrence_code/6.
5293 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
5294 %-------------------------------------------------------------------------------
5295 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
5296         <=>
5297                 ( named_history(RuleNb,_,_) ->
5298                         does_use_history(C,O)
5299                 ;
5300                         true
5301                 ),
5302                 NId = Id,
5303                 L = T.
5304 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
5305         <=>     true |
5306                 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
5307                 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
5308                         NId = Id,
5309                         head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
5310                 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
5311                         head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
5312                         inc_id(Id,NId),
5313                         ( unconditional_occurrence(C,O) ->
5314                                 L1 = T
5315                         ;
5316                                 gen_alloc_inc_clause(C,O,Id,L1,T)
5317                         )
5318                 ).
5319
5320 occurrence_code(C,O,_,_,_,_)
5321         <=>
5322                 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
5323 %-------------------------------------------------------------------------------
5324
5325 %%      Generate code based on one removed head of a CHR rule
5326 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5327         PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5328         Rule = rule(_,Head2,_,_),
5329         ( Head2 == [] ->
5330                 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5331                 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
5332         ;
5333                 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5334         ).
5335
5336 %% Generate code based on one persistent head of a CHR rule
5337 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
5338         PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
5339         Rule = rule(Head1,_,_,_),
5340         ( Head1 == [] ->
5341                 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
5342                 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
5343         ;
5344                 simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
5345         ).
5346
5347 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
5348         vars_susp(A,Vars,Susp,VarsSusp),
5349         build_head(F,A,Id,VarsSusp,Head),
5350         inc_id(Id,IncId),
5351         build_head(F,A,IncId,VarsSusp,CallHead),
5352         gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
5353         Clause =
5354         (
5355                 Head :-
5356                         ConditionalAlloc,
5357                         CallHead
5358         ),
5359         L = [Clause|T].
5360
5361 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
5362         get_allocation_occurrence(FA,AO),
5363         ( chr_pp_flag(debugable,off), O == AO ->
5364                 allocate_constraint_goal(FA,Susp,Vars,Goal0),
5365                 ( may_trigger(FA) ->
5366                         Goal = (var(Susp) -> Goal0 ; true)
5367                 ;
5368                         Goal = Goal0
5369                 )
5370         ;
5371                 Goal = true
5372         ).
5373
5374 gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :-
5375         get_allocation_occurrence(FA,AO),
5376         ( chr_pp_flag(debugable,off), O < AO ->
5377                 allocate_constraint_goal(FA,Susp,Vars,Goal0),
5378                 ( may_trigger(FA) ->
5379                         Goal = (var(Susp) -> Goal0 ; true)
5380                 ;
5381                         Goal = Goal0
5382                 )
5383         ;
5384                 Goal = true
5385         ).
5386
5387 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5388
5389 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5390 %
5391 % Reorders guard goals with respect to partner constraint retrieval goals and
5392 % active constraint. Returns combined partner retrieval + guard goal.
5393
5394 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
5395         ( chr_pp_flag(guard_via_reschedule,on) ->
5396                 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
5397                 list2conj(ScheduleSkeleton,GoalSkeleton)
5398         ;
5399                 length(Retrievals,RL), length(LookupSkeleton,RL),
5400                 length(GuardList,GL), length(GuardListSkeleton,GL),
5401                 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
5402                 list2conj(GoalListSkeleton,GoalSkeleton)
5403         ).
5404 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
5405         GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
5406         initialize_unit_dictionary(ActiveHead,Dict),
5407         maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
5408         maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
5409         build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
5410         dependency_reorder(Units,NUnits),
5411         wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
5412         sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
5413         snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
5414
5415 wrap_in_functor(Functor,X,Term) :-
5416         Term =.. [Functor,X].
5417
5418 wrappedunits2lists([],[],[],[]).
5419 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
5420         Ss = [GoalCopy|TSs],
5421         ( WrappedGoal = lookup(Goal) ->
5422                 Ls = [GoalCopy|TLs],
5423                 Gs = TGs
5424         ; WrappedGoal = guard(Goal) ->
5425                 Gs = [N-GoalCopy|TGs],
5426                 Ls = TLs
5427         ),
5428         wrappedunits2lists(Units,TGs,TLs,TSs).
5429
5430 guard_splitting(Rule,SplitGuardList) :-
5431         Rule = rule(H1,H2,Guard,_),
5432         append(H1,H2,Heads),
5433         conj2list(Guard,GuardList),
5434         term_variables(Heads,HeadVars),
5435         split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
5436         append(GuardPrefix,[RestGuard],SplitGuardList),
5437         term_variables(RestGuardList,GuardVars1),
5438         % variables that are declared to be ground don't need to be locked
5439         ground_vars(Heads,GroundVars),
5440         list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
5441         intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
5442         ( chr_pp_flag(guard_locks,on),
5443           bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
5444                 once(pairup(Locks,Unlocks,LocksUnlocks))
5445         ;
5446                 Locks = [],
5447                 Unlocks = []
5448         ),
5449         list2conj(Locks,LockPhase),
5450         list2conj(Unlocks,UnlockPhase),
5451         list2conj(RestGuardList,RestGuard1),
5452         RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
5453
5454 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
5455         Rule = rule(_,_,_,Body),
5456         my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
5457         my_term_copy(Body,VarDict2,BodyCopy).
5458
5459
5460 split_off_simple_guard_new([],_,[],[]).
5461 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
5462         ( simple_guard_new(G,VarDict) ->
5463                 S = [G|Ss],
5464                 split_off_simple_guard_new(Gs,VarDict,Ss,C)
5465         ;
5466                 S = [],
5467                 C = [G|Gs]
5468         ).
5469
5470 % simple guard: cheap and benign (does not bind variables)
5471 simple_guard_new(G,Vars) :-
5472         builtin_binds_b(G,BoundVars),
5473         \+ (( member(V,BoundVars),
5474               memberchk_eq(V,Vars)
5475            )).
5476
5477 dependency_reorder(Units,NUnits) :-
5478         dependency_reorder(Units,[],NUnits).
5479
5480 dependency_reorder([],Acc,Result) :-
5481         reverse(Acc,Result).
5482
5483 dependency_reorder([Unit|Units],Acc,Result) :-
5484         Unit = unit(_GID,_Goal,Type,GIDs),
5485         ( Type == fixed ->
5486                 NAcc = [Unit|Acc]
5487         ;
5488                 dependency_insert(Acc,Unit,GIDs,NAcc)
5489         ),
5490         dependency_reorder(Units,NAcc,Result).
5491
5492 dependency_insert([],Unit,_,[Unit]).
5493 dependency_insert([X|Xs],Unit,GIDs,L) :-
5494         X = unit(GID,_,_,_),
5495         ( memberchk(GID,GIDs) ->
5496                 L = [Unit,X|Xs]
5497         ;
5498                 L = [X | T],
5499                 dependency_insert(Xs,Unit,GIDs,T)
5500         ).
5501
5502 build_units(Retrievals,Guard,InitialDict,Units) :-
5503         build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
5504         build_guard_units(Guard,N,Dict,Tail).
5505
5506 build_retrieval_units([],N,N,Dict,Dict,L,L).
5507 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
5508         term_variables(U,Vs),
5509         update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
5510         L = [unit(N,U,fixed,GIDs)|L1],
5511         N1 is N + 1,
5512         build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
5513
5514 initialize_unit_dictionary(Term,Dict) :-
5515         term_variables(Term,Vars),
5516         pair_all_with(Vars,0,Dict).
5517
5518 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
5519 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
5520         ( lookup_eq(Dict,V,GID) ->
5521                 ( (GID == This ; memberchk(GID,GIDs) ) ->
5522                         GIDs1 = GIDs
5523                 ;
5524                         GIDs1 = [GID|GIDs]
5525                 ),
5526                 Dict1 = Dict
5527         ;
5528                 Dict1 = [V - This|Dict],
5529                 GIDs1 = GIDs
5530         ),
5531         update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
5532
5533 build_guard_units(Guard,N,Dict,Units) :-
5534         ( Guard = [Goal] ->
5535                 Units = [unit(N,Goal,fixed,[])]
5536         ; Guard = [Goal|Goals] ->
5537                 term_variables(Goal,Vs),
5538                 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
5539                 Units = [unit(N,Goal,movable,GIDs)|RUnits],
5540                 N1 is N + 1,
5541                 build_guard_units(Goals,N1,NDict,RUnits)
5542         ).
5543
5544 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
5545 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
5546         ( lookup_eq(Dict,V,GID) ->
5547                 ( (GID == This ; memberchk(GID,GIDs) ) ->
5548                         GIDs1 = GIDs
5549                 ;
5550                         GIDs1 = [GID|GIDs]
5551                 ),
5552                 Dict1 = [V - This|Dict]
5553         ;
5554                 Dict1 = [V - This|Dict],
5555                 GIDs1 = GIDs
5556         ),
5557         update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
5558
5559 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5560
5561 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5562 %%  ____       _     ____                             _   _
5563 %% / ___|  ___| |_  / ___|  ___ _ __ ___   __ _ _ __ | |_(_) ___ ___ _
5564 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
5565 %%  ___) |  __/ |_   ___) |  __/ | | | | | (_| | | | | |_| | (__\__ \_
5566 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
5567 %%
5568 %%  _   _       _                    ___        __
5569 %% | | | |_ __ (_) __ _ _   _  ___  |_ _|_ __  / _| ___ _ __ ___ _ __   ___ ___
5570 %% | | | | '_ \| |/ _` | | | |/ _ \  | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
5571 %% | |_| | | | | | (_| | |_| |  __/  | || | | |  _|  __/ | |  __/ | | | (_|  __/
5572 %%  \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_|  \___|_|  \___|_| |_|\___\___|
5573 %%                   |_|
5574 :- chr_constraint
5575         functional_dependency/4,
5576         get_functional_dependency/4.
5577
5578 :- chr_option(mode,functional_dependency(+,+,?,?)).
5579 :- chr_option(mode,get_functional_dependency(+,+,?,?)).
5580
5581 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
5582         <=>
5583                 RuleNb > 1, AO > O
5584         |
5585                 functional_dependency(C,1,Pattern,Key).
5586
5587 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
5588         <=>
5589                 RuleNb2 >= RuleNb1
5590         |
5591                 QPattern = Pattern, QKey = Key.
5592 get_functional_dependency(_,_,_,_)
5593         <=>
5594                 fail.
5595
5596 functional_dependency_analysis(Rules) :-
5597                 ( fail, chr_pp_flag(functional_dependency_analysis,on) ->
5598                         functional_dependency_analysis_main(Rules)
5599                 ;
5600                         true
5601                 ).
5602
5603 functional_dependency_analysis_main([]).
5604 functional_dependency_analysis_main([PRule|PRules]) :-
5605         ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
5606                 functional_dependency(C,RuleNb,Pattern,Key)
5607         ;
5608                 true
5609         ),
5610         functional_dependency_analysis_main(PRules).
5611
5612 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
5613         PragmaRule = pragma(Rule,_,_,Name,RuleNb),
5614         Rule = rule(H1,H2,Guard,_),
5615         ( H1 = [C1],
5616           H2 = [C2] ->
5617                 true
5618         ; H1 = [C1,C2],
5619           H2 == [] ->
5620                 true
5621         ),
5622         check_unique_constraints(C1,C2,Guard,RuleNb,List),
5623         term_variables(C1,Vs),
5624         \+ (
5625                 member(V1,Vs),
5626                 lookup_eq(List,V1,V2),
5627                 memberchk_eq(V2,Vs)
5628         ),
5629         select_pragma_unique_variables(Vs,List,Key1),
5630         copy_term_nat(C1-Key1,Pattern-Key),
5631         functor(C1,F,A).
5632
5633 select_pragma_unique_variables([],_,[]).
5634 select_pragma_unique_variables([V|Vs],List,L) :-
5635         ( lookup_eq(List,V,_) ->
5636                 L = T
5637         ;
5638                 L = [V|T]
5639         ),
5640         select_pragma_unique_variables(Vs,List,T).
5641
5642         % depends on functional dependency analysis
5643         % and shape of rule: C1 \ C2 <=> true.
5644 set_semantics_rules(Rules) :-
5645         ( fail, chr_pp_flag(set_semantics_rule,on) ->
5646                 set_semantics_rules_main(Rules)
5647         ;
5648                 true
5649         ).
5650
5651 set_semantics_rules_main([]).
5652 set_semantics_rules_main([R|Rs]) :-
5653         set_semantics_rule_main(R),
5654         set_semantics_rules_main(Rs).
5655
5656 set_semantics_rule_main(PragmaRule) :-
5657         PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
5658         ( Rule = rule([C1],[C2],true,_),
5659           IDs = ids([ID1],[ID2]),
5660           \+ is_passive(RuleNb,ID1),
5661           functor(C1,F,A),
5662           get_functional_dependency(F/A,RuleNb,Pattern,Key),
5663           copy_term_nat(Pattern-Key,C1-Key1),
5664           copy_term_nat(Pattern-Key,C2-Key2),
5665           Key1 == Key2 ->
5666                 passive(RuleNb,ID2)
5667         ;
5668                 true
5669         ).
5670
5671 check_unique_constraints(C1,C2,G,RuleNb,List) :-
5672         \+ any_passive_head(RuleNb),
5673         variable_replacement(C1-C2,C2-C1,List),
5674         copy_with_variable_replacement(G,OtherG,List),
5675         negate_b(G,NotG),
5676         once(entails_b(NotG,OtherG)).
5677
5678         % checks for rules of the shape ...,C1,C2... (<|=)=> ...
5679         % where C1 and C2 are symmteric constraints
5680 symmetry_analysis(Rules) :-
5681         ( chr_pp_flag(check_unnecessary_active,off) ->
5682                 true
5683         ;
5684                 symmetry_analysis_main(Rules)
5685         ).
5686
5687 symmetry_analysis_main([]).
5688 symmetry_analysis_main([R|Rs]) :-
5689         R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
5690         Rule = rule(H1,H2,_,_),
5691         ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] ->
5692                 symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb),
5693                 symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb)
5694         ;
5695                 true
5696         ),
5697         symmetry_analysis_main(Rs).
5698
5699 symmetry_analysis_heads_simplification([],[],_,_,_,_).
5700 symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
5701         ( \+ is_passive(RuleNb,ID),
5702           member2(PreHs,PreIDs,PreH-PreID),
5703           \+ is_passive(RuleNb,PreID),
5704           variable_replacement(PreH,H,List),
5705           copy_with_variable_replacement(Rule,Rule2,List),
5706           identical_guarded_rules(Rule,Rule2) ->
5707                 passive(RuleNb,ID)
5708         ;
5709                 true
5710         ),
5711         symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
5712
5713 symmetry_analysis_heads_propagation([],[],_,_,_,_).
5714 symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
5715         ( \+ is_passive(RuleNb,ID),
5716           member2(PreHs,PreIDs,PreH-PreID),
5717           \+ is_passive(RuleNb,PreID),
5718           variable_replacement(PreH,H,List),
5719           copy_with_variable_replacement(Rule,Rule2,List),
5720           identical_rules(Rule,Rule2) ->
5721                 passive(RuleNb,ID)
5722         ;
5723                 true
5724         ),
5725         symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
5726
5727 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5728
5729 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5730 %%  ____  _                 _ _  __ _           _   _
5731 %% / ___|(_)_ __ ___  _ __ | (_)/ _(_) ___ __ _| |_(_) ___  _ __
5732 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
5733 %%  ___) | | | | | | | |_) | | |  _| | (_| (_| | |_| | (_) | | | |
5734 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
5735 %%                   |_|
5736
5737 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
5738         PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
5739         head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
5740         build_head(F,A,Id,HeadVars,ClauseHead),
5741         get_constraint_mode(F/A,Mode),
5742         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
5743
5744
5745         guard_splitting(Rule,GuardList0),
5746         ( is_stored_in_guard(F/A, RuleNb) ->
5747                 GuardList = [Hole1|GuardList0]
5748         ;
5749                 GuardList = GuardList0
5750         ),
5751         guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
5752
5753         rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
5754
5755         guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
5756
5757         ( is_stored_in_guard(F/A, RuleNb) ->
5758                 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
5759                 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
5760                 GuardCopyList = [Hole1Copy|_],
5761                 Hole1Copy = (Allocation, Attachment)
5762         ;
5763                 true
5764         ),
5765
5766
5767         partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments),
5768         active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
5769
5770         ( chr_pp_flag(debugable,on) ->
5771                 Rule = rule(_,_,Guard,Body),
5772                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5773                 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
5774                 DebugTry   = 'chr debug_event'(  try(SortedSusps,[],DebugGuard,DebugBody)),
5775                 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
5776                 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
5777         ;
5778                 Cut = ActualCut
5779         ),
5780         ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
5781         Clause = ( ClauseHead :-
5782                         FirstMatching,
5783                         RescheduledTest,
5784                         Cut,
5785                         SuspsDetachments,
5786                         SuspDetachment,
5787                         BodyCopy
5788                 ),
5789         L = [Clause | T].
5790
5791 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5792 %%      head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det.
5793 %
5794 %       Return goal matching newly introduced variables with variables in
5795 %       previously looked-up heads.
5796 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5797 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
5798         head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
5799
5800 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5801 %%      head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det.
5802 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5803 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
5804         head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
5805         list2conj(GoalList,Goal).
5806
5807 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
5808 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
5809         ( var(Arg) ->
5810                 ( lookup_eq(VarDict,Arg,OtherVar) ->
5811                         ( Mode = (+) ->
5812                                 ( memberchk_eq(Arg,GroundVars) ->
5813                                         GoalList = [Var = OtherVar | RestGoalList],
5814                                         GroundVars1 = GroundVars
5815                                 ;
5816                                         GoalList = [Var == OtherVar | RestGoalList],
5817                                         GroundVars1 = [Arg|GroundVars]
5818                                 )
5819                         ;
5820                                 GoalList = [Var == OtherVar | RestGoalList],
5821                                 GroundVars1 = GroundVars
5822                         ),
5823                         VarDict1 = VarDict
5824                 ;
5825                         VarDict1 = [Arg-Var | VarDict],
5826                         GoalList = RestGoalList,
5827                         ( Mode = (+) ->
5828                                 GroundVars1 = [Arg|GroundVars]
5829                         ;
5830                                 GroundVars1 = GroundVars
5831                         )
5832                 ),
5833                 Pairs = Rest,
5834                 RestModes = Modes
5835         ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) ->
5836             identifier_label_atom(IndexType,Var,ActualArg,Goal),
5837             GoalList = [Goal|RestGoalList],
5838             VarDict = VarDict1,
5839             GroundVars1 = GroundVars,
5840             Pairs = Rest,
5841             RestModes = Modes
5842         ; atomic(Arg) ->
5843             ( Mode = (+) ->
5844                     GoalList = [ Var = Arg | RestGoalList]
5845             ;
5846                     GoalList = [ Var == Arg | RestGoalList]
5847             ),
5848             VarDict = VarDict1,
5849             GroundVars1 = GroundVars,
5850             Pairs = Rest,
5851             RestModes = Modes
5852         ; Mode == (+), is_ground(GroundVars,Arg)  ->
5853             copy_with_variable_replacement(Arg,ArgCopy,VarDict),
5854             GoalList = [ Var = ArgCopy | RestGoalList],
5855             VarDict = VarDict1,
5856             GroundVars1 = GroundVars,
5857             Pairs = Rest,
5858             RestModes = Modes
5859         ;   Arg =.. [_|Args],
5860             functor(Arg,Fct,N),
5861             functor(Term,Fct,N),
5862             Term =.. [_|Vars],
5863             ( Mode = (+) ->
5864                 GoalList = [ Var = Term | RestGoalList ]
5865             ;
5866                 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
5867             ),
5868             pairup(Args,Vars,NewPairs),
5869             append(NewPairs,Rest,Pairs),
5870             replicate(N,Mode,NewModes),
5871             append(NewModes,Modes,RestModes),
5872             VarDict1 = VarDict,
5873             GroundVars1 = GroundVars
5874         ),
5875         head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
5876
5877 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5878 % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det.
5879 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5880 add_heads_types([],VarTypes,VarTypes).
5881 add_heads_types([Head|Heads],VarTypes,NVarTypes) :-
5882         add_head_types(Head,VarTypes,VarTypes1),
5883         add_heads_types(Heads,VarTypes1,NVarTypes).
5884
5885 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5886 % add_head_types(+Head,+VarTypes,-NVarTypes) is det.
5887 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5888 add_head_types(Head,VarTypes,NVarTypes) :-
5889         functor(Head,F,A),
5890         get_constraint_type_det(F/A,ArgTypes),
5891         Head =.. [_|Args],
5892         add_args_types(Args,ArgTypes,VarTypes,NVarTypes).
5893
5894 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5895 % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det.
5896 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5897 add_args_types([],[],VarTypes,VarTypes).
5898 add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :-
5899         add_arg_types(Arg,Type,VarTypes,VarTypes1),
5900         add_args_types(Args,Types,VarTypes1,NVarTypes).
5901
5902 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5903 % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det.
5904 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5905 add_arg_types(Term,Type,VarTypes,NVarTypes) :-
5906         ( var(Term) ->
5907                 ( lookup_eq(VarTypes,Term,_) ->
5908                         NVarTypes = VarTypes
5909                 ;
5910                         NVarTypes = [Term-Type|VarTypes]
5911                 )
5912         ; ground(Term) ->
5913                 NVarTypes = VarTypes
5914         ; % TODO        improve approximation!
5915                 term_variables(Term,Vars),
5916                 length(Vars,VarNb),
5917                 replicate(VarNb,any,Types),
5918                 add_args_types(Vars,Types,VarTypes,NVarTypes)
5919         ).
5920
5921
5922
5923 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5924 %%      add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det.
5925 %
5926 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5927 add_heads_ground_variables([],GroundVars,GroundVars).
5928 add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :-
5929         add_head_ground_variables(Head,GroundVars,GroundVars1),
5930         add_heads_ground_variables(Heads,GroundVars1,NGroundVars).
5931
5932 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5933 %%      add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det.
5934 %
5935 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5936 add_head_ground_variables(Head,GroundVars,NGroundVars) :-
5937         functor(Head,F,A),
5938         get_constraint_mode(F/A,ArgModes),
5939         Head =.. [_|Args],
5940         add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars).
5941
5942
5943 add_arg_ground_variables([],[],GroundVars,GroundVars).
5944 add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :-
5945         ( Mode == (+) ->
5946                 term_variables(Arg,Vars),
5947                 add_var_ground_variables(Vars,GroundVars,GroundVars1)
5948         ;
5949                 GroundVars = GroundVars1
5950         ),
5951         add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars).
5952
5953 add_var_ground_variables([],GroundVars,GroundVars).
5954 add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :-
5955         ( memberchk_eq(Var,GroundVars) ->
5956                 GroundVars1 = GroundVars
5957         ;
5958                 GroundVars1 = [Var|GroundVars]
5959         ),
5960         add_var_ground_variables(Vars,GroundVars1,NGroundVars).
5961 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5962 %%      is_ground(+GroundVars,+Term) is semidet.
5963 %
5964 %       Determine whether =Term= is always ground.
5965 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
5966 is_ground(GroundVars,Term) :-
5967         ( ground(Term) ->
5968                 true
5969         ; compound(Term) ->
5970                 Term =.. [_|Args],
5971                 maplist(is_ground(GroundVars),Args)
5972         ;
5973                 memberchk_eq(Term,GroundVars)
5974         ).
5975
5976 %%      check_ground(+GroundVars,+Term,-Goal) is det.
5977 %
5978 %       Return runtime check to see whether =Term= is ground.
5979 check_ground(GroundVars,Term,Goal) :-
5980         term_variables(Term,Variables),
5981         check_ground_variables(Variables,GroundVars,Goal).
5982
5983 check_ground_variables([],_,true).
5984 check_ground_variables([Var|Vars],GroundVars,Goal) :-
5985         ( memberchk_eq(Var,GroundVars) ->
5986                 check_ground_variables(Vars,GroundVars,Goal)
5987         ;
5988                 Goal = (ground(Var), RGoal),
5989                 check_ground_variables(Vars,GroundVars,RGoal)
5990         ).
5991
5992 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
5993         rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
5994
5995 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
5996         ( Heads = [_|_] ->
5997                 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
5998         ;
5999                 GoalList = [],
6000                 Susps = [],
6001                 VarDict = NVarDict,
6002                 GroundVars = NGroundVars
6003         ).
6004
6005 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
6006 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
6007     [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
6008         functor(H,F,A),
6009         head_info(H,A,Vars,_,_,Pairs),
6010         get_store_type(F/A,StoreType),
6011         ( StoreType == default ->
6012                 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
6013                 delay_phase_end(validate_store_type_assumptions,
6014                         ( static_suspension_term(F/A,Suspension),
6015                           get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
6016                           get_static_suspension_field(F/A,Suspension,state,active,GetState)
6017                         )
6018                 ),
6019                 % create_get_mutable_ref(active,State,GetMutable),
6020                 get_constraint_mode(F/A,Mode),
6021                 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
6022                 NPairs = Pairs,
6023                 sbag_member_call(Susp,VarSusps,Sbag),
6024                 ExistentialLookup =     (
6025                                                 ViaGoal,
6026                                                 Sbag,
6027                                                 Susp = Suspension,              % not inlined
6028                                                 GetState
6029                                         )
6030         ;
6031                 delay_phase_end(validate_store_type_assumptions,
6032                         ( static_suspension_term(F/A,Suspension),
6033                           get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
6034                         )
6035                 ),
6036                 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
6037                 get_constraint_mode(F/A,Mode),
6038                 filter_mode(NPairs,Pairs,Mode,NMode),
6039                 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
6040         ),
6041         different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
6042         append(NPairs,VarDict1,DA_),            % order important here
6043         translate(GroundVars1,DA_,GroundVarsA),
6044         translate(GroundVars1,VarDict1,GroundVarsB),
6045         inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
6046         Goal =
6047         (
6048                 ExistentialLookup,
6049                 DiffSuspGoals,
6050                 MatchingGoal2
6051         ),
6052         rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
6053
6054 inline_matching_goal(A==B,true,GVA,GVB) :-
6055     memberchk_eq(A,GVA),
6056     memberchk_eq(B,GVB),
6057     A=B, !.
6058
6059 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
6060 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
6061     inline_matching_goal(A,A2,GVA,GVB),
6062     inline_matching_goal(B,B2,GVA,GVB).
6063 inline_matching_goal(X,X,_,_).
6064
6065
6066 filter_mode([],_,_,[]).
6067 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
6068         ( Var == V ->
6069                 Modes = [M|MT],
6070                 filter_mode(Rest,R,Ms,MT)
6071         ;
6072                 filter_mode([Arg-Var|Rest],R,Ms,Modes)
6073         ).
6074
6075 check_unique_keys([],_).
6076 check_unique_keys([V|Vs],Dict) :-
6077         lookup_eq(Dict,V,_),
6078         check_unique_keys(Vs,Dict).
6079
6080 % Generates tests to ensure the found constraint differs from previously found constraints
6081 %       TODO: detect more cases where constraints need be different
6082 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
6083         different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
6084         list2conj(DiffSuspGoalList,DiffSuspGoals).
6085
6086 different_from_other_susps_(_,[],_,_,[]) :- !.
6087 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
6088         ( functor(Head,F,A), functor(PreHead,F,A),
6089           copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
6090           \+ \+ PreHeadCopy = HeadCopy ->
6091
6092                 List = [Susp \== PreSusp | Tail]
6093         ;
6094                 List = Tail
6095         ),
6096         different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
6097
6098 % passive_head_via(in,in,in,in,out,out,out) :-
6099 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
6100         functor(Head,F,A),
6101         get_constraint_index(F/A,Pos),
6102         common_variables(Head,PrevHeads,CommonVars),
6103         global_list_store_name(F/A,Name),
6104         GlobalGoal = nb_getval(Name,AllSusps),
6105         get_constraint_mode(F/A,ArgModes),
6106         ( Vars == [] ->
6107                 Goal = GlobalGoal
6108         ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
6109                 translate([CommonVar],VarDict,[Var]),
6110                 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
6111                 Goal = AttrGoal
6112         ;
6113                 translate(CommonVars,VarDict,Vars),
6114                 add_heads_types(PrevHeads,[],TypeDict),
6115                 my_term_copy(TypeDict,VarDict,TypeDictCopy),
6116                 gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps),
6117                 Goal =
6118                         ( ViaGoal ->
6119                                 AttrGoal
6120                         ;
6121                                 GlobalGoal
6122                         )
6123         ).
6124
6125 common_variables(T,Ts,Vs) :-
6126         term_variables(T,V1),
6127         term_variables(Ts,V2),
6128         intersect_eq(V1,V2,Vs).
6129
6130 gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :-
6131         get_target_module(Mod),
6132         ( Vars = [A] ->
6133                 lookup_eq(TypeDict,A,Type),
6134                 ( atomic_type(Type) ->
6135                         ViaGoal = var(A),
6136                         A = V
6137                 ;
6138                         ViaGoal =  'chr newvia_1'(A,V)
6139                 )
6140         ; Vars = [A,B] ->
6141                 ViaGoal = 'chr newvia_2'(A,B,V)
6142         ;
6143                 ViaGoal = 'chr newvia'(Vars,V)
6144         ),
6145         AttrGoal =
6146         (   get_attr(V,Mod,TSusps),
6147             TSuspsEqSusps % TSusps = Susps
6148         ),
6149         get_max_constraint_index(N),
6150         ( N == 1 ->
6151                 TSuspsEqSusps = true, % TSusps = Susps
6152                 AllSusps = TSusps
6153         ;
6154                 TSuspsEqSusps = (TSusps = Susps),
6155                 get_constraint_index(FA,Pos),
6156                 make_attr(N,_,SuspsList,Susps),
6157                 nth1(Pos,SuspsList,AllSusps)
6158         ).
6159 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
6160         get_target_module(Mod),
6161         AttrGoal =
6162         (   get_attr(Var,Mod,TSusps),
6163             TSuspsEqSusps % TSusps = Susps
6164         ),
6165         get_max_constraint_index(N),
6166         ( N == 1 ->
6167                 TSuspsEqSusps = true, % TSusps = Susps
6168                 AllSusps = TSusps
6169         ;
6170                 TSuspsEqSusps = (TSusps = Susps),
6171                 get_constraint_index(FA,Pos),
6172                 make_attr(N,_,SuspsList,Susps),
6173                 nth1(Pos,SuspsList,AllSusps)
6174         ).
6175
6176 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
6177         guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
6178         list2conj(GuardCopyList,GuardCopy).
6179
6180 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
6181         Rule = rule(H,_,Guard,Body),
6182         conj2list(Guard,GuardList),
6183         split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
6184         my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
6185
6186         append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
6187         term_variables(RestGuardList,GuardVars),
6188         term_variables(RestGuardListCopyCore,GuardCopyVars),
6189         % variables that are declared to be ground don't need to be locked
6190         ground_vars(H,GroundVars),
6191         list_difference_eq(GuardVars,GroundVars,GuardVars_),
6192         ( chr_pp_flag(guard_locks,on),
6193           bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
6194                 X ^ (lists:member(X,GuardVars),         % X is a variable appearing in the original guard
6195                      pairlist:lookup_eq(VarDict,X,Y),            % translate X into new variable
6196                      memberchk_eq(Y,GuardCopyVars)      % redundant check? or multiple entries for X possible?
6197                     ),
6198                 LocksUnlocks) ->
6199                 once(pairup(Locks,Unlocks,LocksUnlocks))
6200         ;
6201                 Locks = [],
6202                 Unlocks = []
6203         ),
6204         list2conj(Locks,LockPhase),
6205         list2conj(Unlocks,UnlockPhase),
6206         list2conj(RestGuardListCopyCore,RestGuardCopyCore),
6207         RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
6208         my_term_copy(Body,VarDict2,BodyCopy).
6209
6210
6211 split_off_simple_guard([],_,[],[]).
6212 split_off_simple_guard([G|Gs],VarDict,S,C) :-
6213         ( simple_guard(G,VarDict) ->
6214                 S = [G|Ss],
6215                 split_off_simple_guard(Gs,VarDict,Ss,C)
6216         ;
6217                 S = [],
6218                 C = [G|Gs]
6219         ).
6220
6221 % simple guard: cheap and benign (does not bind variables)
6222 simple_guard(G,VarDict) :-
6223         binds_b(G,Vars),
6224         \+ (( member(V,Vars),
6225              lookup_eq(VarDict,V,_)
6226            )).
6227
6228 active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :-
6229         functor(Head,F,A),
6230         C = F/A,
6231         ( is_stored(C) ->
6232                 ( (Id == [0];
6233                   (get_allocation_occurrence(C,AO),
6234                    get_max_occurrence(C,MO),
6235                    MO < AO )),
6236                   only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) ->
6237                         SuspDetachment = true
6238                 ;
6239                         gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment),
6240                         ( chr_pp_flag(late_allocation,on) ->
6241                                 SuspDetachment =
6242                                         ( var(Susp) ->
6243                                                 true
6244                                         ;
6245                                                 UnCondSuspDetachment
6246                                         )
6247                         ;
6248                                 SuspDetachment = UnCondSuspDetachment
6249                         )
6250                 )
6251         ;
6252                 SuspDetachment = true
6253         ).
6254
6255 partner_constraint_detachments([],[],_,true).
6256 partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :-
6257    gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment),
6258    partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments).
6259
6260 gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :-
6261         functor(Head,F,A),
6262         C = F/A,
6263         ( is_stored(C) ->
6264              SuspDetachment = ( DebugEvent, RemoveInternalGoal),
6265              ( chr_pp_flag(debugable,on) ->
6266                 DebugEvent = 'chr debug_event'(remove(Susp))
6267              ;
6268                 DebugEvent = true
6269              ),
6270              remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal),
6271              delete_constraint_goal(Head,Susp,VarDict,DeleteCall),
6272              ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) ->
6273                 detach_constraint_atom(C,Vars,Susp,Detach)
6274              ;
6275                 Detach = true
6276              )
6277         ;
6278              SuspDetachment = true
6279         ).
6280
6281 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6282
6283 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6284 %%  ____  _                                   _   _               _
6285 %% / ___|(_)_ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __   / |
6286 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \  | |
6287 %%  ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
6288 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
6289 %%                   |_|          |___/
6290
6291 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :-
6292         PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
6293         Rule = rule(_Heads,Heads2,Guard,Body),
6294
6295         head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
6296         get_constraint_mode(F/A,Mode),
6297         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
6298
6299         build_head(F,A,Id,HeadVars,ClauseHead),
6300
6301         append(RestHeads,Heads2,Heads),
6302         append(OtherIDs,Heads2IDs,IDs),
6303         reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
6304
6305         guard_splitting(Rule,GuardList0),
6306         ( is_stored_in_guard(F/A, RuleNb) ->
6307                 GuardList = [Hole1|GuardList0]
6308         ;
6309                 GuardList = GuardList0
6310         ),
6311         guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
6312
6313         rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
6314         split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
6315
6316         guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
6317
6318         ( is_stored_in_guard(F/A, RuleNb) ->
6319                 gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation),
6320                 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_),
6321                 GuardCopyList = [Hole1Copy|_],
6322                 Hole1Copy = (Allocation, Attachment)
6323         ;
6324                 true
6325         ),
6326
6327         sort_by_key(Susps1,Susps1IDs,SortedSusps1),
6328         partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments),
6329         active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment),
6330
6331         ( chr_pp_flag(debugable,on) ->
6332                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6333                 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
6334                 sort_by_key(Susps2,Susps2IDs,KeptSusps),
6335                 DebugTry   = 'chr debug_event'(  try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
6336                 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
6337                 instrument_goal((!),DebugTry,DebugApply,Cut)
6338         ;
6339                 Cut = (!)
6340         ),
6341
6342    Clause = ( ClauseHead :-
6343                 FirstMatching,
6344                 RescheduledTest,
6345                 Cut,
6346                 SuspsDetachments,
6347                 SuspDetachment,
6348                 BodyCopy
6349             ),
6350    L = [Clause | T].
6351
6352 split_by_ids([],[],_,[],[]).
6353 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
6354         ( memberchk_eq(I,I1s) ->
6355                 S1s = [S | R1s],
6356                 S2s = R2s
6357         ;
6358                 S1s = R1s,
6359                 S2s = [S | R2s]
6360         ),
6361         split_by_ids(Is,Ss,I1s,R1s,R2s).
6362
6363 split_by_ids([],[],_,[],[],[],[]).
6364 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
6365         ( memberchk_eq(I,I1s) ->
6366                 S1s  = [S | R1s],
6367                 SI1s = [I|RSI1s],
6368                 S2s = R2s,
6369                 SI2s = RSI2s
6370         ;
6371                 S1s = R1s,
6372                 SI1s = RSI1s,
6373                 S2s = [S | R2s],
6374                 SI2s = [I|RSI2s]
6375         ),
6376         split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
6377 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6378
6379
6380 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6381 %%  ____  _                                   _   _               ____
6382 %% / ___|(_)_ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __   |___ \
6383 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \    __) |
6384 %%  ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | |  / __/
6385 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
6386 %%                   |_|          |___/
6387
6388 %% Genereate prelude + worker predicate
6389 %% prelude calls worker
6390 %% worker iterates over one type of removed constraints
6391 simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
6392    PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
6393    Rule = rule(Heads1,_,Guard,Body),
6394    append(Heads1,RestHeads2,Heads),
6395    append(IDs1,RestIDs,IDs),
6396    reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
6397    simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
6398    extend_id(Id,Id1),
6399    ( memberchk_eq(NID,IDs2) ->
6400         simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
6401    ;
6402         L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
6403    ),
6404    universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
6405    simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T).
6406
6407 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
6408 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
6409         Heads = [Head|RHeads],
6410         inc_id(Id,Id1),
6411         universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
6412         universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
6413         ( memberchk_eq(ID,IDs2) ->
6414                 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
6415         ;
6416                 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
6417         ).
6418
6419 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6420 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
6421         head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
6422         build_head(F,A,Id1,VarsSusp,ClauseHead),
6423         get_constraint_mode(F/A,Mode),
6424         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
6425
6426         lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps),
6427
6428         gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
6429
6430         extend_id(Id1,DelegateId),
6431         extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
6432         append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
6433         build_head(F,A,DelegateId,DelegateCallVars,Delegate),
6434
6435         PreludeClause =
6436            ( ClauseHead :-
6437                   FirstMatching,
6438                   ModConstraintsGoal,
6439                   !,
6440                   ConstraintAllocationGoal,
6441                   Delegate
6442            ),
6443         L = [PreludeClause|T].
6444
6445 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
6446         Term =.. [_|Args],
6447         delegate_variables(Term,Terms,VarDict,Args,Vars).
6448
6449 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
6450         term_variables(PrevTerms,PrevVars),
6451         delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
6452
6453 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
6454         term_variables(Term,V1),
6455         term_variables(Terms,V2),
6456         intersect_eq(V1,V2,V3),
6457         list_difference_eq(V3,PrevVars,V4),
6458         translate(V4,VarDict,Vars).
6459
6460
6461 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6462 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :-
6463         PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
6464         Rule = rule(_,_,Guard,Body),
6465         get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
6466
6467         gen_var(OtherSusp),
6468         gen_var(OtherSusps),
6469
6470         functor(CurrentHead,OtherF,OtherA),
6471         gen_vars(OtherA,OtherVars),
6472         head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
6473         get_constraint_mode(OtherF/OtherA,Mode),
6474         head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
6475
6476         delay_phase_end(validate_store_type_assumptions,
6477                 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
6478                   get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
6479                   get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
6480                 )
6481         ),
6482         % create_get_mutable_ref(active,State,GetMutable),
6483         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
6484         CurrentSuspTest = (
6485            OtherSusp = OtherSuspension,
6486            GetState,
6487            DiffSuspGoals,
6488            FirstMatching
6489         ),
6490
6491         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6492         build_head(F,A,Id,ClauseVars,ClauseHead),
6493
6494         guard_splitting(Rule,GuardList0),
6495         ( is_stored_in_guard(F/A, RuleNb) ->
6496                 GuardList = [Hole1|GuardList0]
6497         ;
6498                 GuardList = GuardList0
6499         ),
6500         guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
6501
6502         rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
6503         split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
6504         split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
6505
6506         partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments),
6507
6508         RecursiveVars = [OtherSusps|PreVarsAndSusps],
6509         build_head(F,A,Id,RecursiveVars,RecursiveCall),
6510         RecursiveVars2 = [[]|PreVarsAndSusps],
6511         build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
6512
6513         guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
6514         ( is_stored_in_guard(F/A, RuleNb) ->
6515                 GuardCopyList = [GuardAttachment|_] % once( ) ??
6516         ;
6517                 true
6518         ),
6519
6520         ( is_observed(F/A,O) ->
6521             gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
6522             gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
6523             gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
6524         ;
6525             Attachment = true,
6526             ConditionalRecursiveCall = RecursiveCall,
6527             ConditionalRecursiveCall2 = RecursiveCall2
6528         ),
6529
6530         ( chr_pp_flag(debugable,on) ->
6531                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6532                 DebugTry   = 'chr debug_event'(  try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
6533                 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
6534         ;
6535                 DebugTry = true,
6536                 DebugApply = true
6537         ),
6538
6539         ( is_stored_in_guard(F/A, RuleNb) ->
6540                 GuardAttachment = Attachment,
6541                 BodyAttachment = true
6542         ;
6543                 GuardAttachment = true,
6544                 BodyAttachment = Attachment     % will be true if not observed at all
6545         ),
6546
6547         ( member(unique(ID1,UniqueKeys), Pragmas),
6548           check_unique_keys(UniqueKeys,VarDict) ->
6549              Clause =
6550                 ( ClauseHead :-
6551                         ( CurrentSuspTest ->
6552                                 ( RescheduledTest,
6553                                   DebugTry ->
6554                                         DebugApply,
6555                                         Susps1Detachments,
6556                                         BodyAttachment,
6557                                         BodyCopy,
6558                                         ConditionalRecursiveCall2
6559                                 ;
6560                                         RecursiveCall2
6561                                 )
6562                         ;
6563                                 RecursiveCall
6564                         )
6565                 )
6566          ;
6567              Clause =
6568                         ( ClauseHead :-
6569                                 ( CurrentSuspTest,
6570                                   RescheduledTest,
6571                                   DebugTry ->
6572                                         DebugApply,
6573                                         Susps1Detachments,
6574                                         BodyAttachment,
6575                                         BodyCopy,
6576                                         ConditionalRecursiveCall
6577                                 ;
6578                                         RecursiveCall
6579                                 )
6580                         )
6581         ),
6582         L = [Clause | T].
6583
6584 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
6585         ( may_trigger(FA) ->
6586                 does_use_field(FA,generation),
6587                 delay_phase_end(validate_store_type_assumptions,
6588                         ( static_suspension_term(FA,Suspension),
6589                           get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
6590                           get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
6591                           get_static_suspension_term_field(arguments,FA,Suspension,Args)
6592                         )
6593                 )
6594         ;
6595                 delay_phase_end(validate_store_type_assumptions,
6596                         ( static_suspension_term(FA,Suspension),
6597                           get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
6598                           get_static_suspension_term_field(arguments,FA,Suspension,Args)
6599                         )
6600                 ),
6601                 GetGeneration = true
6602         ),
6603         ConditionalCall =
6604         (       Susp = Suspension,
6605                 GetState,
6606                 GetGeneration ->
6607                         UpdateState,
6608                         Call
6609                 ;
6610                         true
6611         ).
6612
6613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6614
6615
6616 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6617 %%  ____                                    _   _
6618 %% |  _ \ _ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __
6619 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
6620 %% |  __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
6621 %% |_|   |_|  \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
6622 %%                 |_|          |___/
6623
6624 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
6625         ( RestHeads == [] ->
6626                 propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T)
6627         ;
6628                 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
6629         ).
6630 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6631 %% Single headed propagation
6632 %% everything in a single clause
6633 propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
6634         head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
6635         build_head(F,A,Id,VarsSusp,ClauseHead),
6636
6637         inc_id(Id,NextId),
6638         build_head(F,A,NextId,VarsSusp,NextHead),
6639
6640         get_constraint_mode(F/A,Mode),
6641         head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
6642         guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
6643
6644         % - recursive call -
6645         RecursiveCall = NextHead,
6646
6647         ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
6648                 ActualCut = true
6649         ;
6650                 ActualCut = !
6651         ),
6652
6653         Rule = rule(_,_,Guard,Body),
6654         ( chr_pp_flag(debugable,on) ->
6655                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6656                 DebugTry   = 'chr debug_event'(  try([],[Susp],DebugGuard,DebugBody)),
6657                 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
6658                 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
6659         ;
6660                 Cut = ActualCut
6661         ),
6662         ( may_trigger(F/A), \+ has_no_history(RuleNb)->
6663                 use_auxiliary_predicate(novel_production),
6664                 use_auxiliary_predicate(extend_history),
6665                 does_use_history(F/A,O),
6666                 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
6667
6668                 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
6669                         % Tuple =.. [t,HistoryName,Susp]
6670                         Tuple = HistoryName
6671                 ;
6672                         Tuple = RuleNb
6673                 ),
6674
6675                 NovelProduction = '$novel_production'(Susp,Tuple),
6676                 ExtendHistory   = '$extend_history'(Susp,Tuple),
6677
6678                 ( is_observed(F/A,O) ->
6679                         gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
6680                         gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
6681                 ;
6682                         Attachment = true,
6683                         ConditionalRecursiveCall = RecursiveCall
6684                 )
6685         ;
6686                 Allocation = true,
6687                 NovelProduction = true,
6688                 ExtendHistory   = true,
6689
6690                 ( is_observed(F/A,O) ->
6691                         get_allocation_occurrence(F/A,AllocO),
6692                         ( O == AllocO ->
6693                                 gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp),
6694                                 Generation = 0
6695                         ;       % more room for improvement?
6696                                 Attachment = (Attachment1, Attachment2),
6697                                 gen_occ_allocation(F/A,O,Vars,Susp,Attachment1),
6698                                 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation)
6699                         ),
6700                         gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
6701                 ;
6702                         gen_occ_allocation(F/A,O,Vars,Susp,Attachment),
6703                         ConditionalRecursiveCall = RecursiveCall
6704                 )
6705         ),
6706         ( is_stored_in_guard(F/A, RuleNb) ->
6707                 GuardAttachment = Attachment,
6708                 BodyAttachment = true
6709         ;
6710                 GuardAttachment = true,
6711                 BodyAttachment = Attachment     % will be true if not observed at all
6712         ),
6713
6714         Clause = (
6715              ClauseHead :-
6716                 HeadMatching,
6717                 Allocation,
6718                 NovelProduction,
6719                 GuardAttachment,
6720                 GuardCopy,
6721                 Cut,
6722                 ExtendHistory,
6723                 BodyAttachment,
6724                 BodyCopy,
6725                 ConditionalRecursiveCall
6726         ),
6727         ProgramList = [Clause | ProgramTail].
6728
6729 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6730 %% multi headed propagation
6731 %% prelude + predicates to accumulate the necessary combinations of suspended
6732 %% constraints + predicate to execute the body
6733 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
6734    RestHeads = [First|Rest],
6735    propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
6736    extend_id(Id,ExtendedId),
6737    propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
6738
6739 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6740 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
6741         head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
6742         build_head(F,A,Id,VarsSusp,PreludeHead),
6743         get_constraint_mode(F/A,Mode),
6744         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars),
6745         Rule = rule(_,_,Guard,Body),
6746         extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
6747
6748         lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps),
6749
6750         gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
6751
6752         extend_id(Id,NestedId),
6753         append([Susps|VarsSusp],ExtraVars,NestedVars),
6754         build_head(F,A,NestedId,NestedVars,NestedHead),
6755         NestedCall = NestedHead,
6756
6757         Prelude = (
6758            PreludeHead :-
6759                FirstMatching,
6760                FirstSuspGoal,
6761                !,
6762                CondAllocation,
6763                NestedCall
6764         ),
6765         L = [Prelude|T].
6766
6767 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6768 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
6769    universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
6770    propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
6771
6772 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
6773    universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
6774    universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
6775    inc_id(Id,IncId),
6776    propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
6777
6778 %check_fd_lookup_condition(_,_,_,_) :- fail.
6779 check_fd_lookup_condition(F,A,_,_) :-
6780         get_store_type(F/A,global_singleton), !.
6781 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
6782         \+ may_trigger(F/A),
6783         get_functional_dependency(F/A,1,P,K),
6784         copy_term(P-K,CurrentHead-Key),
6785         term_variables(PreHeads,PreVars),
6786         intersect_eq(Key,PreVars,Key),!.
6787
6788 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
6789         Rule = rule(_,H2,Guard,Body),
6790         gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
6791         flatten(PreVarsAndSuspsList,PreVarsAndSusps),
6792         init(AllSusps,RestSusps),
6793         last(AllSusps,Susp),
6794         gen_var(OtherSusp),
6795         gen_var(OtherSusps),
6796         functor(CurrentHead,OtherF,OtherA),
6797         gen_vars(OtherA,OtherVars),
6798         delay_phase_end(validate_store_type_assumptions,
6799                 ( static_suspension_term(OtherF/OtherA,Suspension),
6800                   get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
6801                   get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
6802                 )
6803         ),
6804         % create_get_mutable_ref(active,State,GetMutable),
6805         CurrentSuspTest = (
6806            OtherSusp = Suspension,
6807            GetState
6808         ),
6809         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6810         build_head(F,A,Id,ClauseVars,ClauseHead),
6811         ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) ->      % iterator (OtherSusps) is empty at runtime
6812                 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
6813                 RecursiveVars = PreVarsAndSusps1
6814         ;
6815                 RecursiveVars = [OtherSusps|PreVarsAndSusps],
6816                 PrevId = Id
6817         ),
6818         build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
6819         RecursiveCall = RecursiveHead,
6820         CurrentHead =.. [_|OtherArgs],
6821         pairup(OtherArgs,OtherVars,OtherPairs),
6822         get_constraint_mode(OtherF/OtherA,Mode),
6823         head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
6824
6825         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
6826         guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
6827         get_occurrence(F/A,O,_,ID),
6828
6829         ( is_observed(F/A,O) ->
6830             init(FirstVarsSusp,FirstVars),
6831             gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation),
6832             gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
6833         ;
6834             Attachment = true,
6835             ConditionalRecursiveCall = RecursiveCall
6836         ),
6837         ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
6838                 NovelProduction = true,
6839                 ExtendHistory   = true
6840         ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
6841                 NovelProduction = true,
6842                 ExtendHistory   = true
6843         ;
6844                 get_occurrence(F/A,O,_,ID),
6845                 use_auxiliary_predicate(novel_production),
6846                 use_auxiliary_predicate(extend_history),
6847                 does_use_history(F/A,O),
6848                 ( named_history(RuleNb,HistoryName,HistoryIDs) ->
6849                         reverse([OtherSusp|RestSusps],NamedSusps),
6850                         named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps),
6851                         HistorySusps = [HistorySusp|_],
6852
6853                         ( length(HistoryIDs, 1) ->
6854                                 ExtendHistory = '$extend_history'(HistorySusp,HistoryName),
6855                                 NovelProduction = '$novel_production'(HistorySusp,HistoryName)
6856                         ;
6857                                 findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols),
6858                                 Tuple =.. [t,HistoryName|HistorySusps]
6859                         )
6860                 ;
6861                         HistorySusp = Susp,
6862                         findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
6863                         sort([ID|RestIDs],HistoryIDs),
6864                         history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
6865                         Tuple =.. [t,RuleNb|HistorySusps]
6866                 ),
6867
6868                 ( var(NovelProduction) ->
6869                         novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
6870                         ExtendHistory = '$extend_history'(HistorySusp,TupleVar),
6871                         NovelProduction = ( TupleVar = Tuple, NovelProductions)
6872                 ;
6873                         true
6874                 )
6875         ),
6876
6877
6878         ( chr_pp_flag(debugable,on) ->
6879                 Rule = rule(_,_,Guard,Body),
6880                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
6881                 get_occurrence(F/A,O,_,ID),
6882                 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
6883                 DebugTry   = 'chr debug_event'(  try([],KeptSusps,DebugGuard,DebugBody)),
6884                 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
6885         ;
6886                 DebugTry = true,
6887                 DebugApply = true
6888         ),
6889
6890         ( is_stored_in_guard(F/A, RuleNb) ->
6891                 GuardAttachment = Attachment,
6892                 BodyAttachment = true
6893         ;
6894                 GuardAttachment = true,
6895                 BodyAttachment = Attachment     % will be true if not observed at all
6896         ),
6897
6898    Clause = (
6899       ClauseHead :-
6900           (   CurrentSuspTest,
6901              DiffSuspGoals,
6902              Matching,
6903              NovelProduction,
6904              GuardAttachment,
6905              GuardCopy,
6906              DebugTry ->
6907              DebugApply,
6908              ExtendHistory,
6909              BodyAttachment,
6910              BodyCopy,
6911              ConditionalRecursiveCall
6912          ;   RecursiveCall
6913          )
6914    ),
6915    L = [Clause|T].
6916
6917 novel_production_calls([],[],[],_,_,true).
6918 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
6919         get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
6920         delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
6921         novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
6922
6923 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
6924         reverse(ReversedRestSusps,RestSusps),
6925         sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
6926
6927 named_history_susps([],_,_,[]).
6928 named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :-
6929         select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !,
6930         named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps).
6931
6932
6933
6934 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
6935    !,
6936    functor(Head,F,A),
6937    head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
6938    get_constraint_mode(F/A,Mode),
6939    head_arg_matches(HeadPairs,Mode,[],_,VarDict),
6940    extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
6941    append(VarsSusp,ExtraVars,HeadVars).
6942 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
6943         gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
6944         functor(Head,F,A),
6945         gen_var(Susps),
6946         head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
6947         get_constraint_mode(F/A,Mode),
6948         head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
6949         passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
6950         append(HeadVars,[Susp,Susps|Rest],VarsSusps).
6951
6952         % returns
6953         %       VarDict         for the copies of variables in the original heads
6954         %       VarsSuspsList   list of lists of arguments for the successive heads
6955         %       FirstVarsSusp   top level arguments
6956         %       SuspList        list of all suspensions
6957         %       Iterators       list of all iterators
6958 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
6959         !,
6960         functor(Head,F,A),
6961         head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),                    % make variables for argument positions
6962         get_constraint_mode(F/A,Mode),
6963         head_arg_matches(Pairs,Mode,[],_,VarDict),                              % copy variables inside arguments, build dictionary
6964         extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),      % decide what additional variables are needed
6965         append(VarsSusp,ExtraVars,HeadVars).                                    % add additional variables to head variables
6966 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
6967         gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
6968         functor(Head,F,A),
6969         gen_var(Susps),
6970         head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
6971         get_constraint_mode(F/A,Mode),
6972         head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
6973         passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
6974         append(HeadVars,[Susp,Susps],Vars).
6975
6976 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
6977         !,
6978         functor(Head,F,A),
6979         head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
6980         get_constraint_mode(F/A,Mode),
6981         head_arg_matches(Pairs,Mode,[],_,VarDict),
6982         extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
6983         append(VarsSusp,ExtraVars,HeadVars).
6984 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
6985         get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
6986         functor(Head,F,A),
6987         gen_var(Susps),
6988         head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
6989         get_constraint_mode(F/A,Mode),
6990         head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
6991         passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
6992         append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
6993
6994 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6995
6996 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6997 %%  ____               _             _   _                _
6998 %% |  _ \ __ _ ___ ___(_)_   _____  | | | | ___  __ _  __| |
6999 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
7000 %% |  __/ (_| \__ \__ \ |\ V /  __/ |  _  |  __/ (_| | (_| |
7001 %% |_|   \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
7002 %%
7003 %%  ____      _        _                 _
7004 %% |  _ \ ___| |_ _ __(_) _____   ____ _| |
7005 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
7006 %% |  _ <  __/ |_| |  | |  __/\ V / (_| | |
7007 %% |_| \_\___|\__|_|  |_|\___| \_/ \__,_|_|
7008 %%
7009 %%  ____                    _           _
7010 %% |  _ \ ___  ___  _ __ __| | ___ _ __(_)_ __   __ _
7011 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
7012 %% |  _ <  __/ (_) | | | (_| |  __/ |  | | | | | (_| |
7013 %% |_| \_\___|\___/|_|  \__,_|\___|_|  |_|_| |_|\__, |
7014 %%                                              |___/
7015
7016 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7017         ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
7018                 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
7019         ;
7020                 NRestHeads = RestHeads,
7021                 NRestIDs = RestIDs
7022         ).
7023
7024 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
7025         term_variables(Head,Vars),
7026         InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
7027         copy_term_nat(InitialData,InitialDataCopy),
7028         a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
7029         InitialDataCopy = InitialData,
7030         FinalData   = entry(RNRestHeads,RNRestIDs,_,_,_,_),
7031         reverse(RNRestHeads,NRestHeads),
7032         reverse(RNRestIDs,NRestIDs).
7033
7034 final_data(Entry) :-
7035         Entry = entry(_,_,_,_,[],_).
7036
7037 expand_data(Entry,NEntry,Cost) :-
7038         Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
7039         select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
7040         term_variables([Head1|Vars],Vars1),
7041         NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
7042         order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
7043
7044         % Assigns score to head based on known variables and heads to lookup
7045 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7046         functor(Head,F,A),
7047         get_store_type(F/A,StoreType),
7048         order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
7049
7050 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7051         term_variables(Head,HeadVars),
7052         term_variables(RestHeads,RestVars),
7053         order_score_vars(HeadVars,KnownVars,RestVars,Score).
7054 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7055         order_score_indexes(Indexes,Head,KnownVars,0,Score).
7056 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
7057         order_score_indexes(Indexes,Head,KnownVars,0,Score).
7058 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7059         term_variables(Head,HeadVars),
7060         term_variables(RestHeads,RestVars),
7061         order_score_vars(HeadVars,KnownVars,RestVars,Score_),
7062         Score is Score_ * 2.
7063 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
7064 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
7065         Score = 1.              % guaranteed O(1)
7066
7067 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7068         find_with_var_identity(
7069                 S,
7070                 t(Head,KnownVars,RestHeads),
7071                 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
7072                 Scores
7073         ),
7074         min_list(Scores,Score).
7075 order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7076         Score = 10.
7077 order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
7078         Score = 10.
7079
7080 order_score_indexes([],_,_,Score,NScore) :-
7081         Score > 0, NScore = 100.
7082 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
7083         multi_hash_key_args(I,Head,Args),
7084         ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
7085                 Score1 is Score + 1
7086         ;
7087                 Score1 = Score
7088         ),
7089         order_score_indexes(Is,Head,KnownVars,Score1,NScore).
7090
7091 order_score_vars(Vars,KnownVars,RestVars,Score) :-
7092         order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
7093         ( K-R-O == 0-0-0 ->
7094                 Score = 0
7095         ; K > 0 ->
7096                 Score is max(10 - K,0)
7097         ; R > 0 ->
7098                 Score is max(10 - R,1) * 10
7099         ;
7100                 Score is max(10-O,1) * 100
7101         ).
7102 order_score_count_vars([],_,_,0-0-0).
7103 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
7104         order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
7105         ( memberchk_eq(V,KnownVars) ->
7106                 NK is K + 1,
7107                 NR = R, NO = O
7108         ; memberchk_eq(V,RestVars) ->
7109                 NR is R + 1,
7110                 NK = K, NO = O
7111         ;
7112                 NO is O + 1,
7113                 NK = K, NR = R
7114         ).
7115
7116 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7117 %%  ___       _ _       _
7118 %% |_ _|_ __ | (_)_ __ (_)_ __   __ _
7119 %%  | || '_ \| | | '_ \| | '_ \ / _` |
7120 %%  | || | | | | | | | | | | | | (_| |
7121 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
7122 %%                              |___/
7123
7124 %% SWI begin
7125 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
7126 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
7127 %% SWI end
7128
7129 %% SICStus begin
7130 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
7131 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
7132 %% SICStus end
7133
7134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7135
7136 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7137 %%  _   _ _   _ _ _ _
7138 %% | | | | |_(_) (_) |_ _   _
7139 %% | | | | __| | | | __| | | |
7140 %% | |_| | |_| | | | |_| |_| |
7141 %%  \___/ \__|_|_|_|\__|\__, |
7142 %%                      |___/
7143
7144 %       Create a fresh variable.
7145 gen_var(_).
7146
7147 %       Create =N= fresh variables.
7148 gen_vars(N,Xs) :-
7149    length(Xs,N).
7150
7151 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
7152    vars_susp(A,Vars,Susp,VarsSusp),
7153    Head =.. [_|Args],
7154    pairup(Args,Vars,HeadPairs).
7155
7156 inc_id([N|Ns],[O|Ns]) :-
7157    O is N + 1.
7158 dec_id([N|Ns],[M|Ns]) :-
7159    M is N - 1.
7160
7161 extend_id(Id,[0|Id]).
7162
7163 next_id([_,N|Ns],[O|Ns]) :-
7164    O is N + 1.
7165
7166 build_head(F,A,Id,Args,Head) :-
7167    buildName(F,A,Id,Name),
7168    ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
7169         ( may_trigger(F/A) ;
7170                 get_allocation_occurrence(F/A,AO),
7171                 get_max_occurrence(F/A,MO),
7172         MO >= AO ) ) ->
7173            Head =.. [Name|Args]
7174    ;
7175            init(Args,ArgsWOSusp),       % XXX not entirely correct!
7176            Head =.. [Name|ArgsWOSusp]
7177   ).
7178
7179 buildName(Fct,Aty,List,Result) :-
7180    ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
7181    ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
7182    MO >= AO ) ; List \= [0])) ) ) ->
7183         atom_concat(Fct, (/) ,FctSlash),
7184         atomic_concat(FctSlash,Aty,FctSlashAty),
7185         buildName_(List,FctSlashAty,Result)
7186    ;
7187         Result = Fct
7188    ).
7189
7190 buildName_([],Name,Name).
7191 buildName_([N|Ns],Name,Result) :-
7192   buildName_(Ns,Name,Name1),
7193   atom_concat(Name1,'__',NameDash),    % '_' is a char :-(
7194   atomic_concat(NameDash,N,Result).
7195
7196 vars_susp(A,Vars,Susp,VarsSusp) :-
7197    length(Vars,A),
7198    append(Vars,[Susp],VarsSusp).
7199
7200 make_attr(N,Mask,SuspsList,Attr) :-
7201         length(SuspsList,N),
7202         Attr =.. [v,Mask|SuspsList].
7203
7204 or_pattern(Pos,Pat) :-
7205         Pow is Pos - 1,
7206         Pat is 1 << Pow.      % was 2 ** X
7207
7208 and_pattern(Pos,Pat) :-
7209         X is Pos - 1,
7210         Y is 1 << X,          % was 2 ** X
7211         Pat is (-1)*(Y + 1).
7212
7213 make_name(Prefix,F/A,Name) :-
7214         atom_concat_list([Prefix,F,(/),A],Name).
7215
7216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7217 % Storetype dependent lookup
7218
7219 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7220 %%      lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,
7221 %%                               -Goal,-SuspensionList) is det.
7222 %
7223 %       Create a universal lookup goal for given head.
7224 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7225 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
7226         functor(Head,F,A),
7227         get_store_type(F/A,StoreType),
7228         lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps).
7229
7230 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7231 %%      lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars,
7232 %%                               -Goal,-SuspensionList) is det.
7233 %
7234 %       Create a universal lookup goal for given head.
7235 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7236 lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7237         functor(Head,F,A),
7238         get_store_type(F/A,StoreType),
7239         lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps).
7240
7241 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7242 %%      lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict,
7243 %%                               +GroundVars,-Goal,-SuspensionList) is det.
7244 %
7245 %       Create a universal lookup goal for given head.
7246 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7247 lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :-
7248         functor(Head,F,A),
7249         passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps).
7250 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7251         hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
7252 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7253         hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_).
7254 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
7255         functor(Head,F,A),
7256         global_ground_store_name(F/A,StoreName),
7257         make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
7258         update_store_type(F/A,global_ground).
7259 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :-
7260         arg(VarIndex,Head,OVar),
7261         arg(KeyIndex,Head,OKey),
7262         translate([OVar,OKey],VarDict,[Var,Key]),
7263         get_target_module(Module),
7264         Goal = (
7265                 get_attr(Var,Module,AssocStore),
7266                 lookup_assoc_store(AssocStore,Key,AllSusps)
7267         ).
7268 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :-
7269         functor(Head,F,A),
7270         global_singleton_store_name(F/A,StoreName),
7271         make_get_store_goal(StoreName,Susp,GetStoreGoal),
7272         Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
7273         update_store_type(F/A,global_singleton).
7274 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7275         once((
7276                 member(ST,StoreTypes),
7277                 lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps)
7278         )).
7279 lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7280         functor(Head,F,A),
7281         arg(Index,Head,Var),
7282         translate([Var],VarDict,[KeyVar]),
7283         delay_phase_end(validate_store_type_assumptions,
7284                 identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal)
7285         ),
7286         update_store_type(F/A,identifier_store(Index)),
7287         get_identifier_index(F/A,Index,_).
7288 lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :-
7289         functor(Head,F,A),
7290         arg(Index,Head,Var),
7291         ( var(Var) ->
7292                 translate([Var],VarDict,[KeyVar]),
7293                 Goal = StructGoal
7294         ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) ->
7295                 lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal),
7296                 Goal = (LookupGoal,StructGoal)
7297         ),
7298         delay_phase_end(validate_store_type_assumptions,
7299                 type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal)
7300         ),
7301         update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)),
7302         get_type_indexed_identifier_index(IndexType,F/A,Index,_).
7303
7304 identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :-
7305         get_identifier_size(ISize),
7306         functor(Struct,struct,ISize),
7307         get_identifier_index(C,Index,IIndex),
7308         arg(IIndex,Struct,AllSusps),
7309         Goal = (KeyVar = Struct).
7310
7311 type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :-
7312         type_indexed_identifier_structure(IndexType,Struct),
7313         get_type_indexed_identifier_index(IndexType,C,Index,IIndex),
7314         arg(IIndex,Struct,AllSusps),
7315         Goal = (KeyVar = Struct).
7316
7317 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7318 %%      hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict,
7319 %%                               +GroundVars,-Goal,-SuspensionList,-Index) is det.
7320 %
7321 %       Create a universal hash lookup goal for given head.
7322 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7323 hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :-
7324         once((
7325                 member(Index,Indexes),
7326                 multi_hash_key_args(Index,Head,KeyArgs),
7327                 (
7328                         translate(KeyArgs,VarDict,KeyArgCopies)
7329                 ;
7330                         ground(KeyArgs), KeyArgCopies = KeyArgs
7331                 )
7332         )),
7333         ( KeyArgCopies = [KeyCopy] ->
7334                 true
7335         ;
7336                 KeyCopy =.. [k|KeyArgCopies]
7337         ),
7338         functor(Head,F,A),
7339         multi_hash_via_lookup_goal(F/A,Index,KeyCopy,AllSusps,LookupGoal),
7340
7341         check_ground(GroundVars,KeyArgs,OriginalGroundCheck),
7342         my_term_copy(OriginalGroundCheck,VarDict,GroundCheck),
7343
7344         Goal = (GroundCheck,LookupGoal),
7345
7346         ( HashType == inthash ->
7347                 update_store_type(F/A,multi_inthash([Index]))
7348         ;
7349                 update_store_type(F/A,multi_hash([Index]))
7350         ).
7351
7352 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7353 %%      existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict,
7354 %%                              +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
7355 %%                              +VarArgDict,-NewVarArgDict) is det.
7356 %
7357 %       Create existential lookup goal for given head.
7358 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7359 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
7360         lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps),
7361         sbag_member_call(Susp,AllSusps,Sbag),
7362         functor(Head,F,A),
7363         delay_phase_end(validate_store_type_assumptions,
7364                 ( static_suspension_term(F/A,SuspTerm),
7365                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7366                 )
7367         ),
7368         Goal = (
7369                 UniversalGoal,
7370                 Sbag,
7371                 Susp = SuspTerm,
7372                 GetState
7373         ).
7374 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
7375         functor(Head,F,A),
7376         global_singleton_store_name(F/A,StoreName),
7377         make_get_store_goal(StoreName,Susp,GetStoreGoal),
7378         Goal =  (
7379                         GetStoreGoal, % nb_getval(StoreName,Susp),
7380                         Susp \== [],
7381                         Susp = SuspTerm
7382                 ),
7383         update_store_type(F/A,global_singleton).
7384 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7385         once((
7386                 member(ST,StoreTypes),
7387                 existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs)
7388         )).
7389 existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7390         existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
7391 existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7392         existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs).
7393 existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7394         lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
7395         hash_index_filter(Pairs,Index,NPairs),
7396
7397         functor(Head,F,A),
7398         ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
7399                 Sbag = (AllSusps = [Susp])
7400         ;
7401                 sbag_member_call(Susp,AllSusps,Sbag)
7402         ),
7403         delay_phase_end(validate_store_type_assumptions,
7404                 ( static_suspension_term(F/A,SuspTerm),
7405                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7406                 )
7407         ),
7408         Goal =  (
7409                         LookupGoal,
7410                         Sbag,
7411                         Susp = SuspTerm,                % not inlined
7412                         GetState
7413         ).
7414 existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
7415         lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps),
7416         hash_index_filter(Pairs,Index,NPairs),
7417
7418         functor(Head,F,A),
7419         ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
7420                 Sbag = (AllSusps = [Susp])
7421         ;
7422                 sbag_member_call(Susp,AllSusps,Sbag)
7423         ),
7424         delay_phase_end(validate_store_type_assumptions,
7425                 ( static_suspension_term(F/A,SuspTerm),
7426                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7427                 )
7428         ),
7429         Goal =  (
7430                         LookupGoal,
7431                         Sbag,
7432                         Susp = SuspTerm,                % not inlined
7433                         GetState
7434         ).
7435 existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :-
7436         lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps),
7437         sbag_member_call(Susp,Susps,Sbag),
7438         functor(Head,F,A),
7439         delay_phase_end(validate_store_type_assumptions,
7440                 ( static_suspension_term(F/A,SuspTerm),
7441                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7442                 )
7443         ),
7444         Goal =  (
7445                         UGoal,
7446                         Sbag,
7447                         Susp = SuspTerm,                % not inlined
7448                         GetState
7449                 ).
7450
7451 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7452 %%      existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict,
7453 %%                              +GroundVariables,-SuspensionTerm,-Goal,-SuspVar,
7454 %%                              +VarArgDict,-NewVarArgDict) is det.
7455 %
7456 %       Create existential hash lookup goal for given head.
7457 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7458 existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :-
7459         hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index),
7460
7461         hash_index_filter(Pairs,Index,NPairs),
7462
7463         functor(Head,F,A),
7464         ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
7465                 Sbag = (AllSusps = [Susp])
7466         ;
7467                 sbag_member_call(Susp,AllSusps,Sbag)
7468         ),
7469         delay_phase_end(validate_store_type_assumptions,
7470                 ( static_suspension_term(F/A,SuspTerm),
7471                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
7472                 )
7473         ),
7474         Goal =  (
7475                         LookupGoal,
7476                         Sbag,
7477                         Susp = SuspTerm,                % not inlined
7478                         GetState
7479         ).
7480
7481 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7482 %%      hash_index_filter(+Pairs,+Index,-NPairs) is det.
7483 %
7484 %       Filter out pairs already covered by given hash index.
7485 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
7486 hash_index_filter(Pairs,Index,NPairs) :-
7487         ( integer(Index) ->
7488                 NIndex = [Index]
7489         ;
7490                 NIndex = Index
7491         ),
7492         hash_index_filter(Pairs,NIndex,1,NPairs).
7493
7494 hash_index_filter([],_,_,[]).
7495 hash_index_filter([P|Ps],Index,N,NPairs) :-
7496         ( Index = [I|Is] ->
7497                 NN is N + 1,
7498                 ( I > N ->
7499                         NPairs = [P|NPs],
7500                         hash_index_filter(Ps,[I|Is],NN,NPs)
7501                 ; I == N ->
7502                         hash_index_filter(Ps,Is,NN,NPairs)
7503                 )
7504         ;
7505                 NPairs = [P|Ps]
7506         ).
7507
7508 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7509 %------------------------------------------------------------------------------%
7510 %%      assume_constraint_stores(+ConstraintSymbols) is det.
7511 %
7512 %       Compute all constraint store types that are possible for the given
7513 %       =ConstraintSymbols=.
7514 %------------------------------------------------------------------------------%
7515 assume_constraint_stores([]).
7516 assume_constraint_stores([C|Cs]) :-
7517         ( chr_pp_flag(debugable,off),
7518           only_ground_indexed_arguments(C),
7519           is_stored(C),
7520           get_store_type(C,default) ->
7521                 get_indexed_arguments(C,IndexedArgs),
7522                 length(IndexedArgs,NbIndexedArgs),
7523                 % Construct Index Combinations
7524                 ( NbIndexedArgs > 10 ->
7525                         findall([Index],member(Index,IndexedArgs),Indexes)
7526                 ;
7527                         findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
7528                         predsort(longer_list,UnsortedIndexes,Indexes)
7529                 ),
7530                 % Choose Index Type
7531                 ( get_functional_dependency(C,1,Pattern,Key),
7532                   all_distinct_var_args(Pattern), Key == [] ->
7533                         assumed_store_type(C,global_singleton)
7534                 ;
7535                         get_constraint_type_det(C,ArgTypes),
7536                         partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes),
7537
7538                         ( IntHashIndexes = [] ->
7539                                 Stores = Stores1
7540                         ;
7541                                 Stores = [multi_inthash(IntHashIndexes)|Stores1]
7542                         ),
7543                         ( HashIndexes = [] ->
7544                                 Stores1 = Stores2
7545                         ;
7546                                 Stores1 = [multi_hash(HashIndexes)|Stores2]
7547                         ),
7548                         ( IdentifierIndexes = [] ->
7549                                 Stores2 = Stores3
7550                         ;
7551                                 maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes),
7552                                 append(WrappedIdentifierIndexes,Stores3,Stores2)
7553                         ),
7554                         append(CompoundIdentifierIndexes,Stores4,Stores3),
7555                         Stores4 = [global_ground],
7556                         assumed_store_type(C,multi_store(Stores))
7557                 )
7558         ;
7559                 true
7560         ),
7561         assume_constraint_stores(Cs).
7562
7563 %------------------------------------------------------------------------------%
7564 %%      partition_indexes(+Indexes,+Types,
7565 %%              -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det.
7566 %------------------------------------------------------------------------------%
7567 partition_indexes([],_,[],[],[],[]).
7568 partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :-
7569         ( Index = [I],
7570           nth(I,Types,Type),
7571           unalias_type(Type,UnAliasedType),
7572           UnAliasedType == chr_identifier ->
7573                 IdentifierIndexes = [I|RIdentifierIndexes],
7574                 IntHashIndexes = RIntHashIndexes,
7575                 HashIndexes = RHashIndexes,
7576                 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
7577         ; Index = [I],
7578           nth(I,Types,Type),
7579           unalias_type(Type,UnAliasedType),
7580           nonvar(UnAliasedType),
7581           UnAliasedType = chr_identifier(IndexType) ->
7582                 CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes],
7583                 IdentifierIndexes = RIdentifierIndexes,
7584                 IntHashIndexes = RIntHashIndexes,
7585                 HashIndexes = RHashIndexes
7586         ; Index = [I],
7587           nth(I,Types,Type),
7588           unalias_type(Type,UnAliasedType),
7589           UnAliasedType == dense_int ->
7590                 IntHashIndexes = [Index|RIntHashIndexes],
7591                 HashIndexes = RHashIndexes,
7592                 IdentifierIndexes = RIdentifierIndexes,
7593                 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
7594         ; member(I,Index),
7595           nth(I,Types,Type),
7596           unalias_type(Type,UnAliasedType),
7597           nonvar(UnAliasedType),
7598           UnAliasedType = chr_identifier(_) ->
7599                 % don't use chr_identifiers in hash indexes
7600                 IntHashIndexes = RIntHashIndexes,
7601                 HashIndexes = RHashIndexes,
7602                 IdentifierIndexes = RIdentifierIndexes,
7603                 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
7604         ;
7605                 IntHashIndexes = RIntHashIndexes,
7606                 HashIndexes = [Index|RHashIndexes],
7607                 IdentifierIndexes = RIdentifierIndexes,
7608                 CompoundIdentifierIndexes = RCompoundIdentifierIndexes
7609         ),
7610         partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes).
7611
7612 longer_list(R,L1,L2) :-
7613         length(L1,N1),
7614         length(L2,N2),
7615         compare(Rt,N2,N1),
7616         ( Rt == (=) ->
7617                 compare(R,L1,L2)
7618         ;
7619                 R = Rt
7620         ).
7621
7622 all_distinct_var_args(Term) :-
7623         Term =.. [_|Args],
7624         copy_term_nat(Args,NArgs),
7625         all_distinct_var_args_(NArgs).
7626
7627 all_distinct_var_args_([]).
7628 all_distinct_var_args_([X|Xs]) :-
7629         var(X),
7630         X = t,
7631         all_distinct_var_args_(Xs).
7632
7633 get_indexed_arguments(C,IndexedArgs) :-
7634         C = F/A,
7635         get_indexed_arguments(1,A,C,IndexedArgs).
7636
7637 get_indexed_arguments(I,N,C,L) :-
7638         ( I > N ->
7639                 L = []
7640         ;       ( is_indexed_argument(C,I) ->
7641                         L = [I|T]
7642                 ;
7643                         L = T
7644                 ),
7645                 J is I + 1,
7646                 get_indexed_arguments(J,N,C,T)
7647         ).
7648
7649 validate_store_type_assumptions([]).
7650 validate_store_type_assumptions([C|Cs]) :-
7651         validate_store_type_assumption(C),
7652         validate_store_type_assumptions(Cs).
7653
7654 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7655 % new code generation
7656 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
7657         Rule = rule(H1,_,Guard,Body),
7658         gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
7659         universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
7660         flatten(VarsAndSuspsList,VarsAndSusps),
7661         Vars = [ [] | VarsAndSusps],
7662         build_head(F,A,Id,Vars,Head),
7663         build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
7664         Clause = ( Head :- PredecessorCall),
7665         L = [Clause | T].
7666 %       ( H1 == [],
7667 %         functor(CurrentHead,CF,CA),
7668 %         check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
7669 %               L = T
7670 %       ;
7671 %               gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
7672 %               universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
7673 %               flatten(VarsAndSuspsList,VarsAndSusps),
7674 %               Vars = [ [] | VarsAndSusps],
7675 %               build_head(F,A,Id,Vars,Head),
7676 %               build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
7677 %               Clause = ( Head :- PredecessorCall),
7678 %               L = [Clause | T]
7679 %       ).
7680
7681         % skips back intelligently over global_singleton lookups
7682 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
7683         ( Id = [0|_] ->
7684                 next_id(Id,PrevId),
7685                 PrevVarsAndSusps = BaseCallArgs
7686         ;
7687                 VarsAndSuspsList = [_|AllButFirstList],
7688                 dec_id(Id,PrevId1),
7689                 ( PrevHeads  = [PrevHead|PrevHeads1],
7690                   functor(PrevHead,F,A),
7691                   check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
7692                         PrevIterators = [_|PrevIterators1],
7693                         universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
7694                 ;
7695                         PrevId = PrevId1,
7696                         flatten(AllButFirstList,AllButFirst),
7697                         PrevIterators = [PrevIterator|_],
7698                         PrevVarsAndSusps = [PrevIterator|AllButFirst]
7699                 )
7700         ).
7701
7702 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
7703         Rule = rule(_,_,Guard,Body),
7704         gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
7705         init(AllSusps,PreSusps),
7706         flatten(PreVarsAndSuspsList,PreVarsAndSusps),
7707         gen_var(OtherSusps),
7708         functor(CurrentHead,OtherF,OtherA),
7709         gen_vars(OtherA,OtherVars),
7710         head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
7711         get_constraint_mode(OtherF/OtherA,Mode),
7712         head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
7713
7714         delay_phase_end(validate_store_type_assumptions,
7715                 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
7716                   get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
7717                   get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
7718                 )
7719         ),
7720
7721         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
7722         % create_get_mutable_ref(active,State,GetMutable),
7723         CurrentSuspTest = (
7724            OtherSusp = OtherSuspension,
7725            GetState,
7726            DiffSuspGoals,
7727            FirstMatching
7728         ),
7729         add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars),
7730         lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps),
7731         inc_id(Id,NestedId),
7732         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
7733         build_head(F,A,Id,ClauseVars,ClauseHead),
7734         passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
7735         append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
7736         build_head(F,A,NestedId,NestedVars,NestedHead),
7737
7738         ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) ->      % iterator (OtherSusps) is empty at runtime
7739                 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
7740                 RecursiveVars = PreVarsAndSusps1
7741         ;
7742                 RecursiveVars = [OtherSusps|PreVarsAndSusps],
7743                 PrevId = Id
7744         ),
7745         build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
7746
7747         Clause = (
7748            ClauseHead :-
7749            (   CurrentSuspTest,
7750                NextSuspGoal
7751                ->
7752                NestedHead
7753            ;   RecursiveHead
7754            )
7755         ),
7756         L = [Clause|T].
7757
7758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7759
7760 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7761 % Observation Analysis
7762 %
7763 % CLASSIFICATION
7764 %   Enabled
7765 %
7766 % Analysis based on Abstract Interpretation paper.
7767 %
7768 % TODO:
7769 %   stronger analysis domain [research]
7770
7771 :- chr_constraint
7772         initial_call_pattern/1,
7773         call_pattern/1,
7774         call_pattern_worker/1,
7775         final_answer_pattern/2,
7776         abstract_constraints/1,
7777         depends_on/2,
7778         depends_on_ap/4,
7779         depends_on_goal/2,
7780         ai_observed_internal/2,
7781         % ai_observed/2,
7782         ai_not_observed_internal/2,
7783         ai_not_observed/2,
7784         ai_is_observed/2,
7785         depends_on_as/3,
7786         ai_observation_gather_results/0.
7787
7788 :- chr_type abstract_domain     --->    odom(program_point,list(constraint)).
7789 :- chr_type program_point       ==      any.
7790
7791 :- chr_option(mode,initial_call_pattern(+)).
7792 :- chr_option(type_declaration,call_pattern(abstract_domain)).
7793
7794 :- chr_option(mode,call_pattern(+)).
7795 :- chr_option(type_declaration,call_pattern(abstract_domain)).
7796
7797 :- chr_option(mode,call_pattern_worker(+)).
7798 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
7799
7800 :- chr_option(mode,final_answer_pattern(+,+)).
7801 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
7802
7803 :- chr_option(mode,abstract_constraints(+)).
7804 :- chr_option(type_declaration,abstract_constraints(list)).
7805
7806 :- chr_option(mode,depends_on(+,+)).
7807 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
7808
7809 :- chr_option(mode,depends_on_as(+,+,+)).
7810 :- chr_option(mode,depends_on_ap(+,+,+,+)).
7811 :- chr_option(mode,depends_on_goal(+,+)).
7812 :- chr_option(mode,ai_is_observed(+,+)).
7813 :- chr_option(mode,ai_not_observed(+,+)).
7814 % :- chr_option(mode,ai_observed(+,+)).
7815 :- chr_option(mode,ai_not_observed_internal(+,+)).
7816 :- chr_option(mode,ai_observed_internal(+,+)).
7817
7818
7819 abstract_constraints_fd @
7820         abstract_constraints(_) \ abstract_constraints(_) <=> true.
7821
7822 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
7823 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
7824 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
7825
7826 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
7827 ai_is_observed(_,_) <=> true.
7828
7829 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
7830 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
7831 ai_observation_gather_results <=> true.
7832
7833 %------------------------------------------------------------------------------%
7834 % Main Analysis Entry
7835 %------------------------------------------------------------------------------%
7836 ai_observation_analysis(ACs) :-
7837     ( chr_pp_flag(ai_observation_analysis,on),
7838         get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
7839         list_to_ord_set(ACs,ACSet),
7840         abstract_constraints(ACSet),
7841         ai_observation_schedule_initial_calls(ACSet,ACSet),
7842         ai_observation_gather_results
7843     ;
7844         true
7845     ).
7846
7847 ai_observation_schedule_initial_calls([],_).
7848 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
7849         ai_observation_schedule_initial_call(AC,ACs),
7850         ai_observation_schedule_initial_calls(RACs,ACs).
7851
7852 ai_observation_schedule_initial_call(AC,ACs) :-
7853         ai_observation_top(AC,CallPattern),
7854         % ai_observation_bot(AC,ACs,CallPattern),
7855         initial_call_pattern(CallPattern).
7856
7857 ai_observation_schedule_new_calls([],AP).
7858 ai_observation_schedule_new_calls([AC|ACs],AP) :-
7859         AP = odom(_,Set),
7860         initial_call_pattern(odom(AC,Set)),
7861         ai_observation_schedule_new_calls(ACs,AP).
7862
7863 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
7864         <=>
7865                 ai_observation_leq(AP2,AP1)
7866         |
7867                 true.
7868
7869 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
7870
7871 initial_call_pattern(CP) ==> call_pattern(CP).
7872
7873 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
7874         ==>
7875                 ai_observation_schedule_new_calls(ACs,AP)
7876         pragma
7877                 passive(ID3).
7878
7879 call_pattern(CP) \ call_pattern(CP) <=> true.
7880
7881 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
7882         final_answer_pattern(CP1,AP).
7883
7884  %call_pattern(CP) ==> writeln(call_pattern(CP)).
7885
7886 call_pattern(CP) ==> call_pattern_worker(CP).
7887
7888 %------------------------------------------------------------------------------%
7889 % Abstract Goal
7890 %------------------------------------------------------------------------------%
7891
7892         % AbstractGoala
7893 %call_pattern(odom([],Set)) ==>
7894 %       final_answer_pattern(odom([],Set),odom([],Set)).
7895
7896 call_pattern_worker(odom([],Set)) <=>
7897         % writeln(' - AbstractGoal'(odom([],Set))),
7898         final_answer_pattern(odom([],Set),odom([],Set)).
7899
7900         % AbstractGoalb
7901 call_pattern_worker(odom([G|Gs],Set)) <=>
7902         % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
7903         CP1 = odom(G,Set),
7904         depends_on_goal(odom([G|Gs],Set),CP1),
7905         call_pattern(CP1).
7906
7907 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
7908         <=> true pragma passive(ID).
7909 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
7910         ==>
7911                 CP1 = odom([_|Gs],_),
7912                 AP2 = odom([],Set),
7913                 CCP = odom(Gs,Set),
7914                 call_pattern(CCP),
7915                 depends_on(CP1,CCP).
7916
7917 %------------------------------------------------------------------------------%
7918 % Abstract Solve
7919 %------------------------------------------------------------------------------%
7920 call_pattern_worker(odom(builtin,Set)) <=>
7921         % writeln('  - AbstractSolve'(odom(builtin,Set))),
7922         ord_empty(EmptySet),
7923         final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
7924
7925 %------------------------------------------------------------------------------%
7926 % Abstract Drop
7927 %------------------------------------------------------------------------------%
7928 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7929         <=>
7930                 O > MO
7931         |
7932                 % writeln('  - AbstractDrop'(odom(occ(C,O),Set))),
7933                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
7934         pragma
7935                 passive(ID2).
7936
7937 %------------------------------------------------------------------------------%
7938 % Abstract Activate
7939 %------------------------------------------------------------------------------%
7940 call_pattern_worker(odom(AC,Set))
7941         <=>
7942                 AC = _ / _
7943         |
7944                 % writeln('  - AbstractActivate'(odom(AC,Set))),
7945                 CP = odom(occ(AC,1),Set),
7946                 call_pattern(CP),
7947                 depends_on(odom(AC,Set),CP).
7948
7949 %------------------------------------------------------------------------------%
7950 % Abstract Passive
7951 %------------------------------------------------------------------------------%
7952 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7953         <=>
7954                 is_passive(RuleNb,ID)
7955         |
7956                 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
7957                 % DEFAULT
7958                 NO is O + 1,
7959                 DCP = odom(occ(C,NO),Set),
7960                 call_pattern(DCP),
7961                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
7962                 depends_on(odom(occ(C,O),Set),DCP)
7963         pragma
7964                 passive(ID2).
7965 %------------------------------------------------------------------------------%
7966 % Abstract Simplify
7967 %------------------------------------------------------------------------------%
7968
7969         % AbstractSimplify
7970 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
7971         <=>
7972                 \+ is_passive(RuleNb,ID)
7973         |
7974                 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
7975                 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
7976                 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
7977                 ai_observation_memo_abstract_goal(RuleNb,AG),
7978                 call_pattern(odom(AG,Set2)),
7979                 % DEFAULT
7980                 NO is O + 1,
7981                 DCP = odom(occ(C,NO),Set),
7982                 call_pattern(DCP),
7983                 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
7984                 % DEADLOCK AVOIDANCE
7985                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
7986         pragma
7987                 passive(ID2).
7988
7989 depends_on_as(CP,CPS,CPD),
7990         final_answer_pattern(CPS,APS),
7991         final_answer_pattern(CPD,APD) ==>
7992         ai_observation_lub(APS,APD,AP),
7993         final_answer_pattern(CP,AP).
7994
7995
7996 :- chr_constraint
7997         ai_observation_memo_simplification_rest_heads/3,
7998         ai_observation_memoed_simplification_rest_heads/3.
7999
8000 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
8001 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
8002
8003 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8004         <=>
8005                 QRH = RH.
8006 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
8007         <=>
8008                 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
8009                 once(select2(ID,_,IDs1,H1,_,RestH1)),
8010                 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
8011                 ai_observation_abstract_constraints(H2,ACs,AH2),
8012                 append(ARestHeads,AH2,AbstractHeads),
8013                 sort(AbstractHeads,QRH),
8014                 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
8015         pragma
8016                 passive(ID1),
8017                 passive(ID2),
8018                 passive(ID3).
8019
8020 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
8021
8022 %------------------------------------------------------------------------------%
8023 % Abstract Propagate
8024 %------------------------------------------------------------------------------%
8025
8026
8027         % AbstractPropagate
8028 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
8029         <=>
8030                 \+ is_passive(RuleNb,ID)
8031         |
8032                 % writeln('  - AbstractPropagate'(odom(occ(C,O),Set))),
8033                 % observe partners
8034                 ai_observation_memo_propagation_rest_heads(C,O,AHs),
8035                 ai_observation_observe_set(Set,AHs,Set2),
8036                 ord_add_element(Set2,C,Set3),
8037                 ai_observation_memo_abstract_goal(RuleNb,AG),
8038                 call_pattern(odom(AG,Set3)),
8039                 ( ord_memberchk(C,Set2) ->
8040                         Delete = no
8041                 ;
8042                         Delete = yes
8043                 ),
8044                 % DEFAULT
8045                 NO is O + 1,
8046                 DCP = odom(occ(C,NO),Set),
8047                 call_pattern(DCP),
8048                 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
8049         pragma
8050                 passive(ID2).
8051
8052 :- chr_constraint
8053         ai_observation_memo_propagation_rest_heads/3,
8054         ai_observation_memoed_propagation_rest_heads/3.
8055
8056 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
8057 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
8058
8059 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8060         <=>
8061                 QRH = RH.
8062 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
8063         <=>
8064                 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
8065                 once(select2(ID,_,IDs2,H2,_,RestH2)),
8066                 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
8067                 ai_observation_abstract_constraints(H1,ACs,AH1),
8068                 append(ARestHeads,AH1,AbstractHeads),
8069                 sort(AbstractHeads,QRH),
8070                 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
8071         pragma
8072                 passive(ID1),
8073                 passive(ID2),
8074                 passive(ID3).
8075
8076 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
8077
8078 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
8079         final_answer_pattern(CP,APD).
8080 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
8081         final_answer_pattern(CPD,APD) ==>
8082         true |
8083         CP = odom(occ(C,O),_),
8084         ( ai_observation_is_observed(APP,C) ->
8085                 ai_observed_internal(C,O)
8086         ;
8087                 ai_not_observed_internal(C,O)
8088         ),
8089         ( Delete == yes ->
8090                 APP = odom([],Set0),
8091                 ord_del_element(Set0,C,Set),
8092                 NAPP = odom([],Set)
8093         ;
8094                 NAPP = APP
8095         ),
8096         ai_observation_lub(NAPP,APD,AP),
8097         final_answer_pattern(CP,AP).
8098
8099 %------------------------------------------------------------------------------%
8100 % Catch All
8101 %------------------------------------------------------------------------------%
8102
8103 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
8104
8105 %------------------------------------------------------------------------------%
8106 % Auxiliary Predicates
8107 %------------------------------------------------------------------------------%
8108
8109 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
8110         ord_intersection(S1,S2,S3).
8111
8112 ai_observation_bot(AG,AS,odom(AG,AS)).
8113
8114 ai_observation_top(AG,odom(AG,EmptyS)) :-
8115         ord_empty(EmptyS).
8116
8117 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
8118         ord_subset(S2,S1).
8119
8120 ai_observation_observe_set(S,ACSet,NS) :-
8121         ord_subtract(S,ACSet,NS).
8122
8123 ai_observation_abstract_constraint(C,ACs,AC) :-
8124         functor(C,F,A),
8125         AC = F/A,
8126         memberchk(AC,ACs).
8127
8128 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
8129         findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
8130
8131 %------------------------------------------------------------------------------%
8132 % Abstraction of Rule Bodies
8133 %------------------------------------------------------------------------------%
8134
8135 :- chr_constraint
8136         ai_observation_memoed_abstract_goal/2,
8137         ai_observation_memo_abstract_goal/2.
8138
8139 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
8140 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
8141
8142 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
8143         <=>
8144                 QAG = AG
8145         pragma
8146                 passive(ID1).
8147
8148 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
8149         <=>
8150                 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
8151                 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
8152                 QAG = AG,
8153                 ai_observation_memoed_abstract_goal(RuleNb,AG)
8154         pragma
8155                 passive(ID1),
8156                 passive(ID2).
8157
8158 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
8159         % also guard: e.g. b, c(X) ==> Y=X | p(Y).
8160         term_variables((H1,H2,Guard),HVars),
8161         append(H1,H2,Heads),
8162         % variables that are declared to be ground are safe,
8163         ground_vars(Heads,GroundVars),
8164         % so we remove them from the list of 'dangerous' head variables
8165         list_difference_eq(HVars,GroundVars,HV),
8166         ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
8167         % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
8168         % HV are 'dangerous' variables, all others are fresh and safe
8169
8170 ground_vars([],[]).
8171 ground_vars([H|Hs],GroundVars) :-
8172         functor(H,F,A),
8173         get_constraint_mode(F/A,Mode),
8174         head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
8175         head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
8176         ground_vars(Hs,GroundVars2),
8177         append(GroundVars1,GroundVars2,GroundVars).
8178
8179 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !,    % conjunction
8180         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
8181         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
8182 ai_observation_abstract_goal((G1;G2),ACs,List,Tail,HV) :- !,    % disjunction
8183         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
8184         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
8185 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !,   % if-then
8186         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
8187         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
8188 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
8189         ai_observation_abstract_constraint(C,ACs,AC), !.        % CHR constraint
8190 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
8191 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
8192 % non-CHR constraint is safe if it only binds fresh variables
8193 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
8194         builtin_binds_b(G,Vars),
8195         intersect_eq(Vars,HV,[]),
8196         !.
8197 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
8198         AG = builtin. % default case if goal is not recognized/safe
8199
8200 ai_observation_is_observed(odom(_,ACSet),AC) :-
8201         \+ ord_memberchk(AC,ACSet).
8202
8203 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8204 unconditional_occurrence(C,O) :-
8205         get_occurrence(C,O,RuleNb,ID),
8206         get_rule(RuleNb,PRule),
8207         PRule = pragma(ORule,_,_,_,_),
8208         copy_term_nat(ORule,Rule),
8209         Rule = rule(H1,H2,Guard,_),
8210         guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
8211         once((
8212                 H1 = [Head], H2 == []
8213              ;
8214                 H2 = [Head], H1 == [], \+ may_trigger(C)
8215         )),
8216         functor(Head,F,A),
8217         Head =.. [_|Args],
8218         unconditional_occurrence_args(Args).
8219
8220 unconditional_occurrence_args([]).
8221 unconditional_occurrence_args([X|Xs]) :-
8222         var(X),
8223         X = x,
8224         unconditional_occurrence_args(Xs).
8225
8226 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8227
8228 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8229 % Partial wake analysis
8230 %
8231 % In a Var = Var unification do not wake up constraints of both variables,
8232 % but rather only those of one variable.
8233 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8234
8235 :- chr_constraint partial_wake_analysis/0.
8236 :- chr_constraint no_partial_wake/1.
8237 :- chr_option(mode,no_partial_wake(+)).
8238 :- chr_constraint wakes_partially/1.
8239 :- chr_option(mode,wakes_partially(+)).
8240
8241 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type),  rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
8242         ==>
8243                 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
8244                 ( is_passive(RuleNb,ID) ->
8245                         true
8246                 ; Type == simplification ->
8247                         select(H,H1,RestH1),
8248                         H =.. [_|Args],
8249                         term_variables(Guard,Vars),
8250                         partial_wake_args(Args,ArgModes,Vars,FA)
8251                 ; % Type == propagation  ->
8252                         select(H,H2,RestH2),
8253                         H =.. [_|Args],
8254                         term_variables(Guard,Vars),
8255                         partial_wake_args(Args,ArgModes,Vars,FA)
8256                 ).
8257
8258 partial_wake_args([],_,_,_).
8259 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
8260         ( Mode \== (+) ->
8261                 ( nonvar(Arg) ->
8262                         no_partial_wake(C)
8263                 ; memberchk_eq(Arg,Vars) ->
8264                         no_partial_wake(C)
8265                 ;
8266                         true
8267                 )
8268         ;
8269                 true
8270         ),
8271         partial_wake_args(Args,Modes,Vars,C).
8272
8273 no_partial_wake(C) \ no_partial_wake(C) <=> true.
8274
8275 no_partial_wake(C) \ wakes_partially(C) <=> fail.
8276
8277 wakes_partially(C) <=> true.
8278
8279
8280 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8281 % Generate rules that implement chr_show_store/1 functionality.
8282 %
8283 % CLASSIFICATION
8284 %   Experimental
8285 %   Unused
8286 %
8287 % Generates additional rules:
8288 %
8289 %   $show, C1 # ID ==> writeln(C1) pragma passive(ID).
8290 %   ...
8291 %   $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
8292 %   $show <=> true.
8293
8294 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
8295         ( chr_pp_flag(show,on) ->
8296                 Constraints = ['$show'/0|Constraints0],
8297                 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
8298                 inc_rule_count(RuleNb),
8299                 Rule = pragma(
8300                                 rule(['$show'],[],true,true),
8301                                 ids([0],[]),
8302                                 [],
8303                                 no,
8304                                 RuleNb
8305                         )
8306         ;
8307                 Constraints = Constraints0,
8308                 Rules = Rules0
8309         ).
8310
8311 generate_show_rules([],Rules,Rules).
8312 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
8313         functor(C,F,A),
8314         inc_rule_count(RuleNb),
8315         Rule = pragma(
8316                         rule([],['$show',C],true,writeln(C)),
8317                         ids([],[0,1]),
8318                         [passive(1)],
8319                         no,
8320                         RuleNb
8321                 ),
8322         generate_show_rules(Rest,Tail,Rules).
8323
8324 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8325 % Custom supension term layout
8326
8327 static_suspension_term(F/A,Suspension) :-
8328         suspension_term_base(F/A,Base),
8329         Arity is Base + A,
8330         functor(Suspension,suspension,Arity).
8331
8332 has_suspension_field(FA,Field) :-
8333         suspension_term_base_fields(FA,Fields),
8334         memberchk(Field,Fields).
8335
8336 suspension_term_base(FA,Base) :-
8337         suspension_term_base_fields(FA,Fields),
8338         length(Fields,Base).
8339
8340 suspension_term_base_fields(FA,Fields) :-
8341         ( chr_pp_flag(debugable,on) ->
8342                 % 1. ID
8343                 % 2. State
8344                 % 3. Propagation History
8345                 % 4. Generation Number
8346                 % 5. Continuation Goal
8347                 % 6. Functor
8348                 Fields = [id,state,history,generation,continuation,functor]
8349         ;
8350                 ( uses_history(FA) ->
8351                         Fields = [id,state,history|Fields2]
8352                 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
8353                         Fields = [state|Fields2]
8354                 ;
8355                         Fields = [id,state|Fields2]
8356                 ),
8357                 ( only_ground_indexed_arguments(FA) ->
8358                         get_store_type(FA,StoreType),
8359                         basic_store_types(StoreType,BasicStoreTypes),
8360                         ( memberchk(global_ground,BasicStoreTypes) ->
8361                                 % 1. ID
8362                                 % 2. State
8363                                 % 3. Propagation History
8364                                 % 4. Global List Prev
8365                                 Fields2 = [global_list_prev]
8366                         ;
8367                                 % 1. ID
8368                                 % 2. State
8369                                 % 3. Propagation History
8370                                 Fields2 = []
8371                         )
8372                 ; may_trigger(FA) ->
8373                         % 1. ID
8374                         % 2. State
8375                         % 3. Propagation History
8376                         ( uses_field(FA,generation) ->
8377                         % 4. Generation Number
8378                         % 5. Global List Prev
8379                                 Fields2 = [generation,global_list_prev]
8380                         ;
8381                                 Fields2 = [global_list_prev]
8382                         )
8383                 ;
8384                         % 1. ID
8385                         % 2. State
8386                         % 3. Propagation History
8387                         % 4. Global List Prev
8388                         Fields2 = [global_list_prev]
8389                 )
8390         ).
8391
8392 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
8393         suspension_term_base_fields(FA,Fields),
8394         nth(Index,Fields,FieldName), !,
8395         arg(Index,StaticSuspension,Field).
8396 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
8397         suspension_term_base(FA,Base),
8398         StaticSuspension =.. [_|Args],
8399         drop(Base,Args,Field).
8400 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
8401         chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
8402
8403
8404 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
8405         suspension_term_base_fields(FA,Fields),
8406         nth(Index,Fields,FieldName), !,
8407         Goal = arg(Index,DynamicSuspension,Field).
8408 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
8409         static_suspension_term(FA,StaticSuspension),
8410         get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
8411         Goal = (DynamicSuspension = StaticSuspension).
8412 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
8413         suspension_term_base(FA,Base),
8414         Index is I + Base,
8415         Goal = arg(Index,DynamicSuspension,Field).
8416 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
8417         chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
8418
8419
8420 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
8421         suspension_term_base_fields(FA,Fields),
8422         nth(Index,Fields,FieldName), !,
8423         Goal = setarg(Index,DynamicSuspension,Field).
8424 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
8425         chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
8426
8427 basic_store_types(multi_store(Types),Types) :- !.
8428 basic_store_types(Type,[Type]).
8429
8430 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8431 %
8432
8433 :- chr_constraint
8434         phase_end/1,
8435         delay_phase_end/2.
8436
8437 :- chr_option(mode,phase_end(+)).
8438 :- chr_option(mode,delay_phase_end(+,?)).
8439
8440 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
8441 % phase_end(Phase) <=> true.
8442
8443
8444 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8445 :- chr_constraint
8446         does_use_history/2,
8447         uses_history/1,
8448         novel_production_call/4.
8449
8450 :- chr_option(mode,uses_history(+)).
8451 :- chr_option(mode,does_use_history(+,+)).
8452 :- chr_option(mode,novel_production_call(+,+,?,?)).
8453
8454 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
8455 does_use_history(FA,_) \ uses_history(FA) <=> true.
8456 uses_history(_FA) <=> fail.
8457
8458 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
8459 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
8460
8461 :- chr_constraint
8462         does_use_field/2,
8463         uses_field/2.
8464
8465 :- chr_option(mode,uses_field(+,+)).
8466 :- chr_option(mode,does_use_field(+,+)).
8467
8468 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
8469 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
8470 uses_field(_FA,_Field) <=> fail.
8471
8472 :- chr_constraint
8473         uses_state/2,
8474         if_used_state/5,
8475         used_states_known/0.
8476
8477 :- chr_option(mode,uses_state(+,+)).
8478 :- chr_option(mode,if_used_state(+,+,?,?,?)).
8479
8480
8481 % states ::= not_stored_yet | passive | active | triggered | removed
8482 %
8483 % allocate CREATES not_stored_yet
8484 %   remove CHECKS  not_stored_yet
8485 % activate CHECKS  not_stored_yet
8486 %
8487 %  ==> no allocate THEN no not_stored_yet
8488
8489 % recurs   CREATES inactive
8490 % lookup   CHECKS  inactive
8491
8492 % insert   CREATES active
8493 % activate CREATES active
8494 % lookup   CHECKS  active
8495 % recurs   CHECKS  active
8496
8497 % runsusp  CREATES triggered
8498 % lookup   CHECKS  triggered
8499 %
8500 % ==> no runsusp THEN no triggered
8501
8502 % remove   CREATES removed
8503 % runsusp  CHECKS  removed
8504 % lookup   CHECKS  removed
8505 % recurs   CHECKS  removed
8506 %
8507 % ==> no remove THEN no removed
8508
8509 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
8510
8511 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
8512
8513 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
8514         <=> ResultGoal = Used.
8515 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
8516         <=> ResultGoal = NotUsed.
8517 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8518 % % In-place updates
8519 %
8520 % inplace_updates(Constraints) :-
8521 %       ( chr_pp_flag(inplace_updates,off) ->
8522 %               true
8523 %       ;
8524 %               inplace_updates0(Constraints)
8525 %       ).
8526 %
8527 % inplace_updates0([]).
8528 % inplace_updates([C|Cs]) :-
8529 %     inplace_update_allowed(C),
8530 %     inplace_updates0(Cs).
8531 %
8532 % :- chr_constraint
8533 %       inplace_update_allowed/1,
8534 %         inplace_update_safe/1,
8535 %         is_safe_inplace_update/1,
8536 %       partial_remove_insert/7.
8537 %
8538 % :- chr_option(mode,inplace_update_allowed(+)).
8539 % :- chr_option(mode,inplace_update_safe(+)).
8540 % :- chr_option(mode,is_safe_inplace_update(+)).
8541 % :- chr_option(mode,partial_remove_insert(+,?,?,?,?,?)).
8542 %
8543 % % pointless to even check for in-place updates if C is never removed
8544 % occurrence(C,ON,RuleNb,ID,_), rule(RuleNb,Rule) \ inplace_update_allowed(C)
8545 %       <=>
8546 %               never_removed(C)
8547 %       |
8548 %               true.
8549 %
8550 % inplace_update_allowed(C) ==> reuse_susps_test(C).
8551 %
8552 % inplace_update_allowed(C) <=> inplace_update_safe(C).
8553 %
8554 % :-chr_constraint
8555 %       safe_body_check/5,
8556 %       all_occs_passive_or_safe/2.
8557 %
8558 % abstract_constraints(ACs) \ safe_body_check(H1,H2,Guard,G,C)
8559 %       <=>
8560 %               ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG),
8561 %               check_abstract_body_safety(AG,C).
8562 %
8563 % safe_body_check(H1,H2,Guard,G,C) <=> fail.
8564 %
8565 % check_abstract_body_safety([],_).
8566 % check_abstract_body_safety([builtin|_],_) :- !, fail.
8567 % check_abstract_body_safety([AC|Rest],C) :-
8568 %       all_occs_passive_or_safe(AC,C),
8569 %       check_abstract_body_safety(Rest,C).
8570 %
8571 % % this breaks loops
8572 % this_one_should_not_be_all_passive @
8573 % all_occs_passive_or_safe(AC,C), all_occs_passive_or_safe(AC,C) <=> fail.
8574 %
8575 % abstract_constraints(ACs), occurrence(AC,ON,RuleNb,ID,_), rule(RuleNb,Rule), all_occs_passive_or_safe(AC,C)
8576 %       ==>
8577 %               \+ is_passive(RuleNb,ID),
8578 %               Rule = pragma(rule(Hr,Hk,Guard,Body),ids(IDr,IDk),_,_,_)
8579 %       |
8580 %               ai_observation_abstract_constraints(Hr,ACs,ARemovedHeads),
8581 %               %not safe if it is removed
8582 %               \+ memberchk_eq(C,ARemovedHeads),
8583 %       safe_body_check(Hr,Hk,Guard,Body,C).
8584 %
8585 % all_occs_passive_or_safe(AC,C) <=> true.
8586 %
8587 % check_passive([],RuleNb).
8588 % check_passive([ID|IDs],RuleNb) :-
8589 %     is_passive(RuleNb,ID),
8590 %     check_passive(IDs,RuleNb).
8591 %
8592 % inplace_update_safe(C) \ is_safe_inplace_update(C) <=> true.
8593 % is_safe_inplace_update(C) <=> fail.
8594 %
8595 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8596 %
8597 % :- chr_constraint
8598 %       inplace_updates2/0,
8599 %       maybe_inplace/16.
8600 %
8601 % inplace_updates2 \ maybe_inplace(C,_,Del,Ins,DelClause,InsClause,_,_,_,_,_,_,_,_,_,_)#Id
8602 %       <=>
8603 %               chr_pp_flag(inplace_updates,off)
8604 %       |
8605 %               Del = DelClause,
8606 %               Ins = InsClause
8607 %         pragma
8608 %               passive(Id).
8609 %
8610 % inplace_updates2,
8611 %       maybe_inplace(C,Susp,Del,Ins,DelClause,InsClause,UpdateDelClause,UpdateInsClause,UpdatedArgs,_,OrigVars,TheNewVars,V1,V2,NewState,ResetHistory)#Id
8612 %       <=>
8613 %               true
8614 %       |
8615 %               ( fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,UpdateInsClause,V1,V2,RSA) ->
8616 %                       ( reuse_susps_history_reset_needed(C) ->
8617 %                           update_suspension_field(C,Susp,history,t,ResetHistory)
8618 %                       ;
8619 %                           ResetHistory = true
8620 %                       ),
8621 %                       ( has_active_occurrence(C) ->
8622 %                               C = F/A,
8623 %                               InsClause =.. [_|NewVars],
8624 %                               append(NewVars,[Susp],VarsSusp),
8625 %                               ( (chr_pp_flag(debugable,on) ; is_stored(C), ( has_active_occurrence(C); chr_pp_flag(late_allocation,off)), ( may_trigger(C) ; get_allocation_occurrence(C,AO), get_max_occurrence(C,MO), MO >= AO ) ) ->
8626 %                                       build_head(F,A,[0],VarsSusp,Delegate),
8627 %                                       ConstraintCall = (SetNewState,Delegate),
8628 %                                       ( NewState = inactive ->
8629 %                                               SetNewState = true
8630 %                                       ;
8631 %                                               update_suspension_field(C,Susp,state,inactive,SetNewState)
8632 %                                       ),
8633 %                                       reuse_susps_removed_needed(C),
8634 %                                       Del = (RemoveFromModifiedStores,UpdateDelClause),
8635 %                                       Ins = (ReInsertIntoModifiedStores,RSA,ConstraintCall)
8636 %                               ;
8637 %                                       Del = DelClause,
8638 %                                       Ins = InsClause
8639 %                               )
8640 %                       ;
8641 %                               Del = (RemoveFromModifiedStores,UpdateDelClause),
8642 %                               Ins = (ReInsertIntoModifiedStores,RSA),
8643 %                               % weird goal
8644 %                               (NewState = active -> true ; true)
8645 %                       )
8646 %               ;
8647 %                           Del = DelClause,
8648 %                           Ins = InsClause
8649 %               ),
8650 %               inplace_updates2
8651 %       pragma
8652 %               passive(Id).
8653 %
8654 %
8655 % fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,SetArgs,V1,V2,RestSetArgs) :-
8656 %       suspension_term_base(C,Base),
8657 %       get_store_type(C,StoreType),
8658 %       ( StoreType == default ->
8659 %               RemoveFromModifiedStores = true,
8660 %               (
8661 %                       none_indexed(UpdatedArgs,C),
8662 %                       UpdatedIndexes = [],
8663 %                       ReInsertIntoModifiedStores = true,
8664 %                       keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
8665 %               ;
8666 %                       UpdatedIndexes = UpdatedArgs,
8667 %                       attach_constraint_atom(C,NewVars2,Susp,Attach),
8668 %                       detach_constraint_atom(C,OrigVars2,Susp,Detach),
8669 %                       ReInsertIntoModifiedStores = ('chr attach_diff'(OrigVars,TheNewVars,OrigVars2,NewVars2), Detach, Attach),
8670 %                       keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
8671 %               )
8672 %       ;
8673 %               indexargs(StoreType,KeepArgs),
8674 %               intersect_eq(KeepArgs,UpdatedArgs,UpdatedIndexes1),
8675 %               multi_arg_updated_indexes(StoreType,UpdatedIndexes1,UpdatedIndexes,ModifiedStore),
8676 %               generate_insert_constraint_body2(ModifiedStore,C,Susp,V1,V2,ReInsertIntoModifiedStores),
8677 %               keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base),
8678 %               RemoveFromModifiedStores = true
8679 %       ).
8680 %
8681 % keep_nonindex_setargs(SetArgs,RestSetArgs,Base) :-
8682 %       keep_nonindex_setargs(SetArgs,[],RestSetArgs,Base).
8683 %
8684 % keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base) :-
8685 %       conj2list(SetArgs,SA),
8686 %       keep_nonindex_setargs_(SA,UpdatedIndexes1,RSA,Base),
8687 %       list2conj(RSA,RestSetArgs).
8688 %
8689 % keep_nonindex_setargs_([],_,[],_).
8690 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
8691 %         var(X), !,
8692 %       keep_nonindex_setargs_(Rest,UI,Rest2,Base).
8693 % keep_nonindex_setargs_([setarg(Pos,X,Y)|Rest],UI,Rest2,Base) :-
8694 %       CPos is Pos - 6,!, % TOM: What is the magic number 6?
8695 %       ( memberchk(CPos,UI) ->
8696 %               Rest2 = R2
8697 %          ;
8698 %                 (CPos > 0 ->
8699 %                         CPos2 is CPos + Base,
8700 %                         Rest2 = [setarg(CPos2,X,Y)|R2]
8701 %                 ;
8702 %                         Rest2 = [setarg(Pos,X,Y)|R2]
8703 %                 )
8704 %          ),
8705 %       keep_nonindex_setargs_(Rest,UI,R2,Base).
8706 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
8707 %       keep_nonindex_setargs_(Rest,UI,Rest2,Base).
8708 %
8709 %
8710 % generate_insert_constraint_body2(multi_inthash(Indexes),C,Susp,O,N,Body) :-
8711 %       generate_multi_inthash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
8712 % generate_insert_constraint_body2(multi_hash(Indexes),C,Susp,O,N,Body) :-
8713 %       generate_multi_hash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
8714 % generate_insert_constraint_body2(multi_store(StoreTypes),C,Susp,O,N,Body) :-
8715 %       append(O,N,ON),
8716 %       find_with_var_identity(
8717 %               B,
8718 %               [Susp|ON],
8719 %               (
8720 %                       lists:member(ST,StoreTypes),
8721 %                       generate_insert_constraint_body2(ST,C,Susp,O,N,B)
8722 %               ),
8723 %               Bodies
8724 %               ),
8725 %       list2conj(Bodies,Body).
8726 %
8727 % generate_multi_inthash_insert_constraint_bodies2([],_,_,_,_,true).
8728 % generate_multi_inthash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
8729 %       multi_hash_store_name(FA,Index,StoreName),
8730 %       Index = [Pos],
8731 %       nth(Pos,O,Orig),
8732 %       nth(Pos,N,New),
8733 %         set_dynamic_suspension_term_field(argument(Pos),FA,Susp,New,UpdateArgument),
8734 %       Body =
8735 %       (
8736 %               (Orig == New ->
8737 %                       true
8738 %               ;
8739 %                       nb_getval(StoreName,Store),
8740 %                       chr_integertable_store:delete_ht(Store,Orig,Susp),
8741 %                         UpdateArgument,
8742 %                       chr_integertable_store:insert_ht(Store,New,Susp)
8743 %               )
8744 %       ),
8745 %       generate_multi_inthash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
8746 % generate_multi_hash_insert_constraint_bodies2([],_,_,_,_,true).
8747 % generate_multi_hash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
8748 %       multi_hash_store_name(FA,Index,StoreName),
8749 %       multi_hash_key2(FA,Index,Susp,O,N,Key1,Key2,SetArgs),
8750 %       Body =
8751 %       (
8752 %               (Key1 == Key2 ->
8753 %                       true
8754 %               ;
8755 %                       nb_getval(StoreName,Store),
8756 %                       chr_hashtable_store:delete_ht(Store,Key1,Susp),
8757 %                       SetArgs,
8758 %                       chr_hashtable_store:insert_ht(Store,Key2,Susp)
8759 %               )
8760 %       ),
8761 %       generate_multi_hash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
8762 %
8763 % multi_hash_key2(F/A,Index,Susp,O,N,Key1,Key2,SetArgs) :-
8764 %       ( ( integer(Index) ->
8765 %               I = Index
8766 %         ;
8767 %               Index = [I]
8768 %         ) ->
8769 %               nth(I,O,Key1),
8770 %               nth(I,N,Key2),
8771 %                 set_dynamic_suspension_term_field(argument(I),F/A,Susp,Key2,SetArgs)
8772 %
8773 %       ; is_list(Index) ->
8774 %               sort(Index,Indexes),
8775 %               append(O,N,ON),
8776 %               find_with_var_identity(
8777 %                         SetArg-(KeyO-KeyI),
8778 %                       [Susp|ON],
8779 %                       (lists:member(I,Indexes),
8780 %                        lists:nth(I,N,KeyI),
8781 %                        lists:nth(I,O,KeyO),
8782 %                          set_dynamic_suspension_term_field(argument(I),F/A,Susp,KeyI,SetArg)),
8783 %                       ArgKeyPairs),
8784 %               pairup(Bodies,Keys,ArgKeyPairs),
8785 %               pairup(OldKey,NewKey,Keys),
8786 %               Key1 =.. [k|OldKey],
8787 %               Key2 =.. [k|NewKey],
8788 %               list2conj(Bodies,SetArgs)
8789 %       ).
8790 %
8791 %
8792 % avoid_redundant_arg_getval([],_,_,[]).
8793 % avoid_redundant_arg_getval([arg(Pos,Susp,Var)|Rest],SetArgs,GetVals,Rest2) :-
8794 %       already_set(SetArgs,Pos,Susp,Var), !,
8795 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
8796 % avoid_redundant_arg_getval([nb_getval(Table,Var)|Rest],SetArgs,GetVals,Rest2) :-
8797 %       already_got(GetVals,Table,Var), !,
8798 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
8799 % avoid_redundant_arg_getval([X|Rest],SetArgs,GetVals,[X|Rest2]) :-
8800 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
8801 %
8802 % already_set([setarg(Pos,Susp2,Var2)|_],Pos,Susp,Var) :-
8803 %       Susp == Susp2, !, Var = Var2.
8804 % already_set([_|Rest],Pos,Susp,Var) :-
8805 %       already_set(Rest,Pos,Susp,Var).
8806 %
8807 % already_got([nb_getval(Table,Var2)|_],Table,Var) :-
8808 %       !, Var = Var2.
8809 % already_got([_|Rest],Table,Var) :- already_got(Rest,Table,Var).
8810 %
8811 %
8812 %
8813 % % TOM: Is this predicate used?
8814 % singleton(C) :-
8815 %       get_store_type(C,StoreType),
8816 %       (
8817 %               StoreType = global_singleton
8818 %       ;
8819 %                StoreType = multi_store([global_singleton])
8820 %       ).
8821 %
8822 %
8823 % inplace_updates2 \ reuse_susps_removed(_,_,X) <=> X = true.
8824 % inplace_updates2 \ reuse_susps_active(_,_,X) <=> X = true.
8825 %
8826 % inplace_updates2 \
8827 %         partial_remove_insert(F/A,X,TheNewVars,PartialRemove,PartialInsert,SetArgs,V2)
8828 %         <=>
8829 %         (get_store_type(F/A,StoreType),
8830 %               (StoreType \== default ->
8831 %                  indexargs(StoreType,UpdatedArgs)
8832 %               ;
8833 %                  length(UpdatedArgs,A),
8834 %                  fill_inc_numbers(UpdatedArgs,1)
8835 %               ),
8836 %         length(V1,A),
8837 %         fix_stores(F/A,X,UpdatedArgs,V1,TheNewVars
8838 %         , UpdatedIndexes, RemoveFromModifiedStores,
8839 %         ReInsertIntoModifiedStores,SetArgs,V1,V2,RemainingSetArgs) ->
8840 %               term_variables(ReInsertIntoModifiedStores,UsedVars),
8841 %                 suspension_term_base(F/A,Base),
8842 %                 Base1 is Base+1,
8843 %               getorigvars(V1,Base1,X,UsedVars,GetOrigVars2),
8844 %
8845 %               PartialRemove =
8846 %                       (GetOrigVars2,
8847 %                       RemoveFromModifiedStores),
8848 %               PartialInsert = (ReInsertIntoModifiedStores,RemainingSetArgs)
8849 %         ;
8850 %               writeln('ERROR: could not fix stores')
8851 %         ).
8852 %
8853 %
8854 %
8855 % getorigvars([],_,_,_,true).
8856 % getorigvars([V|Vs],Pos,Susp,UV,T) :-
8857 %       Pos1 is Pos+1,
8858 %       (memberchk_eq(V,UV) ->
8859 %               T = (arg(Pos,Susp,V),RT),
8860 %               getorigvars(Vs,Pos1,Susp,UV,RT)
8861 %       ;
8862 %               getorigvars(Vs,Pos1,Susp,UV,T)
8863 %       ).
8864 %
8865 % fill_inc_numbers([],_).
8866 % fill_inc_numbers([A|As],A) :- B is A+1, fill_inc_numbers(As,B).
8867 %
8868 % inplace_updates2 <=> true.
8869 %
8870 % get_extra_constraint_clauses([],_C,[],[]).
8871 % get_extra_constraint_clauses([A|RC],C,EC,EC2) :-
8872 %       once((A = (Head :- B) ; A = Head)),
8873 %       ( Head = (C-H2) ->
8874 %               EC = [(H2 :- B)|REC],
8875 %               EC2 = REC2
8876 %       ;
8877 %               EC = REC,
8878 %               EC2 = [A|REC2]
8879 %       ),
8880 %       get_extra_constraint_clauses(RC,C,REC,REC2).
8881 %
8882 % :- chr_constraint onlyone/1, isonlyone/1.
8883 % :- chr_option(mode,onlyone(+)).
8884 % :- chr_option(mode,isonlyone(+)).
8885 %
8886 % onlyone(C) \ onlyone(C) <=> true.
8887 % onlyone(C) \ isonlyone(C) <=> true.
8888 % isonlyone(C) <=> fail.
8889 %
8890 %
8891 % none_indexed([],_).
8892 % none_indexed([A|As],C) :-
8893 %       ( is_indexed_argument(C,A), get_constraint_mode(C,Mode), nth(A,Mode,M), M \== (+) ->
8894 %               fail
8895 %       ;
8896 %               none_indexed(As,C)
8897 %       ).
8898 %
8899 %
8900 % multi_arg_updated_indexes(multi_inthash(Indices),UI,UpdInd,multi_inthash(UpdInd)) :- !,
8901 %       find_updated(Indices,UI,UpdInd).
8902 % multi_arg_updated_indexes(multi_hash(Indices),UI,UpdInd,multi_hash(UpdInd)) :- !,
8903 %       find_updated(Indices,UI,UpdInd).
8904 %
8905 % find_updated([],_,[]).
8906 % find_updated([Ind|RInd],UI,RInd2) :-
8907 %       intersect_eq(Ind,UI,[]), !,
8908 %       find_updated(RInd,UI,RInd2).
8909 % find_updated([Ind|RInd],UI,[Ind|RInd2]) :- !,
8910 %       find_updated(RInd,UI,RInd2).
8911 %
8912 % multi_arg_updated_indexes(multi_store([]),_,[],multi_store([])) :- !.
8913 % multi_arg_updated_indexes(multi_store([S|Ss]),UI,UI2,multi_store([AS|ASs])) :- !,
8914 %     multi_arg_updated_indexes(S,UI,X1,AS),
8915 %     multi_arg_updated_indexes(multi_store(Ss),UI,X2,multi_store(ASs)),
8916 %     append(X1,X2,Args_),
8917 %     sort(Args_,UI2).
8918 % multi_arg_updated_indexes(_,_,[],multi_store([])).
8919 %
8920 %
8921 %
8922 %
8923 % indexargs(multi_inthash(Indexes),Args) :- !,indexes2args(Indexes,Args).
8924 % indexargs(multi_hash(Indexes),Args) :- !,indexes2args(Indexes,Args).
8925 % indexargs(multi_store([]),[]) :- !.
8926 % indexargs(multi_store([S|Ss]),Args) :- !,
8927 %     indexargs(S,A1),
8928 %     indexargs(multi_store(Ss),A2),
8929 %     append(A1,A2,Args_),
8930 %     sort(Args_,Args).
8931 % indexargs(global_ground,[]).
8932 % indexargs(global_singleton,[]).
8933 % % no default store (need to add support for correct detach-attach)
8934 %
8935 % indexes2args([],[]).
8936 % indexes2args([[]|R],Ys) :- !, indexes2args(R,Ys).
8937 % indexes2args([[X|Xs]|R],[X|Ys]) :- !,indexes2args([Xs|R],Ys).
8938 % indexes2args([X|R],[X|Ys]) :- !,indexes2args(R,Ys).
8939 %