View source with formatted comments or as raw
    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-2019, 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            undefined/0,
   43
   44            current_table/2,            % :Variant, ?Table
   45            abolish_all_tables/0,
   46            abolish_table_subgoals/1,   % :Subgoal
   47            abolish_module_tables/1,    % +Module
   48            abolish_nonincremental_tables/0,
   49            abolish_nonincremental_tables/1, % +Options
   50
   51            start_tabling/3,            % +Closure, +Wrapper, :Worker
   52            start_subsumptive_tabling/3,% +Closure, +Wrapper, :Worker
   53            start_tabling/5,            % +Closure, +Wrapper, :Worker, :Variant, ?ModeArgs
   54
   55            '$wrap_tabled'/2,		% :Head, +Mode
   56            '$moded_wrap_tabled'/4,	% :Head, +ModeTest, +Variant, +Moded
   57            '$wfs_call'/2,              % :Goal, -Delays
   58
   59            '$wrap_incremental'/1,      % :Head
   60            '$unwrap_incremental'/1     % :Head
   61          ]).   62
   63:- meta_predicate
   64    table(:),
   65    untable(:),
   66    tnot(0),
   67    start_tabling(+, +, 0),
   68    start_tabling(+, +, 0, +, ?),
   69    current_table(:, -),
   70    abolish_table_subgoals(:),
   71    '$wfs_call'(0, :).   72
   73/** <module> Tabled execution (SLG WAM)
   74
   75This  library  handled  _tabled_  execution   of  predicates  using  the
   76characteristics if the _SLG WAM_. The   required  suspension is realised
   77using _delimited continuations_ implemented by  reset/3 and shift/1. The
   78table space and work lists are part of the SWI-Prolog core.
   79
   80@author Benoit Desouter, Jan Wielemaker and Fabrizio Riguzzi
   81*/
   82
   83% Enable debugging using debug(tabling(Topic)) when compiled with
   84% -DO_DEBUG
   85goal_expansion(tdebug(Topic, Fmt, Args), Expansion) :-
   86    (   current_prolog_flag(prolog_debug, true)
   87    ->  Expansion = debug(tabling(Topic), Fmt, Args)
   88    ;   Expansion = true
   89    ).
   90goal_expansion(tdebug(Goal), Expansion) :-
   91    (   current_prolog_flag(prolog_debug, true)
   92    ->  Expansion = (   debugging(tabling(_))
   93                    ->  (   Goal
   94                        ->  true
   95                        ;   print_message(error, goal_failed(Goal))
   96                        )
   97                    ;   true
   98                    )
   99    ;   Expansion = true
  100    ).
  101
  102:- if(current_prolog_flag(prolog_debug, true)).  103wl_goal(tnot(WorkList), ~(Goal), Skeleton) :-
  104    !,
  105    '$tbl_worklist_data'(WorkList, worklist(_SCC,Trie,_,_,_)),
  106    '$tbl_table_status'(Trie, _Status, Wrapper, Skeleton),
  107    unqualify_goal(Wrapper, user, Goal).
  108wl_goal(WorkList, Goal, Skeleton) :-
  109    '$tbl_worklist_data'(WorkList, worklist(_SCC,Trie,_,_,_)),
  110    '$tbl_table_status'(Trie, _Status, Wrapper, Skeleton),
  111    unqualify_goal(Wrapper, user, Goal).
  112
  113trie_goal(ATrie, Goal, Skeleton) :-
  114    '$tbl_table_status'(ATrie, _Status, Wrapper, Skeleton),
  115    unqualify_goal(Wrapper, user, Goal).
  116
  117delay_goals(List, Goal) :-
  118    delay_goals(List, user, Goal).
  119
  120user_goal(Goal, UGoal) :-
  121    unqualify_goal(Goal, user, UGoal).
  122
  123:- multifile
  124    prolog:portray/1.  125
  126user:portray(ATrie) :-
  127    '$is_answer_trie'(ATrie),
  128    trie_goal(ATrie, Goal, _Skeleton),
  129    format('~q for ~p', [ATrie, Goal]).
  130
  131:- endif.  132
  133%!  table(:PredicateIndicators)
  134%
  135%   Prepare the given PredicateIndicators for tabling. This predicate is
  136%   normally used as a directive,  but   SWI-Prolog  also allows runtime
  137%   conversion of non-tabled predicates to  tabled predicates by calling
  138%   table/1. The example below prepares  the   predicate  edge/2 and the
  139%   non-terminal statement//1 for tabled execution.
  140%
  141%     ==
  142%     :- table edge/2, statement//1.
  143%     ==
  144%
  145%   In addition to using _predicate  indicators_,   a  predicate  can be
  146%   declared for _mode  directed  tabling_  using   a  term  where  each
  147%   argument declares the intended mode.  For example:
  148%
  149%     ==
  150%     :- table connection(_,_,min).
  151%     ==
  152%
  153%   _Mode directed tabling_ is  discussed   in  the general introduction
  154%   section about tabling.
  155
  156table(M:PIList) :-
  157    setup_call_cleanup(
  158        '$set_source_module'(OldModule, M),
  159        expand_term((:- table(PIList)), Clauses),
  160        '$set_source_module'(OldModule)),
  161    dyn_tabling_list(Clauses, M).
  162
  163dyn_tabling_list([], _).
  164dyn_tabling_list([H|T], M) :-
  165    dyn_tabling(H, M),
  166    dyn_tabling_list(T, M).
  167
  168dyn_tabling(M:Clause, _) :-
  169    !,
  170    dyn_tabling(Clause, M).
  171dyn_tabling((:- multifile(PI)), M) :-
  172    !,
  173    multifile(M:PI),
  174    dynamic(M:PI).
  175dyn_tabling(:- initialization(Wrap, now), M) :-
  176    !,
  177    M:Wrap.
  178dyn_tabling('$tabled'(Head, TMode), M) :-
  179    (   clause(M:'$tabled'(Head, OMode), true, Ref),
  180        (   OMode \== TMode
  181        ->  erase(Ref),
  182            fail
  183        ;   true
  184        )
  185    ->  true
  186    ;   assertz(M:'$tabled'(Head, TMode))
  187    ).
  188dyn_tabling('$table_mode'(Head, Variant, Moded), M) :-
  189    (   clause(M:'$table_mode'(Head, Variant0, Moded0), true, Ref)
  190    ->  (   t(Head, Variant, Moded) =@= t(Head, Variant0, Moded0)
  191        ->  true
  192        ;   erase(Ref),
  193            assertz(M:'$table_mode'(Head, Variant, Moded))
  194        )
  195    ;   assertz(M:'$table_mode'(Head, Variant, Moded))
  196    ).
  197dyn_tabling(('$table_update'(Head, S0, S1, S2) :- Body), M) :-
  198    (   clause(M:'$table_update'(Head, S00, S10, S20), Body0, Ref)
  199    ->  (   t(Head, S0, S1, S2, Body) =@= t(Head, S00, S10, S20, Body0)
  200        ->  true
  201        ;   erase(Ref),
  202            assertz(M:('$table_update'(Head, S0, S1, S2) :- Body))
  203        )
  204    ;   assertz(M:('$table_update'(Head, S0, S1, S2) :- Body))
  205    ).
  206
  207%!  untable(M:PIList) is det.
  208%
  209%   Remove tabling for the predicates in  PIList.   This  can be used to
  210%   undo the effect of table/1 at runtime.   In addition to removing the
  211%   tabling instrumentation this also removes possibly associated tables
  212%   using abolish_table_subgoals/1.
  213%
  214%   @arg PIList is a comma-list that is compatible ith table/1.
  215
  216untable(M:PIList) :-
  217    untable(PIList, M).
  218
  219untable(Var, _) :-
  220    var(Var),
  221    !,
  222    '$instantiation_error'(Var).
  223untable(M:Spec, _) :-
  224    !,
  225    '$must_be'(atom, M),
  226    untable(Spec, M).
  227untable((A,B), M) :-
  228    !,
  229    untable(A, M),
  230    untable(B, M).
  231untable(Name//Arity, M) :-
  232    atom(Name), integer(Arity), Arity >= 0,
  233    !,
  234    Arity1 is Arity+2,
  235    untable(Name/Arity1, M).
  236untable(Name/Arity, M) :-
  237    !,
  238    functor(Head, Name, Arity),
  239    (   '$get_predicate_attribute'(M:Head, tabled, 1)
  240    ->  abolish_table_subgoals(M:Head),
  241        dynamic(M:'$tabled'/2),
  242        dynamic(M:'$table_mode'/3),
  243        retractall(M:'$tabled'(Head, _TMode)),
  244        retractall(M:'$table_mode'(Head, _Variant, _Moded)),
  245        unwrap_predicate(M:Name/Arity, table),
  246        '$set_predicate_attribute'(M:Head, tabled, false)
  247    ;   true
  248    ).
  249untable(Head, M) :-
  250    callable(Head),
  251    !,
  252    functor(Head, Name, Arity),
  253    untable(Name/Arity, M).
  254untable(TableSpec, _) :-
  255    '$type_error'(table_desclaration, TableSpec).
  256
  257untable_reconsult(PI) :-
  258    print_message(informational, untable(PI)),
  259    untable(PI).
  260
  261:- initialization
  262   prolog_listen(untable, untable_reconsult).  263
  264
  265%!  start_tabling(:Wrapper, :Implementation)
  266%
  267%   Execute Implementation using tabling. This  predicate should not
  268%   be called directly. The table/1 directive  causes a predicate to
  269%   be translated into a renamed implementation   and a wrapper that
  270%   involves this predicate.
  271%
  272%   @compat This interface may change or disappear without notice
  273%           from future versions.
  274
  275'$wrap_tabled'(Head, Options) :-
  276    get_dict(mode, Options, subsumptive),
  277    !,
  278    set_pattributes(Head, Options),
  279    '$wrap_predicate'(Head, table, Closure, Wrapped,
  280                      start_subsumptive_tabling(Closure, Head, Wrapped)).
  281'$wrap_tabled'(Head, Options) :-
  282    !,
  283    set_pattributes(Head, Options),
  284    '$wrap_predicate'(Head, table, Closure, Wrapped,
  285                      start_tabling(Closure, Head, Wrapped)).
  286
  287set_pattributes(Head, Options) :-
  288    '$set_predicate_attribute'(Head, tabled, true),
  289    (   get_dict(incremental, Options, true)
  290    ->  '$set_predicate_attribute'(Head, incremental, true)
  291    ;   true
  292    ),
  293    (   get_dict(dynamic, Options, true)
  294    ->  '$set_predicate_attribute'(Head, dynamic, true)
  295    ;   true
  296    ),
  297    (   get_dict(tshared, Options, true)
  298    ->  '$set_predicate_attribute'(Head, tshared, true)
  299    ;   true
  300    ).
  301
  302
  303start_tabling(Closure, Wrapper, Worker) :-
  304    '$tbl_variant_table'(Closure, Wrapper, Trie, Status, Skeleton),
  305    tdebug(deadlock, 'Got table ~p, status ~p', [Trie, Status]),
  306    (   Status == complete
  307    ->  trie_gen_compiled(Trie, Skeleton)
  308    ;   Status == fresh
  309    ->  catch(create_table(Trie, Skeleton, Wrapper, Worker),
  310              deadlock,
  311              restart_tabling(Closure, Wrapper, Worker))
  312    ;   Status == invalid
  313    ->  reeval(Trie, Wrapper, Skeleton)
  314    ;   % = run_follower, but never fresh and Status is a worklist
  315        shift(call_info(Skeleton, Status))
  316    ).
  317
  318create_table(Trie, Skeleton, Wrapper, Worker) :-
  319    '$tbl_create_subcomponent'(SCC, Trie),
  320    tdebug(user_goal(Wrapper, Goal)),
  321    tdebug(schedule, 'Created component ~d for ~p', [SCC, Goal]),
  322    setup_call_catcher_cleanup(
  323        '$idg_set_current'(OldCurrent, Trie),
  324        run_leader(Skeleton, Worker, Trie, SCC, LStatus, Clause),
  325        Catcher,
  326        finished_leader(OldCurrent, Catcher, SCC, Wrapper)),
  327    tdebug(schedule, 'Leader ~p done, status = ~p', [Goal, LStatus]),
  328    done_leader(LStatus, SCC, Skeleton, Clause).
  329
  330
  331%!  restart_tabling(+Closure, +Wrapper, +Worker)
  332%
  333%   We were aborted due to a  deadlock.   Simply  retry. We sleep a very
  334%   tiny amount to give the thread against  which we have deadlocked the
  335%   opportunity to grab our table. Without, it is common that we re-grab
  336%   the table within our time slice  and   before  the kernel managed to
  337%   wakeup the other thread.
  338
  339restart_tabling(Closure, Wrapper, Worker) :-
  340    tdebug(user_goal(Wrapper, Goal)),
  341    tdebug(deadlock, 'Deadlock running ~p; retrying', [Goal]),
  342    sleep(0.000001),
  343    start_tabling(Closure, Wrapper, Worker).
  344
  345
  346%!  start_subsumptive_tabling(:Wrapper, :Implementation)
  347%
  348%   (*) We should __not__ use  trie_gen_compiled/2   here  as  this will
  349%   enumerate  all  answers  while  '$tbl_answer_update_dl'/2  uses  the
  350%   available trie indexing to only fetch the relevant answer(s).
  351%
  352%   @tbd  In  the  end  '$tbl_answer_update_dl'/2  is  problematic  with
  353%   incremental and shared tabling  as  we   do  not  get the consistent
  354%   update view from the compiled result.
  355
  356start_subsumptive_tabling(Closure, Wrapper, Worker) :-
  357    (   '$tbl_existing_variant_table'(Closure, Wrapper, Trie, Status, Skeleton)
  358    ->  (   Status == complete
  359        ->  trie_gen_compiled(Trie, Skeleton)
  360        ;   Status == invalid
  361        ->  reeval(Trie, Wrapper, Skeleton),
  362            trie_gen_compiled(Trie, Skeleton)
  363        ;   shift(call_info(Skeleton, Status))
  364        )
  365    ;   more_general_table(Wrapper, ATrie),
  366        '$tbl_table_status'(ATrie, complete, Wrapper, Skeleton)
  367    ->  '$tbl_answer_update_dl'(ATrie, Skeleton) % see (*)
  368    ;   more_general_table(Wrapper, ATrie),
  369        '$tbl_table_status'(ATrie, Status, GenWrapper, GenSkeleton)
  370    ->  (   Status == invalid
  371        ->  reeval(ATrie, GenWrapper, GenSkeleton),
  372            Wrapper = GenWrapper,
  373            '$tbl_answer_update_dl'(ATrie, GenSkeleton)
  374        ;   shift(call_info(GenSkeleton, Status)),
  375            unify_subsumptive(Wrapper, GenWrapper)
  376        )
  377    ;   '$tbl_variant_table'(Closure, Wrapper, Trie, _0Status, Skeleton),
  378        tdebug(_0Status == fresh),
  379        '$tbl_create_subcomponent'(SCC, Trie),
  380        tdebug(user_goal(Wrapper, Goal)),
  381        tdebug(schedule, 'Created component ~d for ~p', [SCC, Goal]),
  382        setup_call_catcher_cleanup(
  383            '$idg_set_current'(OldCurrent, Trie),
  384            run_leader(Skeleton, Worker, Trie, SCC, LStatus, Clause),
  385            Catcher,
  386            finished_leader(OldCurrent, Catcher, SCC, Wrapper)),
  387        tdebug(schedule, 'Leader ~p done, status = ~p', [Goal, LStatus]),
  388        done_leader(LStatus, SCC, Skeleton, Clause)
  389    ).
  390
  391unify_subsumptive(X,X).
  392
  393:- '$hide'((done_leader/4, finished_leader/4)).  394
  395done_leader(complete, _SCC, Skeleton, Clause) :-
  396    !,
  397    trie_gen_compiled(Clause, Skeleton).
  398done_leader(final, SCC, Skeleton, Clause) :-
  399    !,
  400    '$tbl_free_component'(SCC),
  401    trie_gen_compiled(Clause, Skeleton).
  402done_leader(_,_,_,_).
  403
  404finished_leader(OldCurrent, Catcher, SCC, Wrapper) :-
  405    '$idg_set_current'(OldCurrent),
  406    (   Catcher == exit
  407    ->  true
  408    ;   Catcher == fail
  409    ->  true
  410    ;   Catcher = exception(_)
  411    ->  '$tbl_table_discard_all'(SCC)
  412    ;   print_message(error, tabling(unexpected_result(Wrapper, Catcher)))
  413    ).
  414
  415%!  run_leader(+Wrapper, +Worker, +Trie, +SCC, -Status, -Clause) is det.
  416%
  417%   Run the leader of  a  (new)   SCC,  storing  instantiated  copies of
  418%   Wrapper into Trie. Status  is  the  status   of  the  SCC  when this
  419%   predicate terminates. It is one of   `complete`, in which case local
  420%   completion finished or `merged` if running   the completion finds an
  421%   open (not completed) active goal that resides in a parent component.
  422%   In this case, this SCC has been merged with this parent.
  423%
  424%   If the SCC is merged, the answers   it already gathered are added to
  425%   the worklist and we shift  (suspend),   turning  our  leader into an
  426%   internal node for the upper SCC.
  427
  428run_leader(Skeleton, Worker, Trie, SCC, Status, Clause) :-
  429    tdebug('$tbl_table_status'(Trie, _Status, Wrapper, Skeleton)),
  430    tdebug(user_goal(Wrapper, Goal)),
  431    tdebug(schedule, '-> Activate component ~p for ~p', [SCC, Goal]),
  432    activate(Skeleton, Worker, Trie, Worklist),
  433    tdebug(schedule, '-> Complete component ~p for ~p', [SCC, Goal]),
  434    completion(SCC, Status, Clause),
  435    tdebug(schedule, '-> Completed component ~p for ~p: ~p', [SCC, Goal, Status]),
  436    (   Status == merged
  437    ->  tdebug(merge, 'Turning leader ~p into follower', [Goal]),
  438        '$tbl_wkl_make_follower'(Worklist),
  439        shift(call_info(Skeleton, Worklist))
  440    ;   true                                    % completed
  441    ).
  442
  443activate(Wrapper, Worker, Trie, WorkList) :-
  444    '$tbl_new_worklist'(WorkList, Trie),
  445    tdebug(activate, '~p: created wl=~p, trie=~p',
  446           [Wrapper, WorkList, Trie]),
  447    (   reset_delays,
  448        delim(Wrapper, Worker, WorkList, []),
  449        fail
  450    ;   true
  451    ).
  452
  453%!  delim(+Wrapper, +Worker, +WorkList, +Delays)
  454%
  455%   Call/resume Worker for non-mode directed tabled predicates.
  456
  457delim(Wrapper, Worker, WorkList, Delays) :-
  458    reset(Worker, SourceCall, Continuation),
  459    tdebug(wl_goal(WorkList, Goal, _)),
  460    (   Continuation == 0
  461    ->  tdebug('$tbl_add_global_delays'(Delays, AllDelays)),
  462        tdebug(delay_goals(AllDelays, Cond)),
  463        tdebug(answer, 'New answer ~p for ~p (delays = ~p)',
  464               [Wrapper, Goal, Cond]),
  465        '$tbl_wkl_add_answer'(WorkList, Wrapper, Delays, Complete),
  466        Complete == !,
  467        !
  468    ;   SourceCall = call_info(SrcSkeleton, SourceWL),
  469        '$tbl_add_global_delays'(Delays, AllDelays),
  470        tdebug(wl_goal(SourceWL, SrcGoal, _)),
  471        tdebug(wl_goal(WorkList, DstGoal, _)),
  472        tdebug(schedule, 'Suspended ~p, for solving ~p', [SrcGoal, DstGoal]),
  473        '$tbl_wkl_add_suspension'(
  474            SourceWL,
  475            dependency(SrcSkeleton, Continuation, Wrapper, WorkList, AllDelays))
  476    ).
  477
  478%!  start_tabling(:Wrapper, :Implementation, +Variant, +ModeArgs)
  479%
  480%   As start_tabling/2, but in addition separates the data stored in the
  481%   answer trie in the Variant and ModeArgs.
  482
  483'$moded_wrap_tabled'(Head, ModeTest, WrapperNoModes, ModeArgs) :-
  484    '$set_predicate_attribute'(Head, tabled, true),
  485    '$wrap_predicate'(Head, table, Closure, Wrapped,
  486                      (   ModeTest,
  487                          start_tabling(Closure, Head, Wrapped, WrapperNoModes, ModeArgs)
  488                      )).
  489
  490
  491start_tabling(Closure, Wrapper, Worker, WrapperNoModes, ModeArgs) :-
  492    '$tbl_moded_variant_table'(Closure, WrapperNoModes, Trie, Status, _Skeleton),
  493    (   Status == complete
  494    ->  trie_gen(Trie, WrapperNoModes, ModeArgs)
  495    ;   Status == fresh
  496    ->  '$tbl_create_subcomponent'(SubComponent, Trie),
  497        setup_call_catcher_cleanup(
  498            '$idg_set_current'(OldCurrent, Trie),
  499            run_leader(Wrapper, WrapperNoModes, ModeArgs,
  500                       Worker, Trie, SubComponent, LStatus),
  501            Catcher,
  502            finished_leader(OldCurrent, Catcher, SubComponent, Wrapper)),
  503        tdebug(schedule, 'Leader ~p done, modeargs = ~p, status = ~p',
  504               [Wrapper, ModeArgs, LStatus]),
  505        moded_done_leader(LStatus, SubComponent, WrapperNoModes, ModeArgs, Trie)
  506    ;   Status == invalid
  507    ->  reeval(Trie),
  508        trie_gen(Trie, WrapperNoModes, ModeArgs)
  509    ;   % = run_follower, but never fresh and Status is a worklist
  510        shift(call_info(Wrapper, Status))
  511    ).
  512
  513moded_done_leader(complete, _SCC, WrapperNoModes, ModeArgs, Trie) :-
  514    !,
  515    trie_gen(Trie, WrapperNoModes, ModeArgs).
  516moded_done_leader(final, SCC, WrapperNoModes, ModeArgs, Trie) :-
  517    !,
  518    '$tbl_free_component'(SCC),
  519    trie_gen(Trie, WrapperNoModes, ModeArgs).
  520moded_done_leader(_, _, _, _, _).
  521
  522
  523get_wrapper_no_mode_args(M:Wrapper, M:WrapperNoModes, ModeArgs) :-
  524    M:'$table_mode'(Wrapper, WrapperNoModes, ModeArgs).
  525
  526run_leader(Wrapper, WrapperNoModes, ModeArgs, Worker, Trie, SCC, Status) :-
  527    moded_activate(Wrapper, WrapperNoModes, ModeArgs, Worker, Trie, Worklist),
  528    completion(SCC, Status, _Clause),           % TBD: propagate
  529    (   Status == merged
  530    ->  tdebug(scc, 'Turning leader ~p into follower', [Wrapper]),
  531        (   trie_gen(Trie, WrapperNoModes1, ModeArgs1),
  532            tdebug(scc, 'Adding old answer ~p+~p to worklist ~p',
  533                   [ WrapperNoModes1, ModeArgs1, Worklist]),
  534            '$tbl_wkl_mode_add_answer'(Worklist, WrapperNoModes1,
  535                                       ModeArgs1, Wrapper),
  536            fail
  537        ;   true
  538        ),
  539        shift(call_info(Wrapper, Worklist))
  540    ;   true                                    % completed
  541    ).
  542
  543
  544moded_activate(Wrapper, WrapperNoModes, _ModeArgs, Worker, Trie, WorkList) :-
  545    '$tbl_new_worklist'(WorkList, Trie),
  546    (   moded_delim(Wrapper, WrapperNoModes, Worker, WorkList, []), % FIXME: Delay list
  547        fail
  548    ;   true
  549    ).
  550
  551%!  moded_delim(+Wrapper, +WrapperNoModes, +Worker, +WorkList, +Delays).
  552%
  553%   Call/resume Worker for mode directed tabled predicates.
  554
  555moded_delim(Wrapper, WrapperNoModes, Worker, WorkList, Delays) :-
  556    reset(Worker, SourceCall, Continuation),
  557    moded_add_answer_or_suspend(Continuation, Wrapper, WrapperNoModes,
  558                                WorkList, SourceCall, Delays).
  559
  560moded_add_answer_or_suspend(0, Wrapper, WrapperNoModes, WorkList, _, _) :-
  561    !,
  562    get_wrapper_no_mode_args(Wrapper, _, ModeArgs),
  563    '$tbl_wkl_mode_add_answer'(WorkList, WrapperNoModes,
  564                               ModeArgs, Wrapper). % FIXME: Add Delays
  565moded_add_answer_or_suspend(Continuation, Wrapper, _WrapperNoModes, WorkList,
  566                      call_info(SrcWrapper, SourceWL),
  567                      Delays) :-
  568    '$tbl_wkl_add_suspension'(
  569        SourceWL,
  570        dependency(SrcWrapper, Continuation, Wrapper, WorkList, Delays)).
  571
  572
  573%!  update(+Wrapper, +A1, +A2, -A3) is semidet.
  574%
  575%   Update the aggregated value for  an   answer.  Wrapper is the tabled
  576%   goal, A1 is the aggregated value so far, A2 is the new answer and A3
  577%   should be unified with the new   aggregated value. The new aggregate
  578%   is ignored if it is the same as the old one.
  579
  580:- public
  581    update/4.  582
  583update(M:Wrapper, A1, A2, A3) :-
  584    M:'$table_update'(Wrapper, A1, A2, A3),
  585    A1 \=@= A3.
  586
  587
  588%!  completion(+Component, -Status, -Clause) is det.
  589%
  590%   Wakeup suspended goals until no new answers are generated. Status is
  591%   one of `merged`, `completed` or `final`.  If Status is not `merged`,
  592%   Clause is a compiled  representation  for   the  answer  trie of the
  593%   Component leader.
  594
  595completion(SCC, Status, Clause) :-
  596    (   reset_delays,
  597        completion_(SCC),
  598        fail
  599    ;   '$tbl_table_complete_all'(SCC, Status, Clause),
  600        tdebug(schedule, 'SCC ~p: ~p', [scc(SCC), Status])
  601    ).
  602
  603completion_(SCC) :-
  604    repeat,
  605    (   '$tbl_pop_worklist'(SCC, WorkList)
  606    ->  tdebug(wl_goal(WorkList, Goal, _)),
  607        tdebug(schedule, 'Complete ~p in ~p', [Goal, scc(SCC)]),
  608        completion_step(WorkList)
  609    ;   !
  610    ).
  611
  612%!  completion_step(+Worklist) is fail.
  613
  614completion_step(WorkList) :-
  615    '$tbl_trienode'(Reserved),
  616    '$tbl_wkl_work'(WorkList,
  617                    Answer, ModeArgs,
  618                    Goal, Continuation, Wrapper, TargetWorklist, Delays),
  619    '$idg_set_current_wl'(TargetWorklist),
  620    tdebug(wl_goal(WorkList, SourceGoal, _)),
  621    tdebug(wl_goal(TargetWorklist, TargetGoal, _Skeleton)),
  622    (   ModeArgs == Reserved
  623    ->  tdebug('$tbl_add_global_delays'(Delays, AllDelays)),
  624        tdebug(delay_goals(AllDelays, Cond)),
  625        tdebug(schedule, 'Resuming ~p, calling ~p with ~p (delays = ~p)',
  626               [TargetGoal, SourceGoal, Answer, Cond]),
  627        Goal = Answer,
  628        delim(Wrapper, Continuation, TargetWorklist, Delays)
  629    ;   get_wrapper_no_mode_args(Goal, Answer, ModeArgs),
  630        get_wrapper_no_mode_args(Wrapper, WrapperNoModes, _),
  631        moded_delim(Wrapper, WrapperNoModes, Continuation, TargetWorklist,
  632                    Delays)
  633    ),
  634    fail.
  635
  636
  637		 /*******************************
  638		 *     STRATIFIED NEGATION	*
  639		 *******************************/
  640
  641%!  tnot(:Goal)
  642%
  643%   Tabled negation.
  644
  645tnot(Goal0) :-
  646    '$tnot_implementation'(Goal0, Goal),        % verifies Goal is tabled
  647    '$tbl_variant_table'(_, Goal, Trie, Status, Skeleton),
  648    (   '$tbl_answer_dl'(Trie, _, true)
  649    ->  fail
  650    ;   '$tbl_answer_dl'(Trie, _, _)
  651    ->  add_delay(Trie)
  652    ;   Status == complete
  653    ->  true
  654    ;   Status == fresh
  655    ->  tdebug(tnot, 'tnot: ~p: fresh', [Goal]),
  656        (   call(Goal),
  657            fail
  658        ;   '$tbl_variant_table'(_, Goal, Trie, NewStatus, NewSkeleton),
  659            tdebug(tnot, 'tnot: fresh ~p now ~p', [Goal, NewStatus]),
  660            (   '$tbl_answer_dl'(Trie, _, true)
  661            ->  fail
  662            ;   '$tbl_answer_dl'(Trie, _, _)
  663            ->  add_delay(Trie)
  664            ;   NewStatus == complete
  665            ->  true
  666            ;   negation_suspend(Goal, NewSkeleton, NewStatus)
  667            )
  668        )
  669    ;   negation_suspend(Goal, Skeleton, Status)
  670    ).
  671
  672
  673%!  negation_suspend(+Goal, +Skeleton, +Worklist)
  674%
  675%   Suspend Worklist due to negation. This marks the worklist as dealing
  676%   with a negative literal and suspend.
  677%
  678%   The completion step will resume  negative   worklists  that  have no
  679%   solutions, causing this to succeed.
  680
  681negation_suspend(Wrapper, Skeleton, Worklist) :-
  682    tdebug(tnot, 'negation_suspend ~p (wl=~p)', [Wrapper, Worklist]),
  683    '$tbl_wkl_negative'(Worklist),
  684    shift(call_info(Skeleton, tnot(Worklist))),
  685    tdebug(tnot, 'negation resume ~p (wl=~p)', [Wrapper, Worklist]),
  686    '$tbl_wkl_is_false'(Worklist).
  687
  688
  689		 /*******************************
  690		 *           DELAY LISTS	*
  691		 *******************************/
  692
  693add_delay(Delay) :-
  694    '$tbl_delay_list'(DL0),
  695    '$tbl_set_delay_list'([Delay|DL0]).
  696
  697reset_delays :-
  698    '$tbl_set_delay_list'([]).
  699
  700%!  '$wfs_call'(:Goal, :Delays)
  701%
  702%   Call Goal and provide WFS delayed goals  as a conjunction in Delays.
  703%   This  predicate  is  teh  internal  version  of  call_delays/2  from
  704%   library(wfs).
  705
  706'$wfs_call'(Goal, M:Delays) :-
  707    '$tbl_delay_list'(DL0),
  708    reset_delays,
  709    call(Goal),
  710    '$tbl_delay_list'(DL1),
  711    (   delay_goals(DL1, M, Delays)
  712    ->  true
  713    ;   Delays = undefined
  714    ),
  715    '$append'(DL0, DL1, DL),
  716    '$tbl_set_delay_list'(DL).
  717
  718delay_goals([], _, true) :-
  719    !.
  720delay_goals([AT+AN|T], M, Goal) :-
  721    !,
  722    (   integer(AN)
  723    ->  at_delay_goal(AT, M, G0, Answer),
  724        trie_term(AN, Answer)
  725    ;   '$tbl_table_status'(AT, _Status, G0, AN)
  726    ),
  727    GN = G0,
  728    (   T == []
  729    ->  Goal = GN
  730    ;   Goal = (GN,GT),
  731        delay_goals(T, M, GT)
  732    ).
  733delay_goals([AT|T], M, Goal) :-
  734    at_delay_goal(AT, M, G0, _Skeleton),
  735    GN = tnot(G0),
  736    (   T == []
  737    ->  Goal = GN
  738    ;   Goal = (GN,GT),
  739        delay_goals(T, M, GT)
  740    ).
  741
  742at_delay_goal(tnot(Trie), M, tnot(Goal), Skeleton) :-
  743    is_trie(Trie),
  744    !,
  745    '$tbl_table_status'(Trie, _Status, Wrapper, Skeleton),
  746    unqualify_goal(Wrapper, M, Goal).
  747at_delay_goal(Trie, M, Goal, Skeleton) :-
  748    is_trie(Trie),
  749    !,
  750    '$tbl_table_status'(Trie, _Status, Wrapper, Skeleton),
  751    unqualify_goal(Wrapper, M, Goal).
  752
  753unqualify_goal(M:Goal, M, Goal0) :-
  754    !,
  755    Goal0 = Goal.
  756unqualify_goal(Goal, _, Goal).
  757
  758
  759                 /*******************************
  760                 *            CLEANUP           *
  761                 *******************************/
  762
  763%!  abolish_all_tables
  764%
  765%   Remove all tables. This is normally used to free up the space or
  766%   recompute the result after predicates on   which  the result for
  767%   some tabled predicates depend.
  768%
  769%   Abolishes both local and shared   tables. Possibly incomplete tables
  770%   are marked for destruction upon completion.
  771
  772abolish_all_tables :-
  773    (   '$tbl_abolish_local_tables'
  774    ->  true
  775    ;   true
  776    ),
  777    (   '$tbl_variant_table'(VariantTrie),
  778        trie_gen(VariantTrie, _, Trie),
  779        '$tbl_destroy_table'(Trie),
  780        fail
  781    ;   true
  782    ).
  783
  784%!  abolish_table_subgoals(:Subgoal) is det.
  785%
  786%   Abolish all tables that unify with SubGoal.
  787%
  788%   @tbd: SubGoal must be callable.  Should we allow for more general
  789%   patterns?
  790
  791abolish_table_subgoals(SubGoal0) :-
  792    '$tbl_implementation'(SubGoal0, M:SubGoal),
  793    !,
  794    forall(( '$tbl_variant_table'(VariantTrie),
  795             trie_gen(VariantTrie, M:SubGoal, Trie)
  796           ),
  797           '$tbl_destroy_table'(Trie)).
  798abolish_table_subgoals(_).
  799
  800%!  abolish_module_tables(+Module) is det.
  801%
  802%   Abolish all tables for predicates associated with the given module.
  803
  804abolish_module_tables(Module) :-
  805    '$must_be'(atom, Module),
  806    '$tbl_variant_table'(VariantTrie),
  807    current_module(Module),
  808    !,
  809    forall(trie_gen(VariantTrie, Module:_, Trie),
  810           '$tbl_destroy_table'(Trie)).
  811abolish_module_tables(_).
  812
  813%!  abolish_nonincremental_tables is det.
  814%
  815%   Abolish all tables that are not related to incremental predicates.
  816
  817abolish_nonincremental_tables :-
  818    (   '$tbl_variant_table'(VariantTrie),
  819        trie_gen(VariantTrie, _, Trie),
  820        '$tbl_table_status'(Trie, Status, Goal, _),
  821        (   Status == complete
  822        ->  true
  823        ;   '$permission_error'(abolish, incomplete_table, Trie)
  824        ),
  825        \+ predicate_property(Goal, incremental),
  826        '$tbl_destroy_table'(Trie),
  827        fail
  828    ;   true
  829    ).
  830
  831%!  abolish_nonincremental_tables(+Options)
  832%
  833%   Allow for skipping incomplete tables while abolishing.
  834%
  835%   @tbd Mark tables for destruction such   that they are abolished when
  836%   completed.
  837
  838abolish_nonincremental_tables(Options) :-
  839    (   Options = on_incomplete(Action)
  840    ->  Action == skip
  841    ;   '$option'(on_incomplete(skip), Options)
  842    ),
  843    !,
  844    (   '$tbl_variant_table'(VariantTrie),
  845        trie_gen(VariantTrie, _, Trie),
  846        '$tbl_table_status'(Trie, complete, Goal, _),
  847        \+ predicate_property(Goal, incremental),
  848        '$tbl_destroy_table'(Trie),
  849        fail
  850    ;   true
  851    ).
  852abolish_nonincremental_tables(_) :-
  853    abolish_nonincremental_tables.
  854
  855
  856                 /*******************************
  857                 *        EXAMINE TABLES        *
  858                 *******************************/
  859
  860%!  current_table(:Variant, -Trie) is nondet.
  861%
  862%   True when Trie is the answer table for Variant.
  863
  864current_table(M:Variant, Trie) :-
  865    '$tbl_variant_table'(VariantTrie),
  866    (   (var(Variant) ; var(M))
  867    ->  trie_gen(VariantTrie, M:Variant, Trie)
  868    ;   trie_lookup(VariantTrie, M:Variant, Trie)
  869    ).
  870
  871
  872                 /*******************************
  873                 *      WRAPPER GENERATION      *
  874                 *******************************/
  875
  876:- multifile
  877    system:term_expansion/2,
  878    tabled/2.  879:- dynamic
  880    system:term_expansion/2.  881
  882wrappers(Spec, M) -->
  883    { tabling_defaults([ table_incremental-(incremental=true),
  884                         table_shared-(tshared=true),
  885                         table_subsumptive-(mode=subsumptive)
  886                       ],
  887                       #{}, Defaults)
  888    },
  889    wrappers(Spec, M, Defaults).
  890
  891wrappers(Var, _, _) -->
  892    { var(Var),
  893      !,
  894      '$instantiation_error'(Var)
  895    }.
  896wrappers(M:Spec, _, Opts) -->
  897    !,
  898    { '$must_be'(atom, M) },
  899    wrappers(Spec, M, Opts).
  900wrappers(Spec as Options, M, Opts0) -->
  901    !,
  902    { table_options(Options, Opts0, Opts) },
  903    wrappers(Spec, M, Opts).
  904wrappers((A,B), M, Opts) -->
  905    !,
  906    wrappers(A, M, Opts),
  907    wrappers(B, M, Opts).
  908wrappers(Name//Arity, M, Opts) -->
  909    { atom(Name), integer(Arity), Arity >= 0,
  910      !,
  911      Arity1 is Arity+2
  912    },
  913    wrappers(Name/Arity1, M, Opts).
  914wrappers(Name/Arity, Module, Opts) -->
  915    { '$option'(mode(TMode), Opts, variant),
  916      atom(Name), integer(Arity), Arity >= 0,
  917      !,
  918      functor(Head, Name, Arity),
  919      '$tbl_trienode'(Reserved)
  920    },
  921    qualify(Module,
  922            [ '$tabled'(Head, TMode),
  923              '$table_mode'(Head, Head, Reserved)
  924            ]),
  925    [ (:- initialization('$wrap_tabled'(Module:Head, Opts), now))
  926    ].
  927wrappers(ModeDirectedSpec, Module, Opts) -->
  928    { '$option'(mode(TMode), Opts, variant),
  929      callable(ModeDirectedSpec),
  930      !,
  931      functor(ModeDirectedSpec, Name, Arity),
  932      functor(Head, Name, Arity),
  933      extract_modes(ModeDirectedSpec, Head, Variant, Modes, Moded),
  934      updater_clauses(Modes, Head, UpdateClauses),
  935      mode_check(Moded, ModeTest),
  936      (   ModeTest == true
  937      ->  WrapClause = '$wrap_tabled'(Module:Head, Opts)
  938      ;   WrapClause = '$moded_wrap_tabled'(Module:Head, ModeTest,
  939          Module:Variant, Moded)
  940      )
  941    },
  942    qualify(Module,
  943            [ '$tabled'(Head, TMode),
  944              '$table_mode'(Head, Variant, Moded)
  945            ]),
  946    [ (:- initialization(WrapClause, now))
  947    ],
  948    qualify(Module, UpdateClauses).
  949wrappers(TableSpec, _M, _Opts) -->
  950    { '$type_error'(table_desclaration, TableSpec)
  951    }.
  952
  953qualify(Module, List) -->
  954    { prolog_load_context(module, Module) },
  955    !,
  956    clist(List).
  957qualify(Module, List) -->
  958    qlist(List, Module).
  959
  960clist([])    --> [].
  961clist([H|T]) --> [H], clist(T).
  962
  963qlist([], _)    --> [].
  964qlist([H|T], M) --> [M:H], qlist(T, M).
  965
  966
  967tabling_defaults([], Dict, Dict).
  968tabling_defaults([Flag-(Opt=Value)|T], Dict0, Dict) :-
  969    (   current_prolog_flag(Flag, true)
  970    ->  Dict1 = Dict0.put(Opt,Value)
  971    ;   Dict1 = Dict0
  972    ),
  973    tabling_defaults(T, Dict1, Dict).
  974
  975
  976%!  table_options(+Options, +OptDictIn, -OptDictOut)
  977%
  978%   Handler the ... as _options_ ... construct.
  979
  980table_options(Options, _Opts0, _Opts) :-
  981    var(Options),
  982    '$instantiation_error'(Options).
  983table_options((A,B), Opts0, Opts) :-
  984    !,
  985    table_options(A, Opts0, Opts1),
  986    table_options(B, Opts1, Opts).
  987table_options(subsumptive, Opts0, Opts1) :-
  988    !,
  989    put_dict(mode, Opts0, subsumptive, Opts1).
  990table_options(variant, Opts0, Opts1) :-
  991    !,
  992    put_dict(mode, Opts0, variant, Opts1).
  993table_options(incremental, Opts0, Opts1) :-
  994    !,
  995    put_dict(incremental, Opts0, true, Opts1).
  996table_options(opaque, Opts0, Opts1) :-
  997    !,
  998    put_dict(incremental, Opts0, false, Opts1).
  999table_options(dynamic, Opts0, Opts1) :-
 1000    !,
 1001    put_dict(dynamic, Opts0, true, Opts1).
 1002table_options(shared, Opts0, Opts1) :-
 1003    !,
 1004    put_dict(tshared, Opts0, true, Opts1).
 1005table_options(private, Opts0, Opts1) :-
 1006    !,
 1007    put_dict(tshared, Opts0, false, Opts1).
 1008table_options(Opt, _, _) :-
 1009    '$domain_error'(table_option, Opt).
 1010
 1011%!  mode_check(+Moded, -TestCode)
 1012%
 1013%   Enforce the output arguments of a  mode-directed tabled predicate to
 1014%   be unbound.
 1015
 1016mode_check(Moded, Check) :-
 1017    var(Moded),
 1018    !,
 1019    Check = (var(Moded)->true;'$uninstantiation_error'(Moded)).
 1020mode_check(Moded, true) :-
 1021    '$tbl_trienode'(Moded),
 1022    !.
 1023mode_check(Moded, (Test->true;'$tabling':instantiated_moded_arg(Vars))) :-
 1024    Moded =.. [s|Vars],
 1025    var_check(Vars, Test).
 1026
 1027var_check([H|T], Test) :-
 1028    (   T == []
 1029    ->  Test = var(H)
 1030    ;   Test = (var(H),Rest),
 1031        var_check(T, Rest)
 1032    ).
 1033
 1034:- public
 1035    instantiated_moded_arg/1. 1036
 1037instantiated_moded_arg(Vars) :-
 1038    '$member'(V, Vars),
 1039    \+ var(V),
 1040    '$uninstantiation_error'(V).
 1041
 1042
 1043%!  extract_modes(+ModeSpec, +Head, -Variant, -Modes, -ModedAnswer) is det.
 1044%
 1045%   Split Head into  its  variant  and   term  that  matches  the  moded
 1046%   arguments.
 1047%
 1048%   @arg ModedAnswer is a term that  captures   that  value of all moded
 1049%   arguments of an answer. If there  is   only  one,  this is the value
 1050%   itself. If there are multiple, this is a term s(A1,A2,...)
 1051
 1052extract_modes(ModeSpec, Head, Variant, Modes, ModedAnswer) :-
 1053    compound(ModeSpec),
 1054    !,
 1055    compound_name_arguments(ModeSpec, Name, ModeSpecArgs),
 1056    compound_name_arguments(Head, Name, HeadArgs),
 1057    separate_args(ModeSpecArgs, HeadArgs, VariantArgs, Modes, ModedArgs),
 1058    length(ModedArgs, Count),
 1059    atomic_list_concat([$,Name,$,Count], VName),
 1060    Variant =.. [VName|VariantArgs],
 1061    (   ModedArgs == []
 1062    ->  '$tbl_trienode'(ModedAnswer)
 1063    ;   ModedArgs = [ModedAnswer]
 1064    ->  true
 1065    ;   ModedAnswer =.. [s|ModedArgs]
 1066    ).
 1067extract_modes(Atom, Atom, Variant, [], ModedAnswer) :-
 1068    atomic_list_concat([$,Atom,$,0], Variant),
 1069    '$tbl_trienode'(ModedAnswer).
 1070
 1071%!  separate_args(+ModeSpecArgs, +HeadArgs,
 1072%!		  -NoModesArgs, -Modes, -ModeArgs) is det.
 1073%
 1074%   Split the arguments in those that  need   to  be part of the variant
 1075%   identity (NoModesArgs) and those that are aggregated (ModeArgs).
 1076%
 1077%   @arg Args seems a copy of ModeArgs, why?
 1078
 1079separate_args([], [], [], [], []).
 1080separate_args([HM|TM], [H|TA], [H|TNA], Modes, TMA):-
 1081    indexed_mode(HM),
 1082    !,
 1083    separate_args(TM, TA, TNA, Modes, TMA).
 1084separate_args([M|TM], [H|TA], TNA, [M|Modes], [H|TMA]):-
 1085    separate_args(TM, TA, TNA, Modes, TMA).
 1086
 1087indexed_mode(Mode) :-                           % XSB
 1088    var(Mode),
 1089    !.
 1090indexed_mode(index).                            % YAP
 1091indexed_mode(+).                                % B
 1092
 1093%!  updater_clauses(+Modes, +Head, -Clauses)
 1094%
 1095%   Generates a clause to update the aggregated state.  Modes is
 1096%   a list of predicate names we apply to the state.
 1097
 1098updater_clauses([], _, []) :- !.
 1099updater_clauses([P], Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :- !,
 1100    update_goal(P, S0,S1,S2, Body).
 1101updater_clauses(Modes, Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :-
 1102    length(Modes, Len),
 1103    functor(S0, s, Len),
 1104    functor(S1, s, Len),
 1105    functor(S2, s, Len),
 1106    S0 =.. [_|Args0],
 1107    S1 =.. [_|Args1],
 1108    S2 =.. [_|Args2],
 1109    update_body(Modes, Args0, Args1, Args2, true, Body).
 1110
 1111update_body([], _, _, _, Body, Body).
 1112update_body([P|TM], [A0|Args0], [A1|Args1], [A2|Args2], Body0, Body) :-
 1113    update_goal(P, A0,A1,A2, Goal),
 1114    mkconj(Body0, Goal, Body1),
 1115    update_body(TM, Args0, Args1, Args2, Body1, Body).
 1116
 1117update_goal(Var, _,_,_, _) :-
 1118    var(Var),
 1119    !,
 1120    '$instantiation_error'(Var).
 1121update_goal(lattice(M:PI), S0,S1,S2, M:Goal) :-
 1122    !,
 1123    '$must_be'(atom, M),
 1124    update_goal(lattice(PI), S0,S1,S2, Goal).
 1125update_goal(lattice(Name/Arity), S0,S1,S2, Goal) :-
 1126    !,
 1127    '$must_be'(oneof(integer, lattice_arity, [3]), Arity),
 1128    '$must_be'(atom, Name),
 1129    Goal =.. [Name,S0,S1,S2].
 1130update_goal(lattice(Head), S0,S1,S2, Goal) :-
 1131    compound(Head),
 1132    !,
 1133    compound_name_arity(Head, Name, Arity),
 1134    '$must_be'(oneof(integer, lattice_arity, [3]), Arity),
 1135    Goal =.. [Name,S0,S1,S2].
 1136update_goal(lattice(Name), S0,S1,S2, Goal) :-
 1137    !,
 1138    '$must_be'(atom, Name),
 1139    update_goal(lattice(Name/3), S0,S1,S2, Goal).
 1140update_goal(po(Name/Arity), S0,S1,S2, Goal) :-
 1141    !,
 1142    '$must_be'(oneof(integer, po_arity, [2]), Arity),
 1143    '$must_be'(atom, Name),
 1144    Call =.. [Name, S0, S1],
 1145    Goal = (Call -> S2 = S0 ; S2 = S1).
 1146update_goal(po(M:Name/Arity), S0,S1,S2, Goal) :-
 1147    !,
 1148    '$must_be'(atom, M),
 1149    '$must_be'(oneof(integer, po_arity, [2]), Arity),
 1150    '$must_be'(atom, Name),
 1151    Call =.. [Name, S0, S1],
 1152    Goal = (M:Call -> S2 = S0 ; S2 = S1).
 1153update_goal(po(M:Name), S0,S1,S2, Goal) :-
 1154    !,
 1155    '$must_be'(atom, M),
 1156    '$must_be'(atom, Name),
 1157    update_goal(po(M:Name/2), S0,S1,S2, Goal).
 1158update_goal(po(Name), S0,S1,S2, Goal) :-
 1159    !,
 1160    '$must_be'(atom, Name),
 1161    update_goal(po(Name/2), S0,S1,S2, Goal).
 1162update_goal(Alias, S0,S1,S2, Goal) :-
 1163    update_alias(Alias, Update),
 1164    !,
 1165    update_goal(Update, S0,S1,S2, Goal).
 1166update_goal(Mode, _,_,_, _) :-
 1167    '$domain_error'(tabled_mode, Mode).
 1168
 1169update_alias(first, lattice('$tabling':first/3)).
 1170update_alias(-,     lattice('$tabling':first/3)).
 1171update_alias(last,  lattice('$tabling':last/3)).
 1172update_alias(min,   lattice('$tabling':min/3)).
 1173update_alias(max,   lattice('$tabling':max/3)).
 1174update_alias(sum,   lattice('$tabling':sum/3)).
 1175
 1176mkconj(true, G,  G) :- !.
 1177mkconj(G1,   G2, (G1,G2)).
 1178
 1179
 1180		 /*******************************
 1181		 *          AGGREGATION		*
 1182		 *******************************/
 1183
 1184%!  first(+S0, +S1, -S) is det.
 1185%!  last(+S0, +S1, -S) is det.
 1186%!  min(+S0, +S1, -S) is det.
 1187%!  max(+S0, +S1, -S) is det.
 1188%!  sum(+S0, +S1, -S) is det.
 1189%
 1190%   Implement YAP tabling modes.
 1191
 1192:- public first/3, last/3, min/3, max/3, sum/3. 1193
 1194first(S, _, S).
 1195last(_, S, S).
 1196min(S0, S1, S) :- (S0 @< S1 -> S = S0 ; S = S1).
 1197max(S0, S1, S) :- (S0 @> S1 -> S = S0 ; S = S1).
 1198sum(S0, S1, S) :- S is S0+S1.
 1199
 1200
 1201		 /*******************************
 1202		 *      INCREMENTAL TABLING	*
 1203		 *******************************/
 1204
 1205%!  '$wrap_incremental'(:Head) is det.
 1206%
 1207%   Wrap an incremental dynamic predicate to be added to the IDG.
 1208
 1209'$wrap_incremental'(Head) :-
 1210    abstract_goal(Head, Abstract),
 1211    '$pi_head'(PI, Head),
 1212    (   Head == Abstract
 1213    ->  prolog_listen(PI, dyn_update)
 1214    ;   prolog_listen(PI, dyn_update(Abstract))
 1215    ).
 1216
 1217abstract_goal(M:Head, M:Abstract) :-
 1218    compound(Head),
 1219    '$get_predicate_attribute'(M:Head, abstract, 1),
 1220    !,
 1221    compound_name_arity(Head, Name, Arity),
 1222    functor(Abstract, Name, Arity).
 1223abstract_goal(Head, Head).
 1224
 1225%!  dyn_update(+Action, +Context) is det.
 1226%
 1227%   Track changes to added or removed clauses. We use '$clause'/4
 1228%   because it works on erased clauses.
 1229%
 1230%   @tbd Add a '$clause_head'(-Head, +ClauseRef) to only decompile the
 1231%   head.
 1232
 1233dyn_update(_Action, ClauseRef) :-
 1234    (   atomic(ClauseRef)                       % avoid retractall, start(_)
 1235    ->  '$clause'(Head, _Body, ClauseRef, _Bindings),
 1236        dyn_changed_pattern(Head)
 1237    ;   true
 1238    ).
 1239
 1240dyn_update(Abstract, _, _) :-
 1241    dyn_changed_pattern(Abstract).
 1242
 1243dyn_changed_pattern(Term) :-
 1244    forall(dyn_affected(Term, ATrie),
 1245           '$idg_changed'(ATrie)).
 1246
 1247dyn_affected(Term, ATrie) :-
 1248    '$tbl_variant_table'(VTable),
 1249    trie_gen(VTable, Term, ATrie).
 1250
 1251%!  '$unwrap_incremental'(:Head) is det.
 1252%
 1253%   Remove dynamic predicate incremenal forwarding,   reset the possible
 1254%   `abstract` property and remove possible tables.
 1255
 1256'$unwrap_incremental'(Head) :-
 1257    '$pi_head'(PI, Head),
 1258    (   unwrap_predicate(PI, incremental)
 1259    ->  abstract_goal(Head, Abstract),
 1260        (   Head == Abstract
 1261        ->  prolog_unlisten(PI, dyn_update)
 1262        ;   '$set_predicate_attribute'(Head, abstract, 0),
 1263            prolog_unlisten(PI, dyn_update(_))
 1264        ),
 1265        (   '$tbl_variant_table'(VariantTrie)
 1266        ->  forall(trie_gen(VariantTrie, Head, ATrie),
 1267                   '$tbl_destroy_table'(ATrie))
 1268        ;   true
 1269        )
 1270    ;   true
 1271    ).
 1272
 1273%!  reeval(+ATrie, :Goal, ?Return) is nondet.
 1274%
 1275%   Called  if  the   table   ATrie    is   out-of-date   (has  non-zero
 1276%   _falsecount_). The answers of this predicate are the answers to Goal
 1277%   after re-evaluating the answer trie.
 1278%
 1279%   This finds all dependency  paths  to   dynamic  predicates  and then
 1280%   evaluates the nodes in a breath-first  fashion starting at the level
 1281%   just above the dynamic predicates  and   moving  upwards.  Bottom up
 1282%   evaluation is used to profit from upward propagation of not-modified
 1283%   events that may cause the evaluation to stop early.
 1284%
 1285%   Note that false paths either end  in   a  dynamic node or a complete
 1286%   node. The latter happens if we have and  IDG   "D  -> P -> Q" and we
 1287%   first re-evaluate P for some reason.  Now   Q  can  still be invalid
 1288%   after P has been re-evaluated.
 1289%
 1290%   @arg ATrie is the answer trie.  When shared tabling, we own this
 1291%   trie.
 1292%   @arg Goal is tabled goal (variant).  If we run into a deadlock we
 1293%   need to call this.
 1294%   @arg Return is the return skeleton. We must run
 1295%   trie_gen_compiled(ATrie, Return) to enumerate the answers
 1296
 1297reeval(ATrie, Goal, Return) :-
 1298    catch(try_reeval(ATrie, Goal, Return), deadlock,
 1299          retry_reeval(ATrie, Goal)).
 1300
 1301retry_reeval(ATrie, Goal) :-
 1302    '$tbl_reeval_abandon'(ATrie),
 1303    tdebug(deadlock, 'Deadlock re-evaluating ~p; retrying', [ATrie]),
 1304    sleep(0.000001),
 1305    call(Goal).
 1306
 1307try_reeval(ATrie, Goal, Return) :-
 1308    nb_current('$tbl_reeval', true),
 1309    !,
 1310    tdebug(reeval, 'Nested re-evaluation for ~p', [ATrie]),
 1311    '$tbl_reeval_prepare'(ATrie, _Variant, Clause),
 1312    (   nonvar(Clause)
 1313    ->  trie_gen_compiled(Clause, Return)
 1314    ;   call(Goal)
 1315    ).
 1316try_reeval(ATrie, Goal, Return) :-
 1317    tdebug(reeval, 'Planning reeval for ~p', [ATrie]),
 1318    findall(Path, false_path(ATrie, Path), Paths0),
 1319    sort(0, @>, Paths0, Paths),
 1320    split_paths(Paths, Dynamic, Complete),
 1321    tdebug(forall('$member'(Path, Dynamic),
 1322                  tdebug(reeval, '  Re-eval dynamic path: ~p', [Path]))),
 1323    tdebug(forall('$member'(Path, Complete),
 1324                  tdebug(reeval, '  Re-eval complete path: ~p', [Path]))),
 1325    reeval_paths(Dynamic, ATrie),
 1326    reeval_paths(Complete, ATrie),
 1327    '$tbl_reeval_prepare'(ATrie, _Variant, Clause),
 1328    (   nonvar(Clause)
 1329    ->  trie_gen_compiled(Clause, Return)
 1330    ;   call(Goal)
 1331    ).
 1332
 1333split_paths([], [], []).
 1334split_paths([[Rank-_Len|Path]|T], [Path|DT], CT) :-
 1335    status_rank(dynamic, Rank),
 1336    !,
 1337    split_paths(T, DT, CT).
 1338split_paths([[_|Path]|T], DT, [Path|CT]) :-
 1339    split_paths(T, DT, CT).
 1340
 1341reeval_paths([], _) :-
 1342    !.
 1343reeval_paths(BottomUp, ATrie) :-
 1344    is_invalid(ATrie),
 1345    !,
 1346    reeval_heads(BottomUp, ATrie, BottomUp1),
 1347    reeval_paths(BottomUp1, ATrie).
 1348reeval_paths(_, _).
 1349
 1350reeval_heads(_, ATrie, _) :-
 1351    \+ is_invalid(ATrie),
 1352    !.
 1353reeval_heads([], _, []).
 1354reeval_heads([[H]|B], ATrie, BT) :-
 1355    !,
 1356    reeval_node(H),
 1357    reeval_heads(B, ATrie, BT).
 1358reeval_heads([[]|B], ATrie, BT) :-
 1359    !,
 1360    reeval_heads(B, ATrie, BT).
 1361reeval_heads([[H|T]|B], ATrie, [T|BT]) :-
 1362    !,
 1363    reeval_node(H),
 1364    reeval_heads(B, ATrie, BT).
 1365
 1366%!  false_path(+Atrie, -Path) is nondet.
 1367%
 1368%   True when Path is a list of   invalid  tries (bottom up, ending with
 1369%   ATrie). The last element of the list is a term `Rank-Length` that is
 1370%   used for sorting the paths.
 1371%
 1372%   If we find a table along the  way   that  is being worked on by some
 1373%   other thread we wait for it.
 1374
 1375false_path(ATrie, BottomUp) :-
 1376    false_path(ATrie, Path, []),
 1377    '$reverse'(Path, BottomUp).
 1378
 1379false_path(ATrie, [ATrie|T], Seen) :-
 1380    \+ memberchk(ATrie, Seen),
 1381    '$idg_edge'(ATrie, dependent, Dep),
 1382    '$tbl_reeval_wait'(Dep, Status),
 1383    tdebug(reeval, '    ~p has dependent ~p (~w)', [ATrie, Dep, Status]),
 1384    (   Status == invalid
 1385    ->  false_path(Dep, T, [ATrie|Seen])
 1386    ;   status_rank(Status, Rank),
 1387        length(Seen, Len),
 1388        T = [Rank-Len]
 1389    ).
 1390
 1391status_rank(dynamic,  2) :- !.
 1392status_rank(complete, 1) :- !.
 1393status_rank(Status,   Rank) :-
 1394    var(Rank),
 1395    !,
 1396    format(user_error, 'Re-eval from status ~p~n', [Status]),
 1397    Rank = 0.
 1398status_rank(Rank,   Rank) :-
 1399    format(user_error, 'Re-eval from rank ~p~n', [Rank]).
 1400
 1401is_invalid(ATrie) :-
 1402    '$idg_falsecount'(ATrie, FalseCount),
 1403    FalseCount > 0.
 1404
 1405%!  reeval_node(+ATrie)
 1406%
 1407%   Re-evaluate the invalid answer trie ATrie.  Initially this created a
 1408%   nested tabling environment, but this is dropped:
 1409%
 1410%     - It is possible for the re-evaluating variant to call into outer
 1411%       non/not-yet incremental tables, requiring a merge with this
 1412%       outer SCC.  This doesn't work well with a sub-environment.
 1413%     - We do not need one.  If this environment is not merged into the
 1414%       outer one it will complete before we continue.
 1415
 1416reeval_node(ATrie) :-
 1417    '$tbl_reeval_prepare'(ATrie, Variant, Clause),
 1418    var(Clause),
 1419    !,
 1420    tdebug(reeval, 'Re-evaluating ~p', [Variant]),
 1421    (   '$idg_reset_current',
 1422        setup_call_cleanup(
 1423            nb_setval('$tbl_reeval', true),
 1424            ignore(Variant),                    % assumes local scheduling
 1425            nb_delete('$tbl_reeval')),
 1426        fail
 1427    ;   tdebug(reeval, 'Re-evaluated ~p', [Variant])
 1428    ).
 1429reeval_node(_).
 1430
 1431
 1432		 /*******************************
 1433		 *      EXPAND DIRECTIVES	*
 1434		 *******************************/
 1435
 1436system:term_expansion((:- table(Preds)), Expansion) :-
 1437    \+ current_prolog_flag(xref, true),
 1438    prolog_load_context(module, M),
 1439    phrase(wrappers(Preds, M), Clauses),
 1440    multifile_decls(Clauses, Directives0),
 1441    sort(Directives0, Directives),
 1442    '$append'(Directives, Clauses, Expansion).
 1443
 1444multifile_decls([], []).
 1445multifile_decls([H0|T0], [H|T]) :-
 1446    multifile_decl(H0, H),
 1447    !,
 1448    multifile_decls(T0, T).
 1449multifile_decls([_|T0], T) :-
 1450    multifile_decls(T0, T).
 1451
 1452multifile_decl(M:(Head :- _Body), (:- multifile(M:Name/Arity))) :-
 1453    !,
 1454    functor(Head, Name, Arity).
 1455multifile_decl(M:Head, (:- multifile(M:Name/Arity))) :-
 1456    !,
 1457    functor(Head, Name, Arity).
 1458multifile_decl((Head :- _Body), (:- multifile(Name/Arity))) :-
 1459    !,
 1460    functor(Head, Name, Arity).
 1461multifile_decl(Head, (:- multifile(Name/Arity))) :-
 1462    !,
 1463    Head \= (:-_),
 1464    functor(Head, Name, Arity).
 1465
 1466
 1467		 /*******************************
 1468		 *      ANSWER COMPLETION	*
 1469		 *******************************/
 1470
 1471:- public answer_completion/2. 1472
 1473%!  answer_completion(+AnswerTrie, +Return) is det.
 1474%
 1475%   Find  positive  loops  in  the  residual   program  and  remove  the
 1476%   corresponding answers, possibly causing   additional simplification.
 1477%   This is called from C  if   simplify_component()  detects  there are
 1478%   conditional answers after simplification.
 1479%
 1480%   Note that we are called recursively from   C.  Our caller prepared a
 1481%   clean new tabling environment and restores   the  old one after this
 1482%   predicate terminates.
 1483%
 1484%   @author This code is by David Warren as part of XSB.
 1485%   @see called from C, pl-tabling.c, answer_completion()
 1486
 1487answer_completion(AnswerTrie, Return) :-
 1488    tdebug(trie_goal(AnswerTrie, Goal, _Return)),
 1489    tdebug(ac(start), 'START: Answer completion for ~p', [Goal]),
 1490    call_cleanup(answer_completion_guarded(AnswerTrie, Return, Propagated),
 1491                 abolish_table_subgoals(eval_subgoal_in_residual(_,_))),
 1492    (   Propagated > 0
 1493    ->  answer_completion(AnswerTrie, Return)
 1494    ;   true
 1495    ).
 1496
 1497answer_completion_guarded(AnswerTrie, Return, Propagated) :-
 1498    (   eval_subgoal_in_residual(AnswerTrie, Return),
 1499        fail
 1500    ;   true
 1501    ),
 1502    delete_answers_for_failing_calls(Propagated),
 1503    (   Propagated == 0
 1504    ->  mark_succeeding_calls_as_answer_completed
 1505    ;   true
 1506    ).
 1507
 1508%!  delete_answers_for_failing_calls(-Propagated)
 1509%
 1510%   Delete answers whose condition  is  determined   to  be  `false` and
 1511%   return the number of additional  answers   that  changed status as a
 1512%   consequence of additional simplification propagation.
 1513
 1514delete_answers_for_failing_calls(Propagated) :-
 1515    State = state(0),
 1516    (   subgoal_residual_trie(ASGF, ESGF),
 1517        \+ trie_gen(ESGF, _ETmp),
 1518        tdebug(trie_goal(ASGF, Goal0, _)),
 1519        tdebug(trie_goal(ASGF, Goal, _0Return)),
 1520        '$trie_gen_node'(ASGF, _0Return, ALeaf),
 1521        tdebug(ac(prune), '  Removing answer ~p from ~p', [Goal, Goal0]),
 1522	'$tbl_force_truth_value'(ALeaf, false, Count),
 1523        arg(1, State, Prop0),
 1524        Prop is Prop0+Count-1,
 1525        nb_setarg(1, State, Prop),
 1526	fail
 1527    ;   arg(1, State, Propagated)
 1528    ).
 1529
 1530mark_succeeding_calls_as_answer_completed :-
 1531    (   subgoal_residual_trie(ASGF, _ESGF),
 1532        (   '$tbl_answer_dl'(ASGF, _0Return, _True)
 1533        ->  tdebug(trie_goal(ASGF, Answer, _0Return)),
 1534            tdebug(trie_goal(ASGF, Goal, _0Return)),
 1535            tdebug(ac(prune), '  Completed ~p on ~p', [Goal, Answer]),
 1536            '$tbl_set_answer_completed'(ASGF)
 1537        ),
 1538        fail
 1539    ;   true
 1540    ).
 1541
 1542subgoal_residual_trie(ASGF, ESGF) :-
 1543    '$tbl_variant_table'(VariantTrie),
 1544    context_module(M),
 1545    trie_gen(VariantTrie, M:eval_subgoal_in_residual(ASGF, _), ESGF).
 1546
 1547%!  eval_dl_in_residual(+Condition)
 1548%
 1549%   Evaluate a condition by only looking at   the  residual goals of the
 1550%   involved calls.
 1551
 1552eval_dl_in_residual(true) :-
 1553    !.
 1554eval_dl_in_residual((A;B)) :-
 1555    !,
 1556    (   eval_dl_in_residual(A)
 1557    ;   eval_dl_in_residual(B)
 1558    ).
 1559eval_dl_in_residual((A,B)) :-
 1560    !,
 1561    eval_dl_in_residual(A),
 1562    eval_dl_in_residual(B).
 1563eval_dl_in_residual(tnot(G)) :-
 1564    !,
 1565    tdebug(ac, ' ? tnot(~p)', [G]),
 1566    current_table(G, SGF),
 1567    '$tbl_table_status'(SGF, _Status, _Wrapper, Return),
 1568    tnot(eval_subgoal_in_residual(SGF, Return)).
 1569eval_dl_in_residual(G) :-
 1570    tdebug(ac, ' ? ~p', [G]),
 1571    (   current_table(G, SGF)
 1572    ->	true
 1573    ;   more_general_table(G, SGF)
 1574    ->	true
 1575    ;	writeln(user_error, 'MISSING CALL? '(G)),
 1576        fail
 1577    ),
 1578    '$tbl_table_status'(SGF, _Status, _Wrapper, Return),
 1579    eval_subgoal_in_residual(SGF, Return).
 1580
 1581more_general_table(G, Trie) :-
 1582    term_variables(G, Vars),
 1583    '$tbl_variant_table'(VariantTrie),
 1584    trie_gen(VariantTrie, G, Trie),
 1585    is_most_general_term(Vars).
 1586
 1587:- table eval_subgoal_in_residual/2. 1588
 1589%!  eval_subgoal_in_residual(+AnswerTrie, ?Return)
 1590%
 1591%   Derive answers for the variant represented   by  AnswerTrie based on
 1592%   the residual goals only.
 1593
 1594eval_subgoal_in_residual(AnswerTrie, _Return) :-
 1595    '$tbl_is_answer_completed'(AnswerTrie),
 1596    !,
 1597    undefined.
 1598eval_subgoal_in_residual(AnswerTrie, Return) :-
 1599    '$tbl_answer'(AnswerTrie, Return, Condition),
 1600    tdebug(trie_goal(AnswerTrie, Goal, Return)),
 1601    tdebug(ac, 'Condition for ~p is ~p', [Goal, Condition]),
 1602    eval_dl_in_residual(Condition).
 1603
 1604%!  undefined
 1605%
 1606%   Expresses the value _bottom_ from the well founded semantics.
 1607
 1608:- table
 1609    undefined/0. 1610
 1611undefined :-
 1612    tnot(undefined)