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, Benoit Desouter, Jan Wielemaker, Fabrizio Riguzzi
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(tabling,
   36          [ (table)/1,                  % +PI ...
   37
   38            current_table/2,            % :Variant, ?Table
   39            abolish_all_tables/0,
   40            abolish_table_subgoals/1,   % :Subgoal
   41
   42            start_tabling/2,            % +Wrapper, :Worker.
   43
   44            op(1150, fx, table)
   45          ]).   46:- use_module(library(error)).   47:- set_prolog_flag(generate_debug_info, false).   48
   49:- meta_predicate
   50    start_tabling(+, 0),
   51    current_table(:, -),
   52    abolish_table_subgoals(:).   53
   54/** <module> Tabled execution (SLG WAM)
   55
   56This  library  handled  _tabled_  execution   of  predicates  using  the
   57characteristics if the _SLG WAM_. The   required  suspension is realised
   58using _delimited continuations_ implemented by  reset/3 and shift/1. The
   59table space and work lists are part of the SWI-Prolog core.
   60
   61@author Benoit Desouter
   62*/
   63
   64%!  table(+PredicateIndicators)
   65%
   66%   Prepare the given PredicateIndicators for   tabling. Can only be
   67%   used as a directive. The example   below  prepares the predicate
   68%   edge/2 and the non-terminal statement//1 for tabled execution.
   69%
   70%     ==
   71%     :- table edge/2, statement//1.
   72%     ==
   73%
   74%   In addition to using _predicate  indicators_,   a  predicate  can be
   75%   declared for _mode  directed  tabling_  using   a  term  where  each
   76%   argument declares the intended mode.  For example:
   77%
   78%     ==
   79%     :- table connection(_,_,min).
   80%     ==
   81%
   82%   _Mode directed tabling_ is  discussed   in  the general introduction
   83%   section about tabling.
   84
   85table(PIList) :-
   86    throw(error(context_error(nodirective, table(PIList)), _)).
   87
   88%!  start_tabling(+Variant, +Implementation)
   89%
   90%   Execute Implementation using tabling. This  predicate should not
   91%   be called directly. The table/1 directive  causes a predicate to
   92%   be translated into a renamed implementation   and a wrapper that
   93%   involves this predicate.
   94%
   95%   @compat This interface may change or disappear without notice
   96%           from future versions.
   97
   98start_tabling(Wrapper, Worker) :-
   99    get_wrapper_no_mode_args(Wrapper, WrapperNoModes, ModeArgs),
  100    '$tbl_variant_table'(WrapperNoModes, Trie, Status),
  101    (   Status == complete
  102    ->  trie_gen(Trie, WrapperNoModes, ModeArgs)
  103    ;   (   '$tbl_scheduling_component'(false, true)
  104        ->  catch(run_leader(Wrapper, WrapperNoModes, Worker, Trie),
  105                  E, true),
  106            (   var(E)
  107            ->  trie_gen(Trie, WrapperNoModes, ModeArgs)
  108            ;   '$tbl_table_discard_all',
  109                throw(E)
  110            )
  111        ;   run_follower(Status, Wrapper, WrapperNoModes, Worker, Trie)
  112        )
  113    ).
  114
  115get_wrapper_no_mode_args(M:Wrapper, M:WrapperNoModes, ModeArgs) :-
  116    M:'$table_mode'(Wrapper, WrapperNoModes, ModeArgs).
  117
  118run_follower(fresh, Wrapper, WrapperNoModes, Worker, Trie) :-
  119    !,
  120    activate(Wrapper, WrapperNoModes, Worker, Trie, Worklist),
  121    shift(call_info(Wrapper, Worklist)).
  122run_follower(Worklist, Wrapper, _WrapperNoModes, _Worker, _Trie) :-
  123    shift(call_info(Wrapper, Worklist)).
  124
  125run_leader(Wrapper, WrapperNoModes, Worker, Trie) :-
  126    activate(Wrapper, WrapperNoModes, Worker, Trie, _Worklist),
  127    completion,
  128    '$tbl_scheduling_component'(_, false).
  129
  130activate(Wrapper, WrapperNoModes, Worker, Trie, WorkList) :-
  131    '$tbl_new_worklist'(WorkList, Trie),
  132    (   delim(Wrapper, WrapperNoModes, Worker, WorkList),
  133        fail
  134    ;   true
  135    ).
  136
  137%!  delim(+Wrapper, +Worker, +WorkList).
  138%!  delim(+Wrapper, +WrapperNoModes, +Worker, +WorkList).
  139%
  140%   Call/resume Worker
  141
  142delim(Wrapper, Worker, WorkList) :-
  143    reset(Worker, SourceCall, Continuation),
  144    add_answer_or_suspend(Continuation, Wrapper,
  145                          WorkList, SourceCall).
  146
  147add_answer_or_suspend(0, Wrapper, WorkList, _) :-
  148    !,
  149    '$tbl_wkl_add_answer'(WorkList, Wrapper).
  150add_answer_or_suspend(Continuation, Wrapper, WorkList,
  151                      call_info(SrcWrapper, SourceWL)) :-
  152    '$tbl_wkl_add_suspension'(
  153        SourceWL,
  154        dependency(SrcWrapper, Continuation, Wrapper, WorkList)).
  155
  156delim(Wrapper, WrapperNoModes, Worker, WorkList) :-
  157    reset(Worker, SourceCall, Continuation),
  158    add_answer_or_suspend(Continuation, Wrapper, WrapperNoModes,
  159                          WorkList, SourceCall).
  160
  161add_answer_or_suspend(0, Wrapper, WrapperNoModes, WorkList, _) :-
  162    !,
  163    get_wrapper_no_mode_args(Wrapper, _, ModeArgs),
  164    '$tbl_wkl_mode_add_answer'(WorkList, WrapperNoModes,
  165                               ModeArgs, Wrapper).
  166add_answer_or_suspend(Continuation, Wrapper, _WrapperNoModes, WorkList,
  167                      call_info(SrcWrapper, SourceWL)) :-
  168    '$tbl_wkl_add_suspension'(
  169        SourceWL,
  170        dependency(SrcWrapper, Continuation, Wrapper, WorkList)).
  171
  172%!  update(+Wrapper, +A1, +A2, -A3) is det.
  173%
  174%   Update the aggregated value for  an   answer.  Wrapper is the tabled
  175%   goal, A1 is the aggregated value so far, A2 is the new answer and A3
  176%   should be unified with the new   aggregated value. The new aggregate
  177%   is ignored if it is the same as the old one.
  178
  179:- public
  180    update/4.  181
  182update(M:Wrapper, A1, A2, A3) :-
  183    M:'$table_update'(Wrapper, A1, A2, A3),
  184    A1 \=@= A3.
  185
  186
  187%!  completion
  188%
  189%   Wakeup suspended goals until no new answers are generated.
  190
  191completion :-
  192    '$tbl_pop_worklist'(WorkList),
  193    !,
  194    completion_step(WorkList),
  195    completion.
  196completion :-
  197    '$tbl_table_complete_all'.
  198
  199completion_step(SourceTable) :-
  200    (   '$tbl_trienode'(Reserved),
  201        '$tbl_wkl_work'(SourceTable,
  202                        Answer, ModeArgs,
  203                        Goal, Continuation, Wrapper, TargetTable),
  204        (   ModeArgs == Reserved
  205        ->  Goal = Answer,
  206            delim(Wrapper, Continuation, TargetTable)
  207        ;   get_wrapper_no_mode_args(Goal, Answer, ModeArgs),
  208            get_wrapper_no_mode_args(Wrapper, WrapperNoModes, _),
  209            delim(Wrapper, WrapperNoModes, Continuation, TargetTable)
  210        ),
  211        fail
  212    ;   true
  213    ).
  214
  215                 /*******************************
  216                 *            CLEANUP           *
  217                 *******************************/
  218
  219%!  abolish_all_tables
  220%
  221%   Remove all tables. This is normally used to free up the space or
  222%   recompute the result after predicates on   which  the result for
  223%   some tabled predicates depend.
  224%
  225%   @error  permission_error(abolish, table, all) if tabling is
  226%           in progress.
  227
  228abolish_all_tables :-
  229    '$tbl_abolish_all_tables'.
  230
  231%!  abolish_table_subgoals(:Subgoal) is det.
  232%
  233%   Abolish all tables that unify with SubGoal.
  234
  235abolish_table_subgoals(M:SubGoal) :-
  236    '$tbl_variant_table'(VariantTrie),
  237    current_module(M),
  238    forall(trie_gen(VariantTrie, M:SubGoal, Trie),
  239           '$tbl_destroy_table'(Trie)).
  240
  241
  242                 /*******************************
  243                 *        EXAMINE TABLES        *
  244                 *******************************/
  245
  246%!  current_table(:Variant, -Trie) is nondet.
  247%
  248%   True when Trie is the answer table for Variant.
  249
  250current_table(M:Variant, Trie) :-
  251    '$tbl_variant_table'(VariantTrie),
  252    (   (var(Variant) ; var(M))
  253    ->  trie_gen(VariantTrie, M:Variant, Trie)
  254    ;   trie_lookup(VariantTrie, M:Variant, Trie)
  255    ).
  256
  257
  258                 /*******************************
  259                 *      WRAPPER GENERATION      *
  260                 *******************************/
  261
  262:- multifile
  263    system:term_expansion/2,
  264    prolog:rename_predicate/2,
  265    tabled/2.  266:- dynamic
  267    system:term_expansion/2.  268
  269wrappers(Var) -->
  270    { var(Var),
  271      !,
  272      instantiation_error(Var)
  273    }.
  274wrappers((A,B)) -->
  275    !,
  276    wrappers(A),
  277    wrappers(B).
  278wrappers(Name//Arity) -->
  279    { atom(Name), integer(Arity), Arity >= 0,
  280      !,
  281      Arity1 is Arity+2
  282    },
  283    wrappers(Name/Arity1).
  284wrappers(Name/Arity) -->
  285    { atom(Name), integer(Arity), Arity >= 0,
  286      !,
  287      functor(Head, Name, Arity),
  288      atom_concat(Name, ' tabled', WrapName),
  289      Head =.. [Name|Args],
  290      WrappedHead =.. [WrapName|Args],
  291      prolog_load_context(module, Module),
  292      '$tbl_trienode'(Reserved)
  293    },
  294    [ '$tabled'(Head),
  295      '$table_mode'(Head, Head, Reserved),
  296      (   Head :-
  297             start_tabling(Module:Head, WrappedHead)
  298      )
  299    ].
  300wrappers(ModeDirectedSpec) -->
  301    { callable(ModeDirectedSpec),
  302      !,
  303      functor(ModeDirectedSpec, Name, Arity),
  304      functor(Head, Name, Arity),
  305      atom_concat(Name, ' tabled', WrapName),
  306      Head =.. [Name|Args],
  307      WrappedHead =.. [WrapName|Args],
  308      extract_modes(ModeDirectedSpec, Head, Variant, Modes, Moded),
  309      updater_clauses(Modes, Head, UpdateClauses),
  310      prolog_load_context(module, Module)
  311    },
  312    [ '$tabled'(Head),
  313      '$table_mode'(Head, Variant, Moded),
  314      (   Head :-
  315             start_tabling(Module:Head, WrappedHead)
  316      )
  317    | UpdateClauses
  318    ].
  319wrappers(TableSpec) -->
  320    { type_error(table_desclaration, TableSpec)
  321    }.
  322
  323
  324%!  extract_modes(+ModeSpec, +Head, -Variant, -Modes, -ModedAnswer) is det.
  325%
  326%   Split Head into  its  variant  and   term  that  matches  the  moded
  327%   arguments.
  328%
  329%   @arg ModedAnswer is a term that  captures   that  value of all moded
  330%   arguments of an answer. If there  is   only  one,  this is the value
  331%   itself. If there are multiple, this is a term s(A1,A2,...)
  332
  333extract_modes(ModeSpec, Head, Variant, Modes, ModedAnswer) :-
  334    compound_name_arguments(ModeSpec, Name, ModeSpecArgs),
  335    compound_name_arguments(Head, Name, HeadArgs),
  336    separate_args(ModeSpecArgs, HeadArgs, VariantArgs, Modes, ModedArgs),
  337    Variant =.. [Name|VariantArgs],
  338    (   ModedArgs == []
  339    ->  '$tbl_trienode'(ModedAnswer)
  340    ;   ModedArgs = [ModedAnswer]
  341    ->  true
  342    ;   ModedAnswer =.. [s|ModedArgs]
  343    ).
  344
  345%!  separate_args(+ModeSpecArgs, +HeadArgs,
  346%!		  -NoModesArgs, -Modes, -ModeArgs) is det.
  347%
  348%   Split the arguments in those that  need   to  be part of the variant
  349%   identity (NoModesArgs) and those that are aggregated (ModeArgs).
  350%
  351%   @arg Args seems a copy of ModeArgs, why?
  352
  353separate_args([], [], [], [], []).
  354separate_args([HM|TM], [H|TA], [H|TNA], Modes, TMA):-
  355    indexed_mode(HM),
  356    !,
  357    separate_args(TM, TA, TNA, Modes, TMA).
  358separate_args([M|TM], [H|TA], TNA, [M|Modes], [H|TMA]):-
  359    separate_args(TM, TA, TNA, Modes, TMA).
  360
  361indexed_mode(Mode) :-                           % XSB
  362    var(Mode),
  363    !.
  364indexed_mode(index).                            % YAP
  365indexed_mode(+).                                % B
  366
  367%!  updater_clauses(+Modes, +Head, -Clauses)
  368%
  369%   Generates a clause to update the aggregated state.  Modes is
  370%   a list of predicate names we apply to the state.
  371
  372updater_clauses([], _, []) :- !.
  373updater_clauses([P], Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :- !,
  374    update_goal(P, S0,S1,S2, Body).
  375updater_clauses(Modes, Head, [('$table_update'(Head, S0, S1, S2) :- Body)]) :-
  376    length(Modes, Len),
  377    functor(S0, s, Len),
  378    functor(S1, s, Len),
  379    functor(S2, s, Len),
  380    S0 =.. [_|Args0],
  381    S1 =.. [_|Args1],
  382    S2 =.. [_|Args2],
  383    update_body(Modes, Args0, Args1, Args2, true, Body).
  384
  385update_body([], _, _, _, Body, Body).
  386update_body([P|TM], [A0|Args0], [A1|Args1], [A2|Args2], Body0, Body) :-
  387    update_goal(P, A0,A1,A2, Goal),
  388    mkconj(Body0, Goal, Body1),
  389    update_body(TM, Args0, Args1, Args2, Body1, Body).
  390
  391update_goal(Var, _,_,_, _) :-
  392    var(Var),
  393    !,
  394    instantiation_error(Var).
  395update_goal(lattice(M:PI), S0,S1,S2, M:Goal) :-
  396    !,
  397    must_be(atom, M),
  398    update_goal(lattice(PI), S0,S1,S2, Goal).
  399update_goal(lattice(Name/Arity), S0,S1,S2, Goal) :-
  400    !,
  401    must_be(oneof([3]), Arity),
  402    must_be(atom, Name),
  403    Goal =.. [Name,S0,S1,S2].
  404update_goal(lattice(Name), S0,S1,S2, Goal) :-
  405    !,
  406    must_be(atom, Name),
  407    update_goal(lattice(Name/3), S0,S1,S2, Goal).
  408update_goal(po(Name/Arity), S0,S1,S2, Goal) :-
  409    !,
  410    must_be(oneof([2]), Arity),
  411    must_be(atom, Name),
  412    Call =.. [Name, S0, S1],
  413    Goal = (Call -> S2 = S0 ; S2 = S1).
  414update_goal(po(M:Name/Arity), S0,S1,S2, Goal) :-
  415    !,
  416    must_be(atom, M),
  417    must_be(oneof([2]), Arity),
  418    must_be(atom, Name),
  419    Call =.. [Name, S0, S1],
  420    Goal = (M:Call -> S2 = S0 ; S2 = S1).
  421update_goal(po(M:Name), S0,S1,S2, Goal) :-
  422    !,
  423    must_be(atom, M),
  424    must_be(atom, Name),
  425    update_goal(po(M:Name/2), S0,S1,S2, Goal).
  426update_goal(po(Name), S0,S1,S2, Goal) :-
  427    !,
  428    must_be(atom, Name),
  429    update_goal(po(Name/2), S0,S1,S2, Goal).
  430update_goal(Alias, S0,S1,S2, Goal) :-
  431    update_alias(Alias, Update),
  432    !,
  433    update_goal(Update, S0,S1,S2, Goal).
  434update_goal(Mode, _,_,_, _) :-
  435    domain_error(tabled_mode, Mode).
  436
  437update_alias(first, lattice(tabling:first/3)).
  438update_alias(-,     lattice(tabling:first/3)).
  439update_alias(last,  lattice(tabling:last/3)).
  440update_alias(min,   lattice(tabling:min/3)).
  441update_alias(max,   lattice(tabling:max/3)).
  442update_alias(sum,   lattice(tabling:sum/3)).
  443
  444mkconj(true, G,  G) :- !.
  445mkconj(G1,   G2, (G1,G2)).
  446
  447
  448		 /*******************************
  449		 *          AGGREGATION		*
  450		 *******************************/
  451
  452%!  first(+S0, +S1, -S) is det.
  453%!  last(+S0, +S1, -S) is det.
  454%!  min(+S0, +S1, -S) is det.
  455%!  max(+S0, +S1, -S) is det.
  456%!  sum(+S0, +S1, -S) is det.
  457%
  458%   Implement YAP tabling modes.
  459
  460:- public first/3, last/3, min/3, max/3, sum/3.  461
  462first(S, _, S).
  463last(_, S, S).
  464min(S0, S1, S) :- (S0 @< S1 -> S = S0 ; S = S1).
  465max(S0, S1, S) :- (S0 @> S1 -> S = S0 ; S = S1).
  466sum(S0, S1, S) :- S is S0+S1.
  467
  468
  469		 /*******************************
  470		 *         RENAME WORKER	*
  471		 *******************************/
  472
  473%!  prolog:rename_predicate(:Head0, :Head) is semidet.
  474%
  475%   Hook into term_expansion for  post   processing  renaming of the
  476%   generated predicate.
  477
  478prolog:rename_predicate(M:Head0, M:Head) :-
  479    '$flushed_predicate'(M:'$tabled'(_)),
  480    call(M:'$tabled'(Head0)),
  481    !,
  482    rename_term(Head0, Head).
  483
  484rename_term(Compound0, Compound) :-
  485    compound(Compound0),
  486    !,
  487    compound_name_arguments(Compound0, Name, Args),
  488    atom_concat(Name, ' tabled', WrapName),
  489    compound_name_arguments(Compound, WrapName, Args).
  490rename_term(Name, WrapName) :-
  491    atom_concat(Name, ' tabled', WrapName).
  492
  493
  494system:term_expansion((:- table(Preds)),
  495                      [ (:- multifile('$tabled'/1)),
  496                        (:- multifile('$table_mode'/3)),
  497                        (:- multifile('$table_update'/4))
  498                      | Clauses
  499                      ]) :-
  500    phrase(wrappers(Preds), Clauses).
  501
  502
  503                 /*******************************
  504                 *           SANDBOX            *
  505                 *******************************/
  506
  507:- multifile
  508    sandbox:safe_directive/1,
  509    sandbox:safe_primitive/1,
  510    sandbox:safe_meta/2.  511
  512%!  sandbox:safe_directive(+Directive) is semidet.
  513%
  514%   Allow tabling directives that affect locally defined predicates.
  515
  516sandbox:safe_directive(Dir) :-
  517    ground(Dir),
  518    local_tabling_dir(Dir).
  519
  520local_tabling_dir(table(Preds)) :-
  521    local_preds(Preds).
  522
  523local_preds((A,B)) :-
  524    !,
  525    local_preds(A),
  526    local_preds(B).
  527
  528local_preds(Name/Arity) :-
  529    atom(Name), integer(Arity).
  530local_preds(Name//Arity) :-
  531    atom(Name), integer(Arity).
  532
  533sandbox:safe_meta_predicate(tabling:start_tabling/2).
  534
  535sandbox:safe_primitive(tabling:abolish_all_tables).
  536sandbox:safe_meta(tabling:abolish_table_subgoals(V), []) :-
  537    \+ qualified(V).
  538sandbox:safe_meta(tabling:current_table(V, _), []) :-
  539    \+ qualified(V).
  540
  541qualified(V) :-
  542    nonvar(V),
  543    V = _:_