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