1/*  Part of SWI-Prolog
    2
    3    Author:        Benoit Desouter <Benoit.Desouter@UGent.be>
    4                   Jan Wielemaker (SWI-Prolog port)
    5                   Fabrizio Riguzzi (mode directed tabling)
    6    Copyright (c) 2016-2020, Benoit Desouter,
    7                             Jan Wielemaker,
    8                             Fabrizio Riguzzi
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module('$tabling',
   38          [ (table)/1,                  % :PI ...
   39            untable/1,                  % :PI ...
   40
   41            (tnot)/1,                   % :Goal
   42            not_exists/1,               % :Goal
   43            undefined/0,
   44            answer_count_restraint/0,
   45            radial_restraint/0,
   46
   47            current_table/2,            % :Variant, ?Table
   48            abolish_all_tables/0,
   49            abolish_private_tables/0,
   50            abolish_shared_tables/0,
   51            abolish_table_subgoals/1,   % :Subgoal
   52            abolish_module_tables/1,    % +Module
   53            abolish_nonincremental_tables/0,
   54            abolish_nonincremental_tables/1, % +Options
   55            abolish_monotonic_tables/0,
   56
   57            start_tabling/3,            % +Closure, +Wrapper, :Worker
   58            start_subsumptive_tabling/3,% +Closure, +Wrapper, :Worker
   59            start_abstract_tabling/3,   % +Closure, +Wrapper, :Worker
   60            start_moded_tabling/5,      % +Closure, +Wrapper, :Worker,
   61                                        % :Variant, ?ModeArgs
   62
   63            '$tbl_answer'/4,            % +Trie, -Return, -ModeArgs, -Delay
   64
   65            '$wrap_tabled'/2,		% :Head, +Mode
   66            '$moded_wrap_tabled'/5,	% :Head, +Opts, +ModeTest, +Varnt, +Moded
   67            '$wfs_call'/2,              % :Goal, -Delays
   68
   69            '$set_table_wrappers'/1,    % :Head
   70            '$start_monotonic'/2        % :Head, :Wrapped
   71          ]).   72
   73:- meta_predicate
   74    table(:),
   75    untable(:),
   76    tnot(0),
   77    not_exists(0),
   78    tabled_call(0),
   79    start_tabling(+, +, 0),
   80    start_abstract_tabling(+, +, 0),
   81    start_moded_tabling(+, +, 0, +, ?),
   82    current_table(:, -),
   83    abolish_table_subgoals(:),
   84    '$wfs_call'(0, :).   85
   86/** <module> Tabled execution (SLG WAM)
   87
   88This  library  handled  _tabled_  execution   of  predicates  using  the
   89characteristics if the _SLG WAM_. The   required  suspension is realised
   90using _delimited continuations_ implemented by  reset/3 and shift/1. The
   91table space and work lists are part of the SWI-Prolog core.
   92
   93@author Benoit Desouter, Jan Wielemaker and Fabrizio Riguzzi
   94*/
   95
   96% Enable debugging using debug(tabling(Topic)) when compiled with
   97% -DO_DEBUG
   98goal_expansion(tdebug(Topic, Fmt, Args), Expansion) :-
   99    (   current_prolog_flag(prolog_debug, true)
  100    ->  Expansion = debug(tabling(Topic), Fmt, Args)
  101    ;   Expansion = true
  102    ).
  103goal_expansion(tdebug(Goal), Expansion) :-
  104    (   current_prolog_flag(prolog_debug, true)
  105    ->  Expansion = (   debugging(tabling(_))
  106                    ->  (   Goal
  107                        ->  true
  108                        ;   print_message(error,
  109                                          format('goal_failed: ~q', [Goal]))
  110                        )
  111                    ;   true
  112                    )
  113    ;   Expansion = true
  114    ).
  115
  116:- if(current_prolog_flag(prolog_debug, true)).  117wl_goal(tnot(WorkList), ~(Goal), Skeleton) :-
  118    !,
  119    '$tbl_wkl_table'(WorkList, ATrie),
  120    trie_goal(ATrie, Goal, Skeleton).
  121wl_goal(WorkList, Goal, Skeleton) :-
  122    '$tbl_wkl_table'(WorkList, ATrie),
  123    trie_goal(ATrie, Goal, Skeleton).
  124
  125trie_goal(ATrie, Goal, Skeleton) :-
  126    '$tbl_table_status'(ATrie, _Status, M:Variant, Skeleton),
  127    M:'$table_mode'(Goal0, Variant, _Moded),
  128    unqualify_goal(M:Goal0, user, Goal).
  129
  130delay_goals(List, Goal) :-
  131    delay_goals(List, user, Goal).
  132
  133user_goal(Goal, UGoal) :-
  134    unqualify_goal(Goal, user, UGoal).
  135
  136:- multifile
  137    prolog:portray/1.  138
  139user:portray(ATrie) :-
  140    '$is_answer_trie'(ATrie, _),
  141    trie_goal(ATrie, Goal, _Skeleton),
  142    format('~q for ~p', [ATrie, Goal]).
  143user:portray(Cont) :-
  144    compound(Cont),
  145    compound_name_arguments(Cont, '$cont$', [Clause, PC | Args]),
  146    clause_property(Clause, file(File)),
  147    file_base_name(File, Base),
  148    clause_property(Clause, line_count(Line)),
  149    clause_property(Clause, predicate(PI)),
  150    format('~q at ~w:~d @PC=~w, ~p', [PI, Base, Line, PC, Args]).
  151
  152:- endif.  153
  154%!  table(:PredicateIndicators)
  155%
  156%   Prepare the given PredicateIndicators for tabling. This predicate is
  157%   normally used as a directive,  but   SWI-Prolog  also allows runtime
  158%   conversion of non-tabled predicates to  tabled predicates by calling
  159%   table/1. The example below prepares  the   predicate  edge/2 and the
  160%   non-terminal statement//1 for tabled execution.
  161%
  162%     ==
  163%     :- table edge/2, statement//1.
  164%     ==
  165%
  166%   In addition to using _predicate  indicators_,   a  predicate  can be
  167%   declared for _mode  directed  tabling_  using   a  term  where  each
  168%   argument declares the intended mode.  For example:
  169%
  170%     ==
  171%     :- table connection(_,_,min).
  172%     ==
  173%
  174%   _Mode directed tabling_ is  discussed   in  the general introduction
  175%   section about tabling.
  176
  177table(M:PIList) :-
  178    setup_call_cleanup(
  179        '$set_source_module'(OldModule, M),
  180        expand_term((:- table(PIList)), Clauses),
  181        '$set_source_module'(OldModule)),
  182    dyn_tabling_list(Clauses, M).
  183
  184dyn_tabling_list([], _).
  185dyn_tabling_list([H|T], M) :-
  186    dyn_tabling(H, M),
  187    dyn_tabling_list(T, M).
  188
  189dyn_tabling(M:Clause, _) :-
  190    !,
  191    dyn_tabling(Clause, M).
  192dyn_tabling((:- multifile(PI)), M) :-
  193    !,
  194    multifile(M:PI),
  195    dynamic(M:PI).
  196dyn_tabling(:- initialization(Wrap, now), M) :-
  197    !,
  198    M:Wrap.
  199dyn_tabling('$tabled'(Head, TMode), M) :-
  200    (   clause(M:'$tabled'(Head, OMode), true, Ref),
  201        (   OMode \== TMode
  202        ->  erase(Ref),
  203            fail
  204        ;   true
  205        )
  206    ->  true
  207    ;   assertz(M:'$tabled'(Head, TMode))
  208    ).
  209dyn_tabling('$table_mode'(Head, Variant, Moded), M) :-
  210    (   clause(M:'$table_mode'(Head, Variant0, Moded0), true, Ref)
  211    ->  (   t(Head, Variant, Moded) =@= t(Head, Variant0, Moded0)
  212        ->  true
  213        ;   erase(Ref),
  214            assertz(M:'$table_mode'(Head, Variant, Moded))
  215        )
  216    ;   assertz(M:'$table_mode'(Head, Variant, Moded))
  217    ).
  218dyn_tabling(('$table_update'(Head, S0, S1, S2) :- Body), M) :-
  219    (   clause(M:'$table_update'(Head, S00, S10, S20), Body0, Ref)
  220    ->  (   t(Head, S0, S1, S2, Body) =@= t(Head, S00, S10, S20, Body0)
  221        ->  true
  222        ;   erase(Ref),
  223            assertz(M:('$table_update'(Head, S0, S1, S2) :- Body))
  224        )
  225    ;   assertz(M:('$table_update'(Head, S0, S1, S2) :- Body))
  226    ).
  227
  228%!  untable(M:PIList) is det.
  229%
  230%   Remove tabling for the predicates in  PIList.   This  can be used to
  231%   undo the effect of table/1 at runtime.   In addition to removing the
  232%   tabling instrumentation this also removes possibly associated tables
  233%   using abolish_table_subgoals/1.
  234%
  235%   @arg PIList is a comma-list that is compatible ith table/1.
  236
  237untable(M:PIList) :-
  238    untable(PIList, M).
  239
  240untable(Var, _) :-
  241    var(Var),
  242    !,
  243    '$instantiation_error'(Var).
  244untable(M:Spec, _) :-
  245    !,
  246    '$must_be'(atom, M),
  247    untable(Spec, M).
  248untable((A,B), M) :-
  249    !,
  250    untable(A, M),
  251    untable(B, M).
  252untable(Name//Arity, M) :-
  253    atom(Name), integer(Arity), Arity >= 0,
  254    !,
  255    Arity1 is Arity+2,
  256    untable(Name/Arity1, M).
  257untable(Name/Arity, M) :-
  258    !,
  259    functor(Head, Name, Arity),
  260    (   '$get_predicate_attribute'(M:Head, tabled, 1)
  261    ->  abolish_table_subgoals(M:Head),
  262        dynamic(M:'$tabled'/2),
  263        dynamic(M:'$table_mode'/3),
  264        retractall(M:'$tabled'(Head, _TMode)),
  265        retractall(M:'$table_mode'(Head, _Variant, _Moded)),
  266        unwrap_predicate(M:Name/Arity, table),
  267        '$set_predicate_attribute'(M:Head, tabled, false),
  268        '$set_predicate_attribute'(M:Head, opaque, false),
  269        '$set_predicate_attribute'(M:Head, incremental, false),
  270        '$set_predicate_attribute'(M:Head, monotonic, false),
  271        '$set_predicate_attribute'(M:Head, lazy, false)
  272    ;   true
  273    ).
  274untable(Head, M) :-
  275    callable(Head),
  276    !,
  277    functor(Head, Name, Arity),
  278    untable(Name/Arity, M).
  279untable(TableSpec, _) :-
  280    '$type_error'(table_desclaration, TableSpec).
  281
  282untable_reconsult(PI) :-
  283    print_message(informational, untable(PI)),
  284    untable(PI).
  285
  286:- initialization
  287   prolog_listen(untable, untable_reconsult).  288
  289
  290'$wrap_tabled'(Head, Options) :-
  291    get_dict(mode, Options, subsumptive),
  292    !,
  293    set_pattributes(Head, Options),
  294    '$wrap_predicate'(Head, table, Closure, Wrapped,
  295                      start_subsumptive_tabling(Closure, Head, Wrapped)).
  296'$wrap_tabled'(Head, Options) :-
  297    get_dict(subgoal_abstract, Options, _Abstract),
  298    !,
  299    set_pattributes(Head, Options),
  300    '$wrap_predicate'(Head, table, Closure, Wrapped,
  301                      start_abstract_tabling(Closure, Head, Wrapped)).
  302'$wrap_tabled'(Head, Options) :-
  303    !,
  304    set_pattributes(Head, Options),
  305    '$wrap_predicate'(Head, table, Closure, Wrapped,
  306                      start_tabling(Closure, Head, Wrapped)).
  307
  308%!  set_pattributes(:Head, +Options) is det.
  309%
  310%   Set all tabling attributes for Head. These have been collected using
  311%   table_options/3 from the `:- table Head as (Attr1,...)` directive.
  312
  313set_pattributes(Head, Options) :-
  314    '$set_predicate_attribute'(Head, tabled, true),
  315    (   tabled_attribute(Attr),
  316        get_dict(Attr, Options, Value),
  317        '$set_predicate_attribute'(Head, Attr, Value),
  318        fail
  319    ;   current_prolog_flag(table_monotonic, lazy),
  320        '$set_predicate_attribute'(Head, lazy, true),
  321        fail
  322    ;   true
  323    ).
  324
  325tabled_attribute(incremental).
  326tabled_attribute(dynamic).
  327tabled_attribute(tshared).
  328tabled_attribute(max_answers).
  329tabled_attribute(subgoal_abstract).
  330tabled_attribute(answer_abstract).
  331tabled_attribute(monotonic).
  332tabled_attribute(opaque).
  333tabled_attribute(lazy).
  334
  335%!  start_tabling(:Closure, :Wrapper, :Implementation)
  336%
  337%   Execute Implementation using tabling. This   predicate should not be
  338%   called directly. The table/1 directive  causes   a  predicate  to be
  339%   translated into a renamed implementation and a wrapper that involves
  340%   this predicate.
  341%
  342%   @arg Closure is the wrapper closure   to find the predicate quickly.
  343%   It is also allowed to pass nothing.   In that cases the predicate is
  344%   looked up using Wrapper.  We suggest to pass `0` in this case.
  345%
  346%   @compat This interface may change or disappear without notice
  347%           from future versions.
  348
  349start_tabling(Closure, Wrapper, Worker) :-
  350    '$tbl_variant_table'(Closure, Wrapper, Trie, Status, Skeleton, IsMono),
  351    (   IsMono == true
  352    ->  shift(dependency(Skeleton, Trie, Mono)),
  353        (   Mono == true
  354        ->  tdebug(monotonic, 'Monotonic new answer: ~p', [Skeleton])
  355        ;   start_tabling_2(Closure, Wrapper, Worker, Trie, Status, Skeleton)
  356        )
  357    ;   start_tabling_2(Closure, Wrapper, Worker, Trie, Status, Skeleton)
  358    ).
  359
  360start_tabling_2(Closure, Wrapper, Worker, Trie, Status, Skeleton) :-
  361    tdebug(deadlock, 'Got table ~p, status ~p', [Trie, Status]),
  362    (   Status == complete
  363    ->  trie_gen_compiled(Trie, Skeleton)
  364    ;   functor(Status, fresh, 2)
  365    ->  catch(create_table(Trie, Status, Skeleton, Wrapper, Worker),
  366              deadlock,
  367              restart_tabling(Closure, Wrapper, Worker))
  368    ;   Status == invalid
  369    ->  reeval(Trie, Wrapper, Skeleton)
  370    ;   % = run_follower, but never fresh and Status is a worklist
  371        shift(call_info(Skeleton, Status))
  372    ).
  373
  374create_table(Trie, Fresh, Skeleton, Wrapper, Worker) :-
  375    tdebug(Fresh = fresh(SCC, WorkList)),
  376    tdebug(wl_goal(WorkList, Goal, _)),
  377    tdebug(schedule, 'Created component ~d for ~p', [SCC, Goal]),
  378    setup_call_catcher_cleanup(
  379        '$idg_set_current'(OldCurrent, Trie),
  380        run_leader(Skeleton, Worker, Fresh, LStatus, Clause),
  381        Catcher,
  382        finished_leader(OldCurrent, Catcher, Fresh, Wrapper)),
  383    tdebug(schedule, 'Leader ~p done, status = ~p', [Goal, LStatus]),
  384    done_leader(LStatus, Fresh, Skeleton, Clause).
  385
  386%!  restart_tabling(+Closure, +Wrapper, +Worker)
  387%
  388%   We were aborted due to a  deadlock.   Simply  retry. We sleep a very
  389%   tiny amount to give the thread against  which we have deadlocked the
  390%   opportunity to grab our table. Without, it is common that we re-grab
  391%   the table within our time slice  and   before  the kernel managed to
  392%   wakeup the other thread.
  393
  394restart_tabling(Closure, Wrapper, Worker) :-
  395    tdebug(user_goal(Wrapper, Goal)),
  396    tdebug(deadlock, 'Deadlock running ~p; retrying', [Goal]),
  397    sleep(0.000001),
  398    start_tabling(Closure, Wrapper, Worker).
  399
  400restart_abstract_tabling(Closure, Wrapper, Worker) :-
  401    tdebug(user_goal(Wrapper, Goal)),
  402    tdebug(deadlock, 'Deadlock running ~p; retrying', [Goal]),
  403    sleep(0.000001),
  404    start_abstract_tabling(Closure, Wrapper, Worker).
  405
  406%!  start_subsumptive_tabling(:Closure, :Wrapper, :Implementation)
  407%
  408%   (*) We should __not__ use  trie_gen_compiled/2   here  as  this will
  409%   enumerate  all  answers  while  '$tbl_answer_update_dl'/2  uses  the
  410%   available trie indexing to only fetch the relevant answer(s).
  411%
  412%   @tbd  In  the  end  '$tbl_answer_update_dl'/2  is  problematic  with
  413%   incremental and shared tabling  as  we   do  not  get the consistent
  414%   update view from the compiled result.
  415
  416start_subsumptive_tabling(Closure, Wrapper, Worker) :-
  417    (   '$tbl_existing_variant_table'(Closure, Wrapper, Trie, Status, Skeleton)
  418    ->  (   Status == complete
  419        ->  trie_gen_compiled(Trie, Skeleton)
  420        ;   Status == invalid
  421        ->  reeval(Trie, Wrapper, Skeleton),
  422            trie_gen_compiled(Trie, Skeleton)
  423        ;   shift(call_info(Skeleton, Status))
  424        )
  425    ;   more_general_table(Wrapper, ATrie),
  426        '$tbl_table_status'(ATrie, complete, Wrapper, Skeleton)
  427    ->  '$tbl_answer_update_dl'(ATrie, Skeleton) % see (*)
  428    ;   more_general_table(Wrapper, ATrie),
  429        '$tbl_table_status'(ATrie, Status, GenWrapper, GenSkeleton)
  430    ->  (   Status == invalid
  431        ->  reeval(ATrie, GenWrapper, GenSkeleton),
  432            Wrapper = GenWrapper,
  433            '$tbl_answer_update_dl'(ATrie, GenSkeleton)
  434        ;   wrapper_skeleton(GenWrapper, GenSkeleton, Wrapper, Skeleton),
  435            shift(call_info(GenSkeleton, Skeleton, Status)),
  436            unify_subsumptive(Skeleton, GenSkeleton)
  437        )
  438    ;   start_tabling(Closure, Wrapper, Worker)
  439    ).
  440
  441%!  wrapper_skeleton(+GenWrapper, +GenSkeleton, +Wrapper, -Skeleton)
  442%
  443%   Skeleton is a specialized version of   GenSkeleton  for the subsumed
  444%   new consumer.
  445
  446wrapper_skeleton(GenWrapper, GenSkeleton, Wrapper, Skeleton) :-
  447    copy_term(GenWrapper+GenSkeleton, Wrapper+Skeleton),
  448    tdebug(call_subsumption, 'GenSkeleton+Skeleton = ~p',
  449           [GenSkeleton+Skeleton]).
  450
  451unify_subsumptive(X,X).
  452
  453%!  start_abstract_tabling(:Closure, :Wrapper, :Worker)
  454%
  455%   Deal with ``table p/1 as  subgoal_abstract(N)``.   This  is  a merge
  456%   between  variant  and  subsumptive  tabling.  If  the  goal  is  not
  457%   abstracted this is simple variant tabling. If the goal is abstracted
  458%   we must solve the  more  general  goal   and  use  answers  from the
  459%   abstract table.
  460%
  461%   Wrapper is e.g., user:p(s(s(s(X))),Y)
  462%   Worker  is e.g., call(<closure>(p/2)(s(s(s(X))),Y))
  463
  464start_abstract_tabling(Closure, Wrapper, Worker) :-
  465    '$tbl_abstract_table'(Closure, Wrapper, Trie, _Abstract, Status, Skeleton),
  466    tdebug(abstract, 'Wrapper=~p, Worker=~p, Skel=~p',
  467           [Wrapper, Worker, Skeleton]),
  468    (   is_most_general_term(Skeleton)           % TBD: Fill and test Abstract
  469    ->  start_tabling_2(Closure, Wrapper, Worker, Trie, Status, Skeleton)
  470    ;   Status == complete
  471    ->  '$tbl_answer_update_dl'(Trie, Skeleton)
  472    ;   functor(Status, fresh, 2)
  473    ->  '$tbl_table_status'(Trie, _, GenWrapper, GenSkeleton),
  474        abstract_worker(Worker, GenWrapper, GenWorker),
  475        catch(create_abstract_table(Trie, Status, Skeleton, GenSkeleton, GenWrapper,
  476                                    GenWorker),
  477              deadlock,
  478              restart_abstract_tabling(Closure, Wrapper, Worker))
  479    ;   Status == invalid
  480    ->  '$tbl_table_status'(Trie, _, GenWrapper, GenSkeleton),
  481        reeval(ATrie, GenWrapper, GenSkeleton),
  482        Wrapper = GenWrapper,
  483        '$tbl_answer_update_dl'(ATrie, Skeleton)
  484    ;   shift(call_info(GenSkeleton, Skeleton, Status)),
  485        unify_subsumptive(Skeleton, GenSkeleton)
  486    ).
  487
  488create_abstract_table(Trie, Fresh, Skeleton, GenSkeleton, Wrapper, Worker) :-
  489    tdebug(Fresh = fresh(SCC, WorkList)),
  490    tdebug(wl_goal(WorkList, Goal, _)),
  491    tdebug(schedule, 'Created component ~d for ~p', [SCC, Goal]),
  492    setup_call_catcher_cleanup(
  493        '$idg_set_current'(OldCurrent, Trie),
  494        run_leader(GenSkeleton, Worker, Fresh, LStatus, _Clause),
  495        Catcher,
  496        finished_leader(OldCurrent, Catcher, Fresh, Wrapper)),
  497    tdebug(schedule, 'Leader ~p done, status = ~p', [Goal, LStatus]),
  498    Skeleton = GenSkeleton,
  499    done_abstract_leader(LStatus, Fresh, GenSkeleton, Trie).
  500
  501abstract_worker(_:call(Term), _M:GenWrapper, call(GenTerm)) :-
  502    functor(Term, Closure, _),
  503    GenWrapper =.. [_|Args],
  504    GenTerm =.. [Closure|Args].
  505
  506:- '$hide'((done_abstract_leader/4)).  507
  508done_abstract_leader(complete, _Fresh, Skeleton, Trie) :-
  509    !,
  510    '$tbl_answer_update_dl'(Trie, Skeleton).
  511done_abstract_leader(final, fresh(SCC, _Worklist), Skeleton, Trie) :-
  512    !,
  513    '$tbl_free_component'(SCC),
  514    '$tbl_answer_update_dl'(Trie, Skeleton).
  515done_abstract_leader(_,_,_,_).
  516
  517%!  done_leader(+Status, +Fresh, +Skeleton, -Clause)
  518%
  519%   Called on completion of a table. Possibly destroys the component and
  520%   generates the answers from the complete  table. The last cases deals
  521%   with leaders that are merged into a higher SCC (and thus no longer a
  522%   leader).
  523
  524:- '$hide'((done_leader/4, finished_leader/4)).  525
  526done_leader(complete, _Fresh, Skeleton, Clause) :-
  527    !,
  528    trie_gen_compiled(Clause, Skeleton).
  529done_leader(final, fresh(SCC, _Worklist), Skeleton, Clause) :-
  530    !,
  531    '$tbl_free_component'(SCC),
  532    trie_gen_compiled(Clause, Skeleton).
  533done_leader(_,_,_,_).
  534
  535finished_leader(OldCurrent, Catcher, Fresh, Wrapper) :-
  536    '$idg_set_current'(OldCurrent),
  537    (   Catcher == exit
  538    ->  true
  539    ;   Catcher == fail
  540    ->  true
  541    ;   Catcher = exception(_)
  542    ->  Fresh = fresh(SCC, _),
  543        '$tbl_table_discard_all'(SCC)
  544    ;   print_message(error, tabling(unexpected_result(Wrapper, Catcher)))
  545    ).
  546
  547%!  run_leader(+Skeleton, +Worker, +Fresh, -Status, -Clause) is det.
  548%
  549%   Run the leader of  a  (new)   SCC,  storing  instantiated  copies of
  550%   Wrapper into Trie. Status  is  the  status   of  the  SCC  when this
  551%   predicate terminates. It is one of   `complete`, in which case local
  552%   completion finished or `merged` if running   the completion finds an
  553%   open (not completed) active goal that resides in a parent component.
  554%   In this case, this SCC has been merged with this parent.
  555%
  556%   If the SCC is merged, the answers   it already gathered are added to
  557%   the worklist and we shift  (suspend),   turning  our  leader into an
  558%   internal node for the upper SCC.
  559
  560run_leader(Skeleton, Worker, fresh(SCC, Worklist), Status, Clause) :-
  561    tdebug(wl_goal(Worklist, Goal, Skeleton)),
  562    tdebug(schedule, '-> Activate component ~p for ~p', [SCC, Goal]),
  563    activate(Skeleton, Worker, Worklist),
  564    tdebug(schedule, '-> Complete component ~p for ~p', [SCC, Goal]),
  565    completion(SCC, Status, Clause),
  566    tdebug(schedule, '-> Completed component ~p for ~p: ~p', [SCC, Goal, Status]),
  567    (   Status == merged
  568    ->  tdebug(merge, 'Turning leader ~p into follower', [Goal]),
  569        '$tbl_wkl_make_follower'(Worklist),
  570        shift(call_info(Skeleton, Worklist))
  571    ;   true                                    % completed
  572    ).
  573
  574activate(Skeleton, Worker, WorkList) :-
  575    tdebug(activate, '~p: created wl=~p', [Skeleton, WorkList]),
  576    (   reset_delays,
  577        delim(Skeleton, Worker, WorkList, []),
  578        fail
  579    ;   true
  580    ).
  581
  582%!  delim(+Skeleton, +Worker, +WorkList, +Delays)
  583%
  584%   Call WorkList and  add  all  instances   of  Skeleton  as  answer to
  585%   WorkList, conditional according to Delays.
  586%
  587%   @arg Skeleton is the return skeleton (ret/N term)
  588%   @arg Worker is either the (wrapped) tabled goal or a _continuation_
  589%   @arg WorkList is the work list associated with Worker (or its
  590%        continuation).
  591%   @arg Delays is the current delay list.  Note that the actual delay
  592%        also include the internal global delay list.
  593%        '$tbl_wkl_add_answer'/4 joins the two.  For a dependency we
  594%        join the two explicitly.
  595
  596delim(Skeleton, Worker, WorkList, Delays) :-
  597    reset(Worker, SourceCall, Continuation),
  598    tdebug(wl_goal(WorkList, Goal, _)),
  599    (   Continuation == 0
  600    ->  tdebug('$tbl_add_global_delays'(Delays, AllDelays)),
  601        tdebug(delay_goals(AllDelays, Cond)),
  602        tdebug(answer, 'New answer ~p for ~p (delays = ~p)',
  603               [Skeleton, Goal, Cond]),
  604        '$tbl_wkl_add_answer'(WorkList, Skeleton, Delays, Complete),
  605        Complete == !,
  606        !
  607    ;   SourceCall = call_info(SrcSkeleton, SourceWL)
  608    ->  '$tbl_add_global_delays'(Delays, AllDelays),
  609        tdebug(wl_goal(SourceWL, SrcGoal, _)),
  610        tdebug(wl_goal(WorkList, DstGoal, _)),
  611        tdebug(schedule, 'Suspended ~p, for solving ~p', [SrcGoal, DstGoal]),
  612        '$tbl_wkl_add_suspension'(
  613            SourceWL,
  614            dependency(SrcSkeleton, Continuation, Skeleton, WorkList, AllDelays))
  615    ;   SourceCall = call_info(SrcSkeleton, InstSkeleton, SourceWL)
  616    ->  '$tbl_add_global_delays'(Delays, AllDelays),
  617        tdebug(wl_goal(SourceWL, SrcGoal, _)),
  618        tdebug(wl_goal(WorkList, DstGoal, _)),
  619        tdebug(schedule, 'Suspended ~p, for solving ~p', [SrcGoal, DstGoal]),
  620        '$tbl_wkl_add_suspension'(
  621            SourceWL,
  622            InstSkeleton,
  623            dependency(SrcSkeleton, Continuation, Skeleton, WorkList, AllDelays))
  624    ;   '$tbl_wkl_table'(WorkList, ATrie),
  625        mon_assert_dep(SourceCall, Continuation, Skeleton, ATrie)
  626    ->  delim(Skeleton, Continuation, WorkList, Delays)
  627    ).
  628
  629%!  start_moded_tabling(+Closure, :Wrapper, :Implementation, +Variant, +ModeArgs)
  630%
  631%   As start_tabling/2, but in addition separates the data stored in the
  632%   answer trie in the Variant and ModeArgs.
  633
  634'$moded_wrap_tabled'(Head, Options, ModeTest, WrapperNoModes, ModeArgs) :-
  635    set_pattributes(Head, Options),
  636    '$wrap_predicate'(Head, table, Closure, Wrapped,
  637                      (   ModeTest,
  638                          start_moded_tabling(Closure, Head, Wrapped,
  639                                              WrapperNoModes, ModeArgs)
  640                      )).
  641
  642
  643start_moded_tabling(Closure, Wrapper, Worker, WrapperNoModes, ModeArgs) :-
  644    '$tbl_moded_variant_table'(Closure, WrapperNoModes, Trie,
  645                               Status, Skeleton, IsMono),
  646    (   IsMono == true
  647    ->  shift(dependency(Skeleton/ModeArgs, Trie, Mono)),
  648        (   Mono == true
  649        ->  tdebug(monotonic, 'Monotonic new answer: ~p', [Skeleton])
  650        ;   start_moded_tabling_2(Closure, Wrapper, Worker, ModeArgs,
  651                                  Trie, Status, Skeleton)
  652        )
  653    ;   start_moded_tabling_2(Closure, Wrapper, Worker, ModeArgs,
  654                              Trie, Status, Skeleton)
  655    ).
  656
  657start_moded_tabling_2(_Closure, Wrapper, Worker, ModeArgs,
  658                      Trie, Status, Skeleton) :-
  659    (   Status == complete
  660    ->  moded_gen_answer(Trie, Skeleton, ModeArgs)
  661    ;   functor(Status, fresh, 2)
  662    ->  setup_call_catcher_cleanup(
  663            '$idg_set_current'(OldCurrent, Trie),
  664            moded_run_leader(Wrapper, Skeleton/ModeArgs,
  665                             Worker, Status, LStatus),
  666            Catcher,
  667            finished_leader(OldCurrent, Catcher, Status, Wrapper)),
  668        tdebug(schedule, 'Leader ~p done, modeargs = ~p, status = ~p',
  669               [Wrapper, ModeArgs, LStatus]),
  670        moded_done_leader(LStatus, Status, Skeleton, ModeArgs, Trie)
  671    ;   Status == invalid
  672    ->  reeval(Trie, Wrapper, Skeleton),
  673        moded_gen_answer(Trie, Skeleton, ModeArgs)
  674    ;   % = run_follower, but never fresh and Status is a worklist
  675        shift(call_info(Skeleton/ModeArgs, Status))
  676    ).
  677
  678:- public
  679    moded_gen_answer/3.                         % XSB tables.pl
  680
  681moded_gen_answer(Trie, Skeleton, ModedArgs) :-
  682    trie_gen(Trie, Skeleton),
  683    '$tbl_answer_update_dl'(Trie, Skeleton, ModedArgs).
  684
  685'$tbl_answer'(ATrie, Skeleton, ModedArgs, Delay) :-
  686    trie_gen(ATrie, Skeleton),
  687    '$tbl_answer_c'(ATrie, Skeleton, ModedArgs, Delay).
  688
  689moded_done_leader(complete, _Fresh, Skeleton, ModeArgs, Trie) :-
  690    !,
  691    moded_gen_answer(Trie, Skeleton, ModeArgs).
  692moded_done_leader(final, fresh(SCC, _WorkList), Skeleton, ModeArgs, Trie) :-
  693    !,
  694    '$tbl_free_component'(SCC),
  695    moded_gen_answer(Trie, Skeleton, ModeArgs).
  696moded_done_leader(_, _, _, _, _).
  697
  698moded_run_leader(Wrapper, SkeletonMA, Worker, fresh(SCC, Worklist), Status) :-
  699    tdebug(wl_goal(Worklist, Goal, _)),
  700    tdebug(schedule, '-> Activate component ~p for ~p', [SCC, Goal]),
  701    moded_activate(SkeletonMA, Worker, Worklist),
  702    tdebug(schedule, '-> Complete component ~p for ~p', [SCC, Goal]),
  703    completion(SCC, Status, _Clause),           % TBD: propagate
  704    tdebug(schedule, '-> Completed component ~p for ~p: ~p', [SCC, Goal, Status]),
  705    (   Status == merged
  706    ->  tdebug(merge, 'Turning leader ~p into follower', [Wrapper]),
  707        '$tbl_wkl_make_follower'(Worklist),
  708        shift(call_info(SkeletonMA, Worklist))
  709    ;   true                                    % completed
  710    ).
  711
  712moded_activate(SkeletonMA, Worker, WorkList) :-
  713    (   reset_delays,
  714        delim(SkeletonMA, Worker, WorkList, []),
  715        fail
  716    ;   true
  717    ).
  718
  719%!  update(+Flags, +Head, +Module, +A1, +A2, -A3, -Action) is semidet.
  720%
  721%   Update the aggregated value  for  an   answer.  Iff  this  predicate
  722%   succeeds, the aggregated value is updated to   A3. If Del is unified
  723%   with `true`, A1 should be deleted.
  724%
  725%   @arg Flags is a bit mask telling which of A1 and A2 are uncondional
  726%   @arg Head is the head of the predicate
  727%   @arg Module is the module of the predicate
  728%   @arg A1 is the currently aggregated value
  729%   @arg A2 is the newly produced value
  730%   @arg Action is one of
  731%	 - `delete` to replace the old answer with the new
  732%	 - `keep`   to keep the old answer and add the new
  733%	 - `done`   to stop the update process
  734
  735:- public
  736    update/7.  737
  738update(0b11, Wrapper, M, A1, A2, A3, delete) :-
  739    !,
  740    M:'$table_update'(Wrapper, A1, A2, A3),
  741    A1 \=@= A3.
  742update(0b10, Wrapper, M, A1, A2, A3, Action) :-
  743    !,
  744    (   is_subsumed_by(Wrapper, M, A2, A1)
  745    ->  Action = done
  746    ;   A3 = A2,
  747        Action = keep
  748    ).
  749update(0b01, Wrapper, M, A1, A2, A2, Action) :-
  750    !,
  751    (   is_subsumed_by(Wrapper, M, A1, A2)
  752    ->  Action = delete
  753    ;   Action = keep
  754    ).
  755update(0b00, _Wrapper, _M, _A1, A2, A2, keep) :-
  756    !.
  757
  758is_subsumed_by(Wrapper, M, Instance, General) :-
  759    M:'$table_update'(Wrapper, Instance, General, New),
  760    New =@= General.
  761
  762%!  completion(+Component, -Status, -Clause) is det.
  763%
  764%   Wakeup suspended goals until no new answers are generated. Status is
  765%   one of `merged`, `completed` or `final`.  If Status is not `merged`,
  766%   Clause is a compiled  representation  for   the  answer  trie of the
  767%   Component leader.
  768
  769completion(SCC, Status, Clause) :-
  770    (   reset_delays,
  771        completion_(SCC),
  772        fail
  773    ;   '$tbl_table_complete_all'(SCC, Status, Clause),
  774        tdebug(schedule, 'SCC ~p: ~p', [scc(SCC), Status])
  775    ).
  776
  777completion_(SCC) :-
  778    repeat,
  779    (   '$tbl_pop_worklist'(SCC, WorkList)
  780    ->  tdebug(wl_goal(WorkList, Goal, _)),
  781        tdebug(schedule, 'Complete ~p in ~p', [Goal, scc(SCC)]),
  782        completion_step(WorkList)
  783    ;   !
  784    ).
  785
  786%!  '$tbl_wkl_work'(+WorkList,
  787%!                  -Answer,
  788%!                  -Continuation, -Wrapper, -TargetWorklist,
  789%!                  -Delays) is nondet.
  790%
  791%   True when Continuation needs to run with Answer and possible answers
  792%   need to be added to  TargetWorklist.   The  remaining  arguments are
  793%   there to restore variable bindings and restore the delay list.
  794%
  795%   The  suspension  added  by  '$tbl_wkl_add_suspension'/2  is  a  term
  796%   dependency(SrcWrapper,  Continuation,  Wrapper,  WorkList,  Delays).
  797%   Note that:
  798%
  799%     - Answer and Goal must be unified to rebind the _input_ arguments
  800%       for the continuation.
  801%     - Wrapper is stored in TargetWorklist on successful completion
  802%       of the Continuation.
  803%     - If Answer Subsumption is in effect, the story is a bit more
  804%       complex and ModeArgs provide the binding over which we do
  805%       _aggregation_. Otherwise, ModeArgs is the the
  806%       reserved trie node produced by '$tbl_trienode'/1.
  807%
  808%   @arg Answer is the answer term from the answer cluster (node in
  809%   the answer trie).  For answer subsumption it is a term Ret/ModeArgs
  810%   @arg Goal to Delays are extracted from the dependency/5 term in
  811%   the same order.
  812
  813%!  completion_step(+Worklist) is fail.
  814
  815completion_step(SourceWL) :-
  816    '$tbl_wkl_work'(SourceWL,
  817                    Answer, Continuation, TargetSkeleton, TargetWL, Delays),
  818    tdebug(wl_goal(SourceWL, SourceGoal, _)),
  819    tdebug(wl_goal(TargetWL, TargetGoal, _Skeleton)),
  820    tdebug('$tbl_add_global_delays'(Delays, AllDelays)),
  821    tdebug(delay_goals(AllDelays, Cond)),
  822    tdebug(schedule, 'Resuming ~p, calling ~p with ~p (delays = ~p)',
  823           [TargetGoal, SourceGoal, Answer, Cond]),
  824    delim(TargetSkeleton, Continuation, TargetWL, Delays),
  825    fail.
  826
  827
  828		 /*******************************
  829		 *     STRATIFIED NEGATION	*
  830		 *******************************/
  831
  832%!  tnot(:Goal)
  833%
  834%   Tabled negation.
  835%
  836%   (*): Only variant tabling is allowed under tnot/1.
  837
  838tnot(Goal0) :-
  839    '$tnot_implementation'(Goal0, Goal),        % verifies Goal is tabled
  840    (   '$tbl_existing_variant_table'(_, Goal, Trie, Status, Skeleton)
  841    ->  (   '$tbl_answer_dl'(Trie, _, true)
  842        ->  fail
  843        ;   '$tbl_answer_dl'(Trie, _, _)
  844        ->  tdebug(tnot, 'tnot: adding ~p to delay list', [Goal]),
  845            add_delay(Trie)
  846        ;   Status == complete
  847        ->  true
  848        ;   negation_suspend(Goal, Skeleton, Status)
  849        )
  850    ;   tdebug(tnot, 'tnot: ~p: fresh', [Goal]),
  851        (   '$wrapped_implementation'(Goal, table, Implementation), % see (*)
  852            functor(Implementation, Closure, _),
  853            start_tabling(Closure, Goal, Implementation),
  854            fail
  855        ;   '$tbl_existing_variant_table'(_, Goal, Trie, NewStatus, NewSkeleton),
  856            tdebug(tnot, 'tnot: fresh ~p now ~p', [Goal, NewStatus]),
  857            (   '$tbl_answer_dl'(Trie, _, true)
  858            ->  fail
  859            ;   '$tbl_answer_dl'(Trie, _, _)
  860            ->  add_delay(Trie)
  861            ;   NewStatus == complete
  862            ->  true
  863            ;   negation_suspend(Goal, NewSkeleton, NewStatus)
  864            )
  865        )
  866    ).
  867
  868floundering(Goal) :-
  869    format(string(Comment), 'Floundering goal in tnot/1: ~p', [Goal]),
  870    throw(error(instantiation_error, context(_Stack, Comment))).
  871
  872
  873%!  negation_suspend(+Goal, +Skeleton, +Worklist)
  874%
  875%   Suspend Worklist due to negation. This marks the worklist as dealing
  876%   with a negative literal and suspend.
  877%
  878%   The completion step will resume  negative   worklists  that  have no
  879%   solutions, causing this to succeed.
  880
  881negation_suspend(Wrapper, Skeleton, Worklist) :-
  882    tdebug(tnot, 'negation_suspend ~p (wl=~p)', [Wrapper, Worklist]),
  883    '$tbl_wkl_negative'(Worklist),
  884    shift(call_info(Skeleton, tnot(Worklist))),
  885    tdebug(tnot, 'negation resume ~p (wl=~p)', [Wrapper, Worklist]),
  886    '$tbl_wkl_is_false'(Worklist).
  887
  888%!  not_exists(:P) is semidet.
  889%
  890%   Tabled negation for non-ground goals. This predicate uses the tabled
  891%   meta-predicate tabled_call/1. The tables  for xsb:tabled_call/1 must
  892%   be cleared if `the world changes' as   well  as to avoid aggregating
  893%   too many variants.
  894
  895not_exists(Goal) :-
  896    ground(Goal),
  897    '$get_predicate_attribute'(Goal, tabled, 1),
  898    !,
  899    tnot(Goal).
  900not_exists(Goal) :-
  901    (   tabled_call(Goal), fail
  902    ;   tnot(tabled_call(Goal))
  903    ).
  904
  905		 /*******************************
  906		 *           DELAY LISTS	*
  907		 *******************************/
  908
  909add_delay(Delay) :-
  910    '$tbl_delay_list'(DL0),
  911    '$tbl_set_delay_list'([Delay|DL0]).
  912
  913reset_delays :-
  914    '$tbl_set_delay_list'([]).
  915
  916%!  '$wfs_call'(:Goal, :Delays)
  917%
  918%   Call Goal and provide WFS delayed goals  as a conjunction in Delays.
  919%   This  predicate  is  the  internal  version  of  call_delays/2  from
  920%   library(wfs).
  921
  922'$wfs_call'(Goal, M:Delays) :-
  923    '$tbl_delay_list'(DL0),
  924    reset_delays,
  925    call(Goal),
  926    '$tbl_delay_list'(DL1),
  927    (   delay_goals(DL1, M, Delays)
  928    ->  true
  929    ;   Delays = undefined
  930    ),
  931    '$append'(DL0, DL1, DL),
  932    '$tbl_set_delay_list'(DL).
  933
  934delay_goals([], _, true) :-
  935    !.
  936delay_goals([AT+AN|T], M, Goal) :-
  937    !,
  938    (   integer(AN)
  939    ->  at_delay_goal(AT, M, G0, Answer, Moded),
  940        (   '$tbl_is_trienode'(Moded)
  941        ->  trie_term(AN, Answer)
  942        ;   true                        % TBD: Generated moded answer
  943        )
  944    ;   AN = Skeleton/ModeArgs
  945    ->  '$tbl_table_status'(AT, _, M1:GNoModes, Skeleton),
  946        M1:'$table_mode'(G0plain, GNoModes, ModeArgs),
  947        G0 = M1:G0plain
  948    ;   '$tbl_table_status'(AT, _, G0, AN)
  949    ),
  950    GN = G0,
  951    (   T == []
  952    ->  Goal = GN
  953    ;   Goal = (GN,GT),
  954        delay_goals(T, M, GT)
  955    ).
  956delay_goals([AT|T], M, Goal) :-
  957    atrie_goal(AT, G0),
  958    unqualify_goal(G0, M, G1),
  959    GN = tnot(G1),
  960    (   T == []
  961    ->  Goal = GN
  962    ;   Goal = (GN,GT),
  963        delay_goals(T, M, GT)
  964    ).
  965
  966at_delay_goal(tnot(Trie), M, tnot(Goal), Skeleton, Moded) :-
  967    is_trie(Trie),
  968    !,
  969    at_delay_goal(Trie, M, Goal, Skeleton, Moded).
  970at_delay_goal(Trie, M, Goal, Skeleton, Moded) :-
  971    is_trie(Trie),
  972    !,
  973    '$tbl_table_status'(Trie, _Status, M2:Variant, Skeleton),
  974    M2:'$table_mode'(Goal0, Variant, Moded),
  975    unqualify_goal(M2:Goal0, M, Goal).
  976
  977atrie_goal(Trie, M:Goal) :-
  978    '$tbl_table_status'(Trie, _Status, M:Variant, _Skeleton),
  979    M:'$table_mode'(Goal, Variant, _Moded).
  980
  981unqualify_goal(M:Goal, M, Goal0) :-
  982    !,
  983    Goal0 = Goal.
  984unqualify_goal(Goal, _, Goal).
  985
  986
  987                 /*******************************
  988                 *            CLEANUP           *
  989                 *******************************/
  990
  991%!  abolish_all_tables
  992%
  993%   Remove all tables. This is normally  used   to  free up the space or
  994%   recompute the result after predicates on   which the result for some
  995%   tabled predicates depend.
  996%
  997%   Abolishes both local and shared   tables. Possibly incomplete tables
  998%   are marked for destruction upon   completion.  The dependency graphs
  999%   for incremental and monotonic tabling are reclaimed as well.
 1000
 1001abolish_all_tables :-
 1002    (   '$tbl_abolish_local_tables'
 1003    ->  true
 1004    ;   true
 1005    ),
 1006    (   '$tbl_variant_table'(VariantTrie),
 1007        trie_gen(VariantTrie, _, Trie),
 1008        '$tbl_destroy_table'(Trie),
 1009        fail
 1010    ;   true
 1011    ).
 1012
 1013abolish_private_tables :-
 1014    (   '$tbl_abolish_local_tables'
 1015    ->  true
 1016    ;   (   '$tbl_local_variant_table'(VariantTrie),
 1017            trie_gen(VariantTrie, _, Trie),
 1018            '$tbl_destroy_table'(Trie),
 1019            fail
 1020        ;   true
 1021        )
 1022    ).
 1023
 1024abolish_shared_tables :-
 1025    (   '$tbl_global_variant_table'(VariantTrie),
 1026        trie_gen(VariantTrie, _, Trie),
 1027        '$tbl_destroy_table'(Trie),
 1028        fail
 1029    ;   true
 1030    ).
 1031
 1032%!  abolish_table_subgoals(:Subgoal) is det.
 1033%
 1034%   Abolish all tables that unify with SubGoal.
 1035%
 1036%   @tbd: SubGoal must be callable.  Should we allow for more general
 1037%   patterns?
 1038
 1039abolish_table_subgoals(SubGoal0) :-
 1040    '$tbl_implementation'(SubGoal0, M:SubGoal),
 1041    !,
 1042    '$must_be'(acyclic, SubGoal),
 1043    (   '$tbl_variant_table'(VariantTrie),
 1044        trie_gen(VariantTrie, M:SubGoal, Trie),
 1045        '$tbl_destroy_table'(Trie),
 1046        fail
 1047    ;   true
 1048    ).
 1049abolish_table_subgoals(_).
 1050
 1051%!  abolish_module_tables(+Module) is det.
 1052%
 1053%   Abolish all tables for predicates associated with the given module.
 1054
 1055abolish_module_tables(Module) :-
 1056    '$must_be'(atom, Module),
 1057    '$tbl_variant_table'(VariantTrie),
 1058    current_module(Module),
 1059    !,
 1060    forall(trie_gen(VariantTrie, Module:_, Trie),
 1061           '$tbl_destroy_table'(Trie)).
 1062abolish_module_tables(_).
 1063
 1064%!  abolish_nonincremental_tables is det.
 1065%
 1066%   Abolish all tables that are not related to incremental predicates.
 1067
 1068abolish_nonincremental_tables :-
 1069    (   '$tbl_variant_table'(VariantTrie),
 1070        trie_gen(VariantTrie, _, Trie),
 1071        '$tbl_table_status'(Trie, Status, Goal, _),
 1072        (   Status == complete
 1073        ->  true
 1074        ;   '$permission_error'(abolish, incomplete_table, Trie)
 1075        ),
 1076        \+ predicate_property(Goal, incremental),
 1077        '$tbl_destroy_table'(Trie),
 1078        fail
 1079    ;   true
 1080    ).
 1081
 1082%!  abolish_nonincremental_tables(+Options)
 1083%
 1084%   Allow for skipping incomplete tables while abolishing.
 1085%
 1086%   @tbd Mark tables for destruction such   that they are abolished when
 1087%   completed.
 1088
 1089abolish_nonincremental_tables(Options) :-
 1090    (   Options = on_incomplete(Action)
 1091    ->  Action == skip
 1092    ;   '$option'(on_incomplete(skip), Options)
 1093    ),
 1094    !,
 1095    (   '$tbl_variant_table'(VariantTrie),
 1096        trie_gen(VariantTrie, _, Trie),
 1097        '$tbl_table_status'(Trie, complete, Goal, _),
 1098        \+ predicate_property(Goal, incremental),
 1099        '$tbl_destroy_table'(Trie),
 1100        fail
 1101    ;   true
 1102    ).
 1103abolish_nonincremental_tables(_) :-
 1104    abolish_nonincremental_tables.
 1105
 1106
 1107                 /*******************************
 1108                 *        EXAMINE TABLES        *
 1109                 *******************************/
 1110
 1111%!  current_table(:Variant, -Trie) is nondet.
 1112%
 1113%   True when Trie is the answer table   for  Variant. If Variant has an
 1114%   unbound module or goal, all  possible   answer  tries are generated,
 1115%   otherwise Variant is considered a fully instantiated variant and the
 1116%   predicate is semidet.
 1117
 1118current_table(Variant, Trie) :-
 1119    ct_generate(Variant),
 1120    !,
 1121    current_table_gen(Variant, Trie).
 1122current_table(Variant, Trie) :-
 1123    current_table_lookup(Variant, Trie),
 1124    !.
 1125
 1126current_table_gen(M:Variant, Trie) :-
 1127    '$tbl_local_variant_table'(VariantTrie),
 1128    trie_gen(VariantTrie, M:NonModed, Trie),
 1129    M:'$table_mode'(Variant, NonModed, _Moded).
 1130current_table_gen(M:Variant, Trie) :-
 1131    '$tbl_global_variant_table'(VariantTrie),
 1132    trie_gen(VariantTrie, M:NonModed, Trie),
 1133    \+ '$tbl_table_status'(Trie, fresh), % shared tables are not destroyed
 1134    M:'$table_mode'(Variant, NonModed, _Moded).
 1135
 1136current_table_lookup(M:Variant, Trie) :-
 1137    M:'$table_mode'(Variant, NonModed, _Moded),
 1138    '$tbl_local_variant_table'(VariantTrie),
 1139    trie_lookup(VariantTrie, M:NonModed, Trie).
 1140current_table_lookup(M:Variant, Trie) :-
 1141    M:'$table_mode'(Variant, NonModed, _Moded),
 1142    '$tbl_global_variant_table'(VariantTrie),
 1143    trie_lookup(VariantTrie, NonModed, Trie),
 1144    \+ '$tbl_table_status'(Trie, fresh).
 1145
 1146ct_generate(M:Variant) :-
 1147    (   var(Variant)
 1148    ->  true
 1149    ;   var(M)
 1150    ).
 1151
 1152                 /*******************************
 1153                 *      WRAPPER GENERATION      *
 1154                 *******************************/
 1155
 1156:- multifile
 1157    system:term_expansion/2,
 1158    tabled/2. 1159:- dynamic
 1160    system:term_expansion/2. 1161
 1162wrappers(Spec, M) -->
 1163    { tabling_defaults(
 1164          [ (table_incremental=true)            - (incremental=true),
 1165            (table_shared=true)                 - (tshared=true),
 1166            (table_subsumptive=true)            - ((mode)=subsumptive),
 1167            call(subgoal_size_restraint(Level)) - (subgoal_abstract=Level)
 1168          ],
 1169          #{}, Defaults)
 1170    },
 1171    wrappers(Spec, M, Defaults).
 1172
 1173wrappers(Var, _, _) -->
 1174    { var(Var),
 1175      !,
 1176      '$instantiation_error'(Var)
 1177    }.
 1178wrappers(M:Spec, _, Opts) -->
 1179    !,
 1180    { '$must_be'(atom, M) },
 1181    wrappers(Spec, M, Opts).
 1182wrappers(Spec as Options, M, Opts0) -->
 1183    !,
 1184    { table_options(Options, Opts0, Opts) },
 1185    wrappers(Spec, M, Opts).
 1186wrappers((A,B), M, Opts) -->
 1187    !,
 1188    wrappers(A, M, Opts),
 1189    wrappers(B, M, Opts).
 1190wrappers(Name//Arity, M, Opts) -->
 1191    { atom(Name), integer(Arity), Arity >= 0,
 1192      !,
 1193      Arity1 is Arity+2
 1194    },
 1195    wrappers(Name/Arity1, M, Opts).
 1196wrappers(Name/Arity, Module, Opts) -->
 1197    { '$option'(mode(TMode), Opts, variant),
 1198      atom(Name), integer(Arity), Arity >= 0,
 1199      !,
 1200      functor(Head, Name, Arity),
 1201      '$tbl_trienode'(Reserved)
 1202    },
 1203    qualify(Module,
 1204            [ '$tabled'(Head, TMode),
 1205              '$table_mode'(Head, Head, Reserved)
 1206            ]),
 1207    [ (:- initialization('$wrap_tabled'(Module:Head, Opts), now))
 1208    ].
 1209wrappers(ModeDirectedSpec, Module, Opts) -->
 1210    { '$option'(mode(TMode), Opts, variant),
 1211      callable(ModeDirectedSpec),
 1212      !,
 1213      functor(ModeDirectedSpec, Name, Arity),
 1214      functor(Head, Name, Arity),
 1215      extract_modes(ModeDirectedSpec, Head, Variant, Modes, Moded),
 1216      updater_clauses(Modes, Head, UpdateClauses),
 1217      mode_check(Moded, ModeTest),
 1218      (   ModeTest == true
 1219      ->  WrapClause = '$wrap_tabled'(Module:Head, Opts),
 1220          TVariant = Head
 1221      ;   WrapClause = '$moded_wrap_tabled'(Module:Head, Opts, ModeTest,
 1222                                            Module:Variant, Moded),
 1223          TVariant = Variant
 1224      )
 1225    },
 1226    qualify(Module,
 1227            [ '$tabled'(Head, TMode),
 1228              '$table_mode'(Head, TVariant, Moded)
 1229            ]),
 1230    [ (:- initialization(WrapClause, now))
 1231    ],
 1232    qualify(Module, UpdateClauses).
 1233wrappers(TableSpec, _M, _Opts) -->
 1234    { '$type_error'(table_desclaration, TableSpec)
 1235    }.
 1236
 1237qualify(Module, List) -->
 1238    { prolog_load_context(module, Module) },
 1239    !,
 1240    clist(List).
 1241qualify(Module, List) -->
 1242    qlist(List, Module).
 1243
 1244clist([])    --> [].
 1245clist([H|T]) --> [H], clist(T).
 1246
 1247qlist([], _)    --> [].
 1248qlist([H|T], M) --> [M:H], qlist(T, M).
 1249
 1250
 1251tabling_defaults([], Dict, Dict).
 1252tabling_defaults([Condition-(Opt=Value)|T], Dict0, Dict) :-
 1253    (   tabling_default(Condition)
 1254    ->  Dict1 = Dict0.put(Opt,Value)
 1255    ;   Dict1 = Dict0
 1256    ),
 1257    tabling_defaults(T, Dict1, Dict).
 1258
 1259tabling_default(Flag=FValue) :-
 1260    !,
 1261    current_prolog_flag(Flag, FValue).
 1262tabling_default(call(Term)) :-
 1263    call(Term).
 1264
 1265% Called from wrappers//2.
 1266
 1267subgoal_size_restraint(Level) :-
 1268    current_prolog_flag(max_table_subgoal_size_action, abstract),
 1269    current_prolog_flag(max_table_subgoal_size, Level).
 1270
 1271%!  table_options(+Options, +OptDictIn, -OptDictOut)
 1272%
 1273%   Handler the ... as _options_ ... construct.
 1274
 1275table_options(Options, _Opts0, _Opts) :-
 1276    var(Options),
 1277    '$instantiation_error'(Options).
 1278table_options((A,B), Opts0, Opts) :-
 1279    !,
 1280    table_options(A, Opts0, Opts1),
 1281    table_options(B, Opts1, Opts).
 1282table_options(subsumptive, Opts0, Opts1) :-
 1283    !,
 1284    put_dict(mode, Opts0, subsumptive, Opts1).
 1285table_options(variant, Opts0, Opts1) :-
 1286    !,
 1287    put_dict(mode, Opts0, variant, Opts1).
 1288table_options(incremental, Opts0, Opts1) :-
 1289    !,
 1290    put_dict(#{incremental:true,opaque:false}, Opts0, Opts1).
 1291table_options(monotonic, Opts0, Opts1) :-
 1292    !,
 1293    put_dict(monotonic, Opts0, true, Opts1).
 1294table_options(opaque, Opts0, Opts1) :-
 1295    !,
 1296    put_dict(#{incremental:false,opaque:true}, Opts0, Opts1).
 1297table_options(lazy, Opts0, Opts1) :-
 1298    !,
 1299    put_dict(lazy, Opts0, true, Opts1).
 1300table_options(dynamic, Opts0, Opts1) :-
 1301    !,
 1302    put_dict(dynamic, Opts0, true, Opts1).
 1303table_options(shared, Opts0, Opts1) :-
 1304    !,
 1305    put_dict(tshared, Opts0, true, Opts1).
 1306table_options(private, Opts0, Opts1) :-
 1307    !,
 1308    put_dict(tshared, Opts0, false, Opts1).
 1309table_options(max_answers(Count), Opts0, Opts1) :-
 1310    !,
 1311    restraint(max_answers, Count, Opts0, Opts1).
 1312table_options(subgoal_abstract(Size), Opts0, Opts1) :-
 1313    !,
 1314    restraint(subgoal_abstract, Size, Opts0, Opts1).
 1315table_options(answer_abstract(Size), Opts0, Opts1) :-
 1316    !,
 1317    restraint(answer_abstract, Size, Opts0, Opts1).
 1318table_options(Opt, _, _) :-
 1319    '$domain_error'(table_option, Opt).
 1320
 1321restraint(Name, Value0, Opts0, Opts) :-
 1322    '$table_option'(Value0, Value),
 1323    (   Value < 0
 1324    ->  Opts = Opts0
 1325    ;   put_dict(Name, Opts0, Value, Opts)
 1326    ).
 1327
 1328
 1329%!  mode_check(+Moded, -TestCode)
 1330%
 1331%   Enforce the output arguments of a  mode-directed tabled predicate to
 1332%   be unbound.
 1333
 1334mode_check(Moded, Check) :-
 1335    var(Moded),
 1336    !,
 1337    Check = (var(Moded)->true;'$uninstantiation_error'(Moded)).
 1338mode_check(Moded, true) :-
 1339    '$tbl_trienode'(Moded),
 1340    !.
 1341mode_check(Moded, (Test->true;'$tabling':instantiated_moded_arg(Vars))) :-
 1342    Moded =.. [s|Vars],
 1343    var_check(Vars, Test).
 1344
 1345var_check([H|T], Test) :-
 1346    (   T == []
 1347    ->  Test = var(H)
 1348    ;   Test = (var(H),Rest),
 1349        var_check(T, Rest)
 1350    ).
 1351
 1352:- public
 1353    instantiated_moded_arg/1. 1354
 1355instantiated_moded_arg(Vars) :-
 1356    '$member'(V, Vars),
 1357    \+ var(V),
 1358    '$uninstantiation_error'(V).
 1359
 1360
 1361%!  extract_modes(+ModeSpec, +Head, -Variant, -Modes, -ModedAnswer) is det.
 1362%
 1363%   Split Head into  its  variant  and   term  that  matches  the  moded
 1364%   arguments.
 1365%
 1366%   @arg ModedAnswer is a term that  captures   that  value of all moded
 1367%   arguments of an answer. If there  is   only  one,  this is the value
 1368%   itself. If there are multiple, this is a term s(A1,A2,...)
 1369
 1370extract_modes(ModeSpec, Head, Variant, Modes, ModedAnswer) :-
 1371    compound(ModeSpec),
 1372    !,
 1373    compound_name_arguments(ModeSpec, Name, ModeSpecArgs),
 1374    compound_name_arguments(Head, Name, HeadArgs),
 1375    separate_args(ModeSpecArgs, HeadArgs, VariantArgs, Modes, ModedArgs),
 1376    length(ModedArgs, Count),
 1377    atomic_list_concat([$,Name,$,Count], VName),
 1378    Variant =.. [VName|VariantArgs],
 1379    (   ModedArgs == []
 1380    ->  '$tbl_trienode'(ModedAnswer)
 1381    ;   ModedArgs = [ModedAnswer]
 1382    ->  true
 1383    ;   ModedAnswer =.. [s|ModedArgs]
 1384    ).
 1385extract_modes(Atom, Atom, Variant, [], ModedAnswer) :-
 1386    atomic_list_concat([$,Atom,$,0], Variant),
 1387    '$tbl_trienode'(ModedAnswer).
 1388
 1389%!  separate_args(+ModeSpecArgs, +HeadArgs,
 1390%!		  -NoModesArgs, -Modes, -ModeArgs) is det.
 1391%
 1392%   Split the arguments in those that  need   to  be part of the variant
 1393%   identity (NoModesArgs) and those that are aggregated (ModeArgs).
 1394%
 1395%   @arg Args seems a copy of ModeArgs, why?
 1396
 1397separate_args([], [], [], [], []).
 1398separate_args([HM|TM], [H|TA], [H|TNA], Modes, TMA):-
 1399    indexed_mode(HM),
 1400    !,
 1401    separate_args(TM, TA, TNA, Modes, TMA).
 1402separate_args([M|TM], [H|TA], TNA, [M|Modes], [H|TMA]):-
 1403    separate_args(TM, TA, TNA, Modes, TMA).
 1404
 1405indexed_mode(Mode) :-                           % XSB
 1406    var(Mode),
 1407    !.
 1408indexed_mode(index).                            % YAP
 1409indexed_mode(+).                                % B
 1410
 1411%!  updater_clauses(+Modes, +Head, -Clauses)
 1412%
 1413%   Generates a clause to update the aggregated state.  Modes is
 1414%   a list of predicate names we apply to the state.
 1415
 1416updater_clauses([], _, []) :- !.
 1417updater_clauses([P], Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :- !,
 1418    update_goal(P, S0,S1,S2, Body).
 1419updater_clauses(Modes, Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :-
 1420    length(Modes, Len),
 1421    functor(S0, s, Len),
 1422    functor(S1, s, Len),
 1423    functor(S2, s, Len),
 1424    S0 =.. [_|Args0],
 1425    S1 =.. [_|Args1],
 1426    S2 =.. [_|Args2],
 1427    update_body(Modes, Args0, Args1, Args2, true, Body).
 1428
 1429update_body([], _, _, _, Body, Body).
 1430update_body([P|TM], [A0|Args0], [A1|Args1], [A2|Args2], Body0, Body) :-
 1431    update_goal(P, A0,A1,A2, Goal),
 1432    mkconj(Body0, Goal, Body1),
 1433    update_body(TM, Args0, Args1, Args2, Body1, Body).
 1434
 1435update_goal(Var, _,_,_, _) :-
 1436    var(Var),
 1437    !,
 1438    '$instantiation_error'(Var).
 1439update_goal(lattice(M:PI), S0,S1,S2, M:Goal) :-
 1440    !,
 1441    '$must_be'(atom, M),
 1442    update_goal(lattice(PI), S0,S1,S2, Goal).
 1443update_goal(lattice(Name/Arity), S0,S1,S2, Goal) :-
 1444    !,
 1445    '$must_be'(oneof(integer, lattice_arity, [3]), Arity),
 1446    '$must_be'(atom, Name),
 1447    Goal =.. [Name,S0,S1,S2].
 1448update_goal(lattice(Head), S0,S1,S2, Goal) :-
 1449    compound(Head),
 1450    !,
 1451    compound_name_arity(Head, Name, Arity),
 1452    '$must_be'(oneof(integer, lattice_arity, [3]), Arity),
 1453    Goal =.. [Name,S0,S1,S2].
 1454update_goal(lattice(Name), S0,S1,S2, Goal) :-
 1455    !,
 1456    '$must_be'(atom, Name),
 1457    update_goal(lattice(Name/3), S0,S1,S2, Goal).
 1458update_goal(po(Name/Arity), S0,S1,S2, Goal) :-
 1459    !,
 1460    '$must_be'(oneof(integer, po_arity, [2]), Arity),
 1461    '$must_be'(atom, Name),
 1462    Call =.. [Name, S0, S1],
 1463    Goal = (Call -> S2 = S0 ; S2 = S1).
 1464update_goal(po(M:Name/Arity), S0,S1,S2, Goal) :-
 1465    !,
 1466    '$must_be'(atom, M),
 1467    '$must_be'(oneof(integer, po_arity, [2]), Arity),
 1468    '$must_be'(atom, Name),
 1469    Call =.. [Name, S0, S1],
 1470    Goal = (M:Call -> S2 = S0 ; S2 = S1).
 1471update_goal(po(M:Name), S0,S1,S2, Goal) :-
 1472    !,
 1473    '$must_be'(atom, M),
 1474    '$must_be'(atom, Name),
 1475    update_goal(po(M:Name/2), S0,S1,S2, Goal).
 1476update_goal(po(Name), S0,S1,S2, Goal) :-
 1477    !,
 1478    '$must_be'(atom, Name),
 1479    update_goal(po(Name/2), S0,S1,S2, Goal).
 1480update_goal(Alias, S0,S1,S2, Goal) :-
 1481    update_alias(Alias, Update),
 1482    !,
 1483    update_goal(Update, S0,S1,S2, Goal).
 1484update_goal(Mode, _,_,_, _) :-
 1485    '$domain_error'(tabled_mode, Mode).
 1486
 1487update_alias(first, lattice('$tabling':first/3)).
 1488update_alias(-,     lattice('$tabling':first/3)).
 1489update_alias(last,  lattice('$tabling':last/3)).
 1490update_alias(min,   lattice('$tabling':min/3)).
 1491update_alias(max,   lattice('$tabling':max/3)).
 1492update_alias(sum,   lattice('$tabling':sum/3)).
 1493
 1494mkconj(true, G,  G) :- !.
 1495mkconj(G1,   G2, (G1,G2)).
 1496
 1497
 1498		 /*******************************
 1499		 *          AGGREGATION		*
 1500		 *******************************/
 1501
 1502%!  first(+S0, +S1, -S) is det.
 1503%!  last(+S0, +S1, -S) is det.
 1504%!  min(+S0, +S1, -S) is det.
 1505%!  max(+S0, +S1, -S) is det.
 1506%!  sum(+S0, +S1, -S) is det.
 1507%
 1508%   Implement YAP tabling modes.
 1509
 1510:- public first/3, last/3, min/3, max/3, sum/3. 1511
 1512first(S, _, S).
 1513last(_, S, S).
 1514min(S0, S1, S) :- (S0 @< S1 -> S = S0 ; S = S1).
 1515max(S0, S1, S) :- (S0 @> S1 -> S = S0 ; S = S1).
 1516sum(S0, S1, S) :- S is S0+S1.
 1517
 1518
 1519		 /*******************************
 1520		 *      DYNAMIC PREDICATES	*
 1521		 *******************************/
 1522
 1523%!  '$set_table_wrappers'(:Head)
 1524%
 1525%   Clear/add wrappers and notifications to trap dynamic predicates.
 1526%   This is required both for incremental and monotonic tabling.
 1527
 1528'$set_table_wrappers'(Pred) :-
 1529    (   '$get_predicate_attribute'(Pred, incremental, 1),
 1530        \+ '$get_predicate_attribute'(Pred, opaque, 1)
 1531    ->  wrap_incremental(Pred)
 1532    ;   unwrap_incremental(Pred)
 1533    ),
 1534    (   '$get_predicate_attribute'(Pred, monotonic, 1)
 1535    ->  wrap_monotonic(Pred)
 1536    ;   unwrap_monotonic(Pred)
 1537    ).
 1538
 1539		 /*******************************
 1540		 *       MONOTONIC TABLING	*
 1541		 *******************************/
 1542
 1543%!  mon_assert_dep(+Dependency, +Continuation, +Skel, +ATrie) is det.
 1544%
 1545%   Create a dependency for monotonic tabling.   Skel  and ATrie are the
 1546%   target trie for solutions of Continuation.
 1547
 1548mon_assert_dep(dependency(Dynamic), Cont, Skel, ATrie) :-
 1549    '$idg_add_mono_dyn_dep'(Dynamic,
 1550                            dependency(Dynamic, Cont, Skel),
 1551                            ATrie).
 1552mon_assert_dep(dependency(SrcSkel, SrcTrie, IsMono), Cont, Skel, ATrie) :-
 1553    '$idg_add_monotonic_dep'(SrcTrie,
 1554                             dependency(SrcSkel, IsMono, Cont, Skel),
 1555                             ATrie).
 1556
 1557%!  monotonic_affects(+SrcTrie, +SrcReturn, -IsMono,
 1558%!                    -Continuation, -Return, -Atrie)
 1559%
 1560%   Dependency between two monotonic tables. If   SrcReturn  is added to
 1561%   SrcTrie we must add all answers for Return of Continuation to Atrie.
 1562%   IsMono shares with Continuation and is   used  in start_tabling/3 to
 1563%   distinguish normal tabled call from propagation.
 1564
 1565monotonic_affects(SrcTrie, SrcSkel, IsMono, Cont, Skel, ATrie) :-
 1566    '$idg_mono_affects_eager'(SrcTrie, ATrie,
 1567                              dependency(SrcSkel, IsMono, Cont, Skel)).
 1568
 1569%!  monotonic_dyn_affects(:Head, -Continuation, -Return, -ATrie)
 1570%
 1571%   Dynamic predicate that maintains  the   dependency  from a monotonic
 1572
 1573monotonic_dyn_affects(Head, Cont, Skel, ATrie) :-
 1574    dyn_affected(Head, DTrie),
 1575    '$idg_mono_affects_eager'(DTrie, ATrie,
 1576                              dependency(Head, Cont, Skel)).
 1577
 1578%!  wrap_monotonic(:Head)
 1579%
 1580%   Prepare the dynamic predicate Head for monotonic tabling. This traps
 1581%   calls to build the dependency graph and updates to propagate answers
 1582%   from new clauses through the dependency graph.
 1583
 1584wrap_monotonic(Head) :-
 1585    '$wrap_predicate'(Head, monotonic, _Closure, Wrapped,
 1586                      '$start_monotonic'(Head, Wrapped)),
 1587    '$pi_head'(PI, Head),
 1588    prolog_listen(PI, monotonic_update).
 1589
 1590%!  unwrap_monotonic(+Head)
 1591%
 1592%   Remove the monotonic wrappers and dependencies.
 1593
 1594unwrap_monotonic(Head) :-
 1595    '$pi_head'(PI, Head),
 1596    (   unwrap_predicate(PI, monotonic)
 1597    ->  prolog_unlisten(PI, monotonic_update)
 1598    ;   true
 1599    ).
 1600
 1601%!  '$start_monotonic'(+Head, +Wrapped)
 1602%
 1603%   This is called the monotonic wrapper   around a dynamic predicate to
 1604%   collect the dependencies  between  the   dynamic  predicate  and the
 1605%   monotonic tabled predicates.
 1606
 1607'$start_monotonic'(Head, Wrapped) :-
 1608    (   '$tbl_collect_mono_dep'
 1609    ->  shift(dependency(Head)),
 1610        tdebug(monotonic, 'Cont in $start_dynamic/2 with ~p', [Head]),
 1611        Wrapped,
 1612        tdebug(monotonic, '  --> ~p', [Head])
 1613    ;   Wrapped
 1614    ).
 1615
 1616%!  monotonic_update(+Action, +ClauseRef)
 1617%
 1618%   Trap changes to the monotonic dynamic predicate and forward them.
 1619
 1620:- public monotonic_update/2. 1621monotonic_update(Action, ClauseRef) :-
 1622    (   atomic(ClauseRef)                       % avoid retractall, start(_)
 1623    ->  '$clause'(Head, _Body, ClauseRef, _Bindings),
 1624        mon_propagate(Action, Head, ClauseRef)
 1625    ;   true
 1626    ).
 1627
 1628%!  mon_propagate(+Action, +Head, +ClauseRef)
 1629%
 1630%   Handle changes to a dynamic predicate as part of monotonic
 1631%   updates.
 1632
 1633mon_propagate(Action, Head, ClauseRef) :-
 1634    assert_action(Action),
 1635    !,
 1636    setup_call_cleanup(
 1637        '$tbl_propagate_start'(Old),
 1638        propagate_assert(Head),
 1639        '$tbl_propagate_end'(Old)),
 1640    forall(dyn_affected(Head, ATrie),
 1641           '$mono_idg_changed'(ATrie, ClauseRef)).
 1642mon_propagate(retract, Head, _) :-
 1643    !,
 1644    mon_invalidate_dependents(Head).
 1645mon_propagate(rollback(Action), Head, _) :-
 1646    mon_propagate_rollback(Action, Head).
 1647
 1648mon_propagate_rollback(Action, _Head) :-
 1649    assert_action(Action),
 1650    !.
 1651mon_propagate_rollback(retract, Head) :-
 1652    mon_invalidate_dependents(Head).
 1653
 1654assert_action(asserta).
 1655assert_action(assertz).
 1656
 1657%!  propagate_assert(+Head) is det.
 1658%
 1659%   Propagate assertion of a dynamic clause with head Head.
 1660
 1661propagate_assert(Head) :-
 1662    tdebug(monotonic, 'Asserted ~p', [Head]),
 1663    (   monotonic_dyn_affects(Head, Cont, Skel, ATrie),
 1664        tdebug(monotonic, 'Propagating dyn ~p to ~p', [Head, ATrie]),
 1665        '$idg_set_current'(_, ATrie),
 1666        pdelim(Cont, Skel, ATrie),
 1667        fail
 1668    ;   true
 1669    ).
 1670
 1671%!  propagate_answer(+SrcTrie, +SrcSkel) is det.
 1672%
 1673%   Propagate the new answer SrcSkel to the answer table SrcTrie.
 1674
 1675propagate_answer(SrcTrie, SrcSkel) :-
 1676    (   monotonic_affects(SrcTrie, SrcSkel, true, Cont, Skel, ATrie),
 1677        tdebug(monotonic, 'Propagating tab ~p to ~p', [SrcTrie, ATrie]),
 1678        pdelim(Cont, Skel, ATrie),
 1679        fail
 1680    ;   true
 1681    ).
 1682
 1683%!  pdelim(+Worker, +Skel, +ATrie)
 1684%
 1685%   Call Worker (a continuation) and add   each  binding it provides for
 1686%   Skel  to  ATrie.  If  a  new  answer    is  added  to  ATrie,  using
 1687%   propagate_answer/2 to propagate this further. Note   that we may hit
 1688%   new dependencies and thus we need to run this using reset/3.
 1689%
 1690%   @tbd Not sure whether we need full   tabling  here. Need to think of
 1691%   test cases.
 1692
 1693pdelim(Worker, Skel, ATrie) :-
 1694    reset(Worker, Dep, Cont),
 1695    (   Cont == 0
 1696    ->  '$tbl_monotonic_add_answer'(ATrie, Skel),
 1697        propagate_answer(ATrie, Skel)
 1698    ;   mon_assert_dep(Dep, Cont, Skel, ATrie),
 1699        pdelim(Cont, Skel, ATrie)
 1700    ).
 1701
 1702%!  mon_invalidate_dependents(+Head)
 1703%
 1704%   A non-monotonic operation was done on Head. Invalidate all dependent
 1705%   tables, preparing for normal incremental   reevaluation  on the next
 1706%   cycle.
 1707
 1708mon_invalidate_dependents(Head) :-
 1709    tdebug(monotonic, 'Invalidate dependents for ~p', [Head]),
 1710    forall(dyn_affected(Head, ATrie),
 1711           '$idg_mono_invalidate'(ATrie)).
 1712
 1713%!  abolish_monotonic_tables
 1714%
 1715%   Abolish all monotonic tables and the monotonic dependency relations.
 1716%
 1717%   @tbd: just prepare for incremental reevaluation?
 1718
 1719abolish_monotonic_tables :-
 1720    (   '$tbl_variant_table'(VariantTrie),
 1721        trie_gen(VariantTrie, Goal, ATrie),
 1722        '$get_predicate_attribute'(Goal, monotonic, 1),
 1723        '$tbl_destroy_table'(ATrie),
 1724        fail
 1725    ;   true
 1726    ).
 1727
 1728		 /*******************************
 1729		 *      INCREMENTAL TABLING	*
 1730		 *******************************/
 1731
 1732%!  wrap_incremental(:Head) is det.
 1733%
 1734%   Wrap an incremental dynamic predicate to be added to the IDG.
 1735
 1736wrap_incremental(Head) :-
 1737    tdebug(monotonic, 'Wrapping ~p', [Head]),
 1738    abstract_goal(Head, Abstract),
 1739    '$pi_head'(PI, Head),
 1740    (   Head == Abstract
 1741    ->  prolog_listen(PI, dyn_update)
 1742    ;   prolog_listen(PI, dyn_update(Abstract))
 1743    ).
 1744
 1745abstract_goal(M:Head, M:Abstract) :-
 1746    compound(Head),
 1747    '$get_predicate_attribute'(M:Head, abstract, 1),
 1748    !,
 1749    compound_name_arity(Head, Name, Arity),
 1750    functor(Abstract, Name, Arity).
 1751abstract_goal(Head, Head).
 1752
 1753%!  dyn_update(+Action, +Context) is det.
 1754%
 1755%   Track changes to added or removed clauses. We use '$clause'/4
 1756%   because it works on erased clauses.
 1757%
 1758%   @tbd Add a '$clause_head'(-Head, +ClauseRef) to only decompile the
 1759%   head.
 1760
 1761:- public dyn_update/2, dyn_update/3. 1762
 1763dyn_update(_Action, ClauseRef) :-
 1764    (   atomic(ClauseRef)                       % avoid retractall, start(_)
 1765    ->  '$clause'(Head, _Body, ClauseRef, _Bindings),
 1766        dyn_changed_pattern(Head)
 1767    ;   true
 1768    ).
 1769
 1770dyn_update(Abstract, _, _) :-
 1771    dyn_changed_pattern(Abstract).
 1772
 1773dyn_changed_pattern(Term) :-
 1774    forall(dyn_affected(Term, ATrie),
 1775           '$idg_changed'(ATrie)).
 1776
 1777dyn_affected(Term, ATrie) :-
 1778    '$tbl_variant_table'(VTable),
 1779    trie_gen(VTable, Term, ATrie).
 1780
 1781%!  unwrap_incremental(:Head) is det.
 1782%
 1783%   Remove dynamic predicate incremenal forwarding,   reset the possible
 1784%   `abstract` property and remove possible tables.
 1785
 1786unwrap_incremental(Head) :-
 1787    '$pi_head'(PI, Head),
 1788    abstract_goal(Head, Abstract),
 1789    (   Head == Abstract
 1790    ->  prolog_unlisten(PI, dyn_update)
 1791    ;   '$set_predicate_attribute'(Head, abstract, 0),
 1792        prolog_unlisten(PI, dyn_update(_))
 1793    ),
 1794    (   '$tbl_variant_table'(VariantTrie)
 1795    ->  forall(trie_gen(VariantTrie, Head, ATrie),
 1796               '$tbl_destroy_table'(ATrie))
 1797    ;   true
 1798    ).
 1799
 1800%!  reeval(+ATrie, :Goal, ?Return) is nondet.
 1801%
 1802%   Called  if  the   table   ATrie    is   out-of-date   (has  non-zero
 1803%   _falsecount_). The answers of this predicate are the answers to Goal
 1804%   after re-evaluating the answer trie.
 1805%
 1806%   This finds all dependency  paths  to   dynamic  predicates  and then
 1807%   evaluates the nodes in a breath-first  fashion starting at the level
 1808%   just above the dynamic predicates  and   moving  upwards.  Bottom up
 1809%   evaluation is used to profit from upward propagation of not-modified
 1810%   events that may cause the evaluation to stop early.
 1811%
 1812%   Note that false paths either end  in   a  dynamic node or a complete
 1813%   node. The latter happens if we have and  IDG   "D  -> P -> Q" and we
 1814%   first re-evaluate P for some reason.  Now   Q  can  still be invalid
 1815%   after P has been re-evaluated.
 1816%
 1817%   @arg ATrie is the answer trie.  When shared tabling, we own this
 1818%   trie.
 1819%   @arg Goal is tabled goal (variant).  If we run into a deadlock we
 1820%   need to call this.
 1821%   @arg Return is the return skeleton. We must run
 1822%   trie_gen_compiled(ATrie, Return) to enumerate the answers
 1823
 1824reeval(ATrie, Goal, Return) :-
 1825    catch(try_reeval(ATrie, Goal, Return), deadlock,
 1826          retry_reeval(ATrie, Goal)).
 1827
 1828retry_reeval(ATrie, Goal) :-
 1829    '$tbl_reeval_abandon'(ATrie),
 1830    tdebug(deadlock, 'Deadlock re-evaluating ~p; retrying', [ATrie]),
 1831    sleep(0.000001),
 1832    call(Goal).
 1833
 1834try_reeval(ATrie, Goal, Return) :-
 1835    nb_current('$tbl_reeval', true),
 1836    !,
 1837    tdebug(reeval, 'Nested re-evaluation for ~p', [ATrie]),
 1838    do_reeval(ATrie, Goal, Return).
 1839try_reeval(ATrie, Goal, Return) :-
 1840    tdebug(reeval, 'Planning reeval for ~p', [ATrie]),
 1841    findall(Path, false_path(ATrie, Path), Paths0),
 1842    sort(0, @>, Paths0, Paths),
 1843    split_paths(Paths, Dynamic, Complete),
 1844    tdebug(forall('$member'(Path, Dynamic),
 1845                  tdebug(reeval, '  Re-eval dynamic path: ~p', [Path]))),
 1846    tdebug(forall('$member'(Path, Complete),
 1847                  tdebug(reeval, '  Re-eval complete path: ~p', [Path]))),
 1848    reeval_paths(Dynamic, ATrie),
 1849    reeval_paths(Complete, ATrie),
 1850    do_reeval(ATrie, Goal, Return).
 1851
 1852do_reeval(ATrie, Goal, Return) :-
 1853    '$tbl_reeval_prepare_top'(ATrie, Clause),
 1854    (   Clause == 0                          % complete and answer subsumption
 1855    ->  '$tbl_table_status'(ATrie, _Status, M:Variant, Return),
 1856        M:'$table_mode'(Goal0, Variant, ModeArgs),
 1857        Goal = M:Goal0,
 1858        moded_gen_answer(ATrie, Return, ModeArgs)
 1859    ;   nonvar(Clause)                       % complete
 1860    ->  trie_gen_compiled(Clause, Return)
 1861    ;   call(Goal)                           % actually re-evaluate
 1862    ).
 1863
 1864
 1865split_paths([], [], []).
 1866split_paths([[_|Path]|T], DT, [Path|CT]) :-
 1867    split_paths(T, DT, CT).
 1868
 1869reeval_paths([], _) :-
 1870    !.
 1871reeval_paths(BottomUp, ATrie) :-
 1872    is_invalid(ATrie),
 1873    !,
 1874    reeval_heads(BottomUp, ATrie, BottomUp1),
 1875    reeval_paths(BottomUp1, ATrie).
 1876reeval_paths(_, _).
 1877
 1878reeval_heads(_, ATrie, _) :-
 1879    \+ is_invalid(ATrie),
 1880    !.
 1881reeval_heads([], _, []).
 1882reeval_heads([[H]|B], ATrie, BT) :-
 1883    !,
 1884    reeval_node(H),
 1885    reeval_heads(B, ATrie, BT).
 1886reeval_heads([[]|B], ATrie, BT) :-
 1887    !,
 1888    reeval_heads(B, ATrie, BT).
 1889reeval_heads([[H|T]|B], ATrie, [T|BT]) :-
 1890    !,
 1891    reeval_node(H),
 1892    reeval_heads(B, ATrie, BT).
 1893
 1894%!  false_path(+Atrie, -Path) is nondet.
 1895%
 1896%   True when Path is a list of   invalid  tries (bottom up, ending with
 1897%   ATrie).   The   last   element   of    the     list    is   a   term
 1898%   `s(Rank,Length,ATrie)` that is used for sorting the paths.
 1899%
 1900%   If we find a table along the  way   that  is being worked on by some
 1901%   other thread we wait for it.
 1902
 1903false_path(ATrie, BottomUp) :-
 1904    false_path(ATrie, Path, []),
 1905    '$reverse'(Path, BottomUp).
 1906
 1907false_path(ATrie, [ATrie|T], Seen) :-
 1908    \+ memberchk(ATrie, Seen),
 1909    '$idg_false_edge'(ATrie, Dep, Status),
 1910    tdebug(reeval, '    ~p has dependent ~p (~w)', [ATrie, Dep, Status]),
 1911    (   Status == invalid
 1912    ->  false_path(Dep, T, [ATrie|Seen])
 1913    ;   status_rank(Status, Rank),
 1914        length(Seen, Len),
 1915        T = [s(Rank,Len,Dep)]
 1916    ).
 1917
 1918status_rank(dynamic,   2) :- !.
 1919status_rank(monotonic, 2) :- !.
 1920status_rank(complete,  1) :- !.
 1921status_rank(Status,    Rank) :-
 1922    var(Rank),
 1923    !,
 1924    format(user_error, 'Re-eval from status ~p~n', [Status]),
 1925    Rank = 0.
 1926status_rank(Rank,   Rank) :-
 1927    format(user_error, 'Re-eval from rank ~p~n', [Rank]).
 1928
 1929is_invalid(ATrie) :-
 1930    '$idg_falsecount'(ATrie, FalseCount),
 1931    FalseCount > 0.
 1932
 1933%!  reeval_node(+ATrie)
 1934%
 1935%   Re-evaluate the invalid answer trie ATrie.  Initially this created a
 1936%   nested tabling environment, but this is dropped:
 1937%
 1938%     - It is possible for the re-evaluating variant to call into outer
 1939%       non/not-yet incremental tables, requiring a merge with this
 1940%       outer SCC.  This doesn't work well with a sub-environment.
 1941%     - We do not need one.  If this environment is not merged into the
 1942%       outer one it will complete before we continue.
 1943
 1944reeval_node(ATrie) :-
 1945    '$tbl_reeval_prepare'(ATrie, M:Variant),
 1946    !,
 1947    M:'$table_mode'(Goal0, Variant, _Moded),
 1948    Goal = M:Goal0,
 1949    tdebug(reeval, 'Re-evaluating ~p', [Goal]),
 1950    (   '$idg_reset_current',
 1951        setup_call_cleanup(
 1952            nb_setval('$tbl_reeval', true),
 1953            ignore(Goal),                    % assumes local scheduling
 1954            nb_delete('$tbl_reeval')),
 1955        fail
 1956    ;   tdebug(reeval, 'Re-evaluated ~p', [Goal])
 1957    ).
 1958reeval_node(ATrie) :-
 1959    '$mono_reeval_prepare'(ATrie, Size),
 1960    !,
 1961    tdebug(reeval, 'Re-evaluating lazy monotonic ~p', [ATrie]),
 1962    (   '$idg_mono_affects_lazy'(ATrie, SrcTrie, Dep, Answers),
 1963        (   Dep = dependency(Head, Cont, Skel)
 1964        ->  (   '$member'(ClauseRef, Answers),
 1965                '$clause'(Head, _Body, ClauseRef, _Bindings),
 1966                tdebug(monotonic, 'Propagating ~p from ~p to ~p',
 1967                       [Head, SrcTrie, ATrie]),
 1968                pdelim(Cont, Skel, ATrie),
 1969                fail
 1970            ;   '$idg_mono_empty_queue'(SrcTrie, ATrie)
 1971            )
 1972        ;   Dep = dependency(SrcSkel, true, Cont, Skel)
 1973        ->  (   '$member'(Node, Answers),
 1974                '$tbl_node_answer'(Node, SrcSkel),
 1975                tdebug(monotonic, 'Propagating ~p from ~p to ~p',
 1976                       [Skel, SrcTrie, ATrie]),
 1977                pdelim(Cont, Skel, ATrie),
 1978                fail
 1979            ;   '$idg_mono_empty_queue'(SrcTrie, ATrie)
 1980            )
 1981        ),
 1982        fail
 1983    ;   '$mono_reeval_done'(ATrie, Size)
 1984    ).
 1985reeval_node(_).
 1986
 1987		 /*******************************
 1988		 *      EXPAND DIRECTIVES	*
 1989		 *******************************/
 1990
 1991system:term_expansion((:- table(Preds)), Expansion) :-
 1992    \+ current_prolog_flag(xref, true),
 1993    prolog_load_context(module, M),
 1994    phrase(wrappers(Preds, M), Clauses),
 1995    multifile_decls(Clauses, Directives0),
 1996    sort(Directives0, Directives),
 1997    '$append'(Directives, Clauses, Expansion).
 1998
 1999multifile_decls([], []).
 2000multifile_decls([H0|T0], [H|T]) :-
 2001    multifile_decl(H0, H),
 2002    !,
 2003    multifile_decls(T0, T).
 2004multifile_decls([_|T0], T) :-
 2005    multifile_decls(T0, T).
 2006
 2007multifile_decl(M:(Head :- _Body), (:- multifile(M:Name/Arity))) :-
 2008    !,
 2009    functor(Head, Name, Arity).
 2010multifile_decl(M:Head, (:- multifile(M:Name/Arity))) :-
 2011    !,
 2012    functor(Head, Name, Arity).
 2013multifile_decl((Head :- _Body), (:- multifile(Name/Arity))) :-
 2014    !,
 2015    functor(Head, Name, Arity).
 2016multifile_decl(Head, (:- multifile(Name/Arity))) :-
 2017    !,
 2018    Head \= (:-_),
 2019    functor(Head, Name, Arity).
 2020
 2021
 2022		 /*******************************
 2023		 *      ANSWER COMPLETION	*
 2024		 *******************************/
 2025
 2026:- public answer_completion/2. 2027
 2028%!  answer_completion(+AnswerTrie, +Return) is det.
 2029%
 2030%   Find  positive  loops  in  the  residual   program  and  remove  the
 2031%   corresponding answers, possibly causing   additional simplification.
 2032%   This is called from C  if   simplify_component()  detects  there are
 2033%   conditional answers after simplification.
 2034%
 2035%   Note that we are called recursively from   C.  Our caller prepared a
 2036%   clean new tabling environment and restores   the  old one after this
 2037%   predicate terminates.
 2038%
 2039%   @author This code is by David Warren as part of XSB.
 2040%   @see called from C, pl-tabling.c, answer_completion()
 2041
 2042answer_completion(AnswerTrie, Return) :-
 2043    tdebug(trie_goal(AnswerTrie, Goal, _Return)),
 2044    tdebug(ac(start), 'START: Answer completion for ~p', [Goal]),
 2045    call_cleanup(answer_completion_guarded(AnswerTrie, Return, Propagated),
 2046                 abolish_table_subgoals(eval_subgoal_in_residual(_,_))),
 2047    (   Propagated > 0
 2048    ->  answer_completion(AnswerTrie, Return)
 2049    ;   true
 2050    ).
 2051
 2052answer_completion_guarded(AnswerTrie, Return, Propagated) :-
 2053    (   eval_subgoal_in_residual(AnswerTrie, Return),
 2054        fail
 2055    ;   true
 2056    ),
 2057    delete_answers_for_failing_calls(Propagated),
 2058    (   Propagated == 0
 2059    ->  mark_succeeding_calls_as_answer_completed
 2060    ;   true
 2061    ).
 2062
 2063%!  delete_answers_for_failing_calls(-Propagated)
 2064%
 2065%   Delete answers whose condition  is  determined   to  be  `false` and
 2066%   return the number of additional  answers   that  changed status as a
 2067%   consequence of additional simplification propagation.
 2068
 2069delete_answers_for_failing_calls(Propagated) :-
 2070    State = state(0),
 2071    (   subgoal_residual_trie(ASGF, ESGF),
 2072        \+ trie_gen(ESGF, _ETmp),
 2073        tdebug(trie_goal(ASGF, Goal0, _)),
 2074        tdebug(trie_goal(ASGF, Goal, _0Return)),
 2075        '$trie_gen_node'(ASGF, _0Return, ALeaf),
 2076        tdebug(ac(prune), '  Removing answer ~p from ~p', [Goal, Goal0]),
 2077	'$tbl_force_truth_value'(ALeaf, false, Count),
 2078        arg(1, State, Prop0),
 2079        Prop is Prop0+Count-1,
 2080        nb_setarg(1, State, Prop),
 2081	fail
 2082    ;   arg(1, State, Propagated)
 2083    ).
 2084
 2085mark_succeeding_calls_as_answer_completed :-
 2086    (   subgoal_residual_trie(ASGF, _ESGF),
 2087        (   '$tbl_answer_dl'(ASGF, _0Return, _True)
 2088        ->  tdebug(trie_goal(ASGF, Answer, _0Return)),
 2089            tdebug(trie_goal(ASGF, Goal, _0Return)),
 2090            tdebug(ac(prune), '  Completed ~p on ~p', [Goal, Answer]),
 2091            '$tbl_set_answer_completed'(ASGF)
 2092        ),
 2093        fail
 2094    ;   true
 2095    ).
 2096
 2097subgoal_residual_trie(ASGF, ESGF) :-
 2098    '$tbl_variant_table'(VariantTrie),
 2099    context_module(M),
 2100    trie_gen(VariantTrie, M:eval_subgoal_in_residual(ASGF, _), ESGF).
 2101
 2102%!  eval_dl_in_residual(+Condition)
 2103%
 2104%   Evaluate a condition by only looking at   the  residual goals of the
 2105%   involved calls.
 2106
 2107eval_dl_in_residual(true) :-
 2108    !.
 2109eval_dl_in_residual((A;B)) :-
 2110    !,
 2111    (   eval_dl_in_residual(A)
 2112    ;   eval_dl_in_residual(B)
 2113    ).
 2114eval_dl_in_residual((A,B)) :-
 2115    !,
 2116    eval_dl_in_residual(A),
 2117    eval_dl_in_residual(B).
 2118eval_dl_in_residual(tnot(G)) :-
 2119    !,
 2120    tdebug(ac, ' ? tnot(~p)', [G]),
 2121    current_table(G, SGF),
 2122    '$tbl_table_status'(SGF, _Status, _Wrapper, Return),
 2123    tnot(eval_subgoal_in_residual(SGF, Return)).
 2124eval_dl_in_residual(G) :-
 2125    tdebug(ac, ' ? ~p', [G]),
 2126    (   current_table(G, SGF)
 2127    ->	true
 2128    ;   more_general_table(G, SGF)
 2129    ->	true
 2130    ;	writeln(user_error, 'MISSING CALL? '(G)),
 2131        fail
 2132    ),
 2133    '$tbl_table_status'(SGF, _Status, _Wrapper, Return),
 2134    eval_subgoal_in_residual(SGF, Return).
 2135
 2136more_general_table(G, Trie) :-
 2137    term_variables(G, Vars),
 2138    '$tbl_variant_table'(VariantTrie),
 2139    trie_gen(VariantTrie, G, Trie),
 2140    is_most_general_term(Vars).
 2141
 2142:- table eval_subgoal_in_residual/2. 2143
 2144%!  eval_subgoal_in_residual(+AnswerTrie, ?Return)
 2145%
 2146%   Derive answers for the variant represented   by  AnswerTrie based on
 2147%   the residual goals only.
 2148
 2149eval_subgoal_in_residual(AnswerTrie, _Return) :-
 2150    '$tbl_is_answer_completed'(AnswerTrie),
 2151    !,
 2152    undefined.
 2153eval_subgoal_in_residual(AnswerTrie, Return) :-
 2154    '$tbl_answer'(AnswerTrie, Return, Condition),
 2155    tdebug(trie_goal(AnswerTrie, Goal, Return)),
 2156    tdebug(ac, 'Condition for ~p is ~p', [Goal, Condition]),
 2157    eval_dl_in_residual(Condition).
 2158
 2159
 2160		 /*******************************
 2161		 *            TRIPWIRES		*
 2162		 *******************************/
 2163
 2164%!  tripwire(+Wire, +Action, +Context)
 2165%
 2166%   Called from the tabling engine of some  tripwire is exceeded and the
 2167%   situation  is  not  handled  internally   (such  as  `abstract`  and
 2168%   `bounded_rationality`.
 2169
 2170:- public tripwire/3. 2171:- multifile prolog:tripwire/2. 2172
 2173tripwire(Wire, _Action, Context) :-
 2174    prolog:tripwire(Wire, Context),
 2175    !.
 2176tripwire(Wire, Action, Context) :-
 2177    Error = error(resource_error(tripwire(Wire, Context)), _),
 2178    tripwire_action(Action, Error).
 2179
 2180tripwire_action(warning, Error) :-
 2181    print_message(warning, Error).
 2182tripwire_action(error, Error) :-
 2183    throw(Error).
 2184tripwire_action(suspend, Error) :-
 2185    print_message(warning, Error),
 2186    break.
 2187
 2188
 2189		 /*******************************
 2190		 *   SYSTEM TABLED PREDICATES	*
 2191		 *******************************/
 2192
 2193:- table
 2194    system:undefined/0,
 2195    system:answer_count_restraint/0,
 2196    system:radial_restraint/0,
 2197    system:tabled_call/1. 2198
 2199%!  undefined is undefined.
 2200%
 2201%   Expresses the value _bottom_ from the well founded semantics.
 2202
 2203system:(undefined :-
 2204    tnot(undefined)).
 2205
 2206%!  answer_count_restraint is undefined.
 2207%!  radial_restraint is undefined.
 2208%
 2209%   Similar  to  undefined/0,  providing  a   specific  _undefined_  for
 2210%   restraint violations.
 2211
 2212system:(answer_count_restraint :-
 2213    tnot(answer_count_restraint)).
 2214
 2215system:(radial_restraint :-
 2216    tnot(radial_restraint)).
 2217
 2218system:(tabled_call(X) :- call(X))