1/*  Part of Extended Libraries for SWI-Prolog
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/xlibrary
    6    Copyright (C): 2015, Process Design Center, Breda, The Netherlands.
    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(neck,
   36          [ neck/0,
   37            neck/2,
   38            necki/0,
   39            necki/2,
   40            necks/0,
   41            necks/2,
   42            neckis/0,
   43            neckis/2
   44          ]).   45
   46:- use_module(library(lists)).   47:- use_module(library(pairs)).   48:- use_module(library(apply)).   49:- use_module(library(resolve_calln)).   50:- use_module(library(transpose)).   51:- use_module(library(choicepoints)).   52:- use_module(library(statistics)).   53:- use_module(library(ordsets)).   54:- use_module(library(solution_sequences)).   55:- use_module(library(checkct)).   56:- reexport(library(track_deps)).   57:- reexport(library(compound_expand)).   58:- init_expansors.

Neck, a Compile-Time Evaluator

Implements several predicates to establish that everything above them should be evaluated at compile time, be careful since such part can only contain predicates already defined. In case of non-determinism, several clauses would be generated. This is a practical way to generate automatic clauses with a proper instantiation of the head. If the code can not be expanded, it will succeed without side effects.

These predicates can also be used in declarations, although in that case, no warnings will be shown about run-time parts being executed, since declarations are executed at compile-time.

*/

 neck is det
 neck(L, L) is det
neck/0 and neck//0 are used if you want to put the body in a separated predicate, and consider it the run-time only part of it, meaning that you can not use it until the compilation of the module has finished.
   83neck.
   84
   85neck --> [].
 necki is det
 necki(L, L) is det
necki/0 and necki//0 (i=inlined) are used if you don't want to create ancillary predicates for the body, but rather have the body inlined.
   94necki.
   95
   96necki --> [].
 necks is det
 necks(L, L) is det
necks/0 and necks//0 (s=silent) will not warn you if the non-expandable parts are called at compile-time.
  105necks.
  106
  107necks --> [].
 neckis is det
 neckis(L, L) is det
neckis/0 and neckis//0 are a combination of inlined and silent.
  115neckis.
  116
  117neckis --> [].
  118
  119current_seq_lit(Seq, Lit, Left, Right) :-
  120    current_seq_lit(Seq, Lit, true, Left, true, Right).
  121
  122conj(T, C, C) :- T == true.
  123conj(C, T, C) :- T == true.
  124conj(A, B, (A, B)).
  125
  126current_seq_lit(S, _, _, _, _, _) :-
  127    var(S),
  128    !,
  129    fail.
  130current_seq_lit(S, S, L, L, R, R).
  131current_seq_lit((H, T), S, L1, L, R1, R) :-
  132    ( once(conj(T, R1, R2)),
  133      current_seq_lit(H, S, L1, L, R2, R)
  134    ; once(conj(L1, H, L2)),
  135      current_seq_lit(T, S, L2, L, R1, R)
  136    ).
  137
  138assign_value(A, V) -->
  139    ( {var(A)}
  140    ->{A=V}
  141    ; [A-V]
  142    ).
  143
  144neck_prefix('__aux_neck_').
  145
  146neck_needs_check(neck,         true).
  147neck_needs_check(necki,        true).
  148neck_needs_check(neck(  _, _), true).
  149neck_needs_check(necki( _, _), true).
  150neck_needs_check(necks,        fail).
  151neck_needs_check(necks( _, _), fail).
  152neck_needs_check(neckis,       fail).
  153neck_needs_check(neckis(_, _), fail).
  154
  155call_checks(Neck, File, Line, Call, HasCP) :-
  156    neck_needs_check(Neck, Check),
  157    has_choicepoints(do_call_checks(Check, File, Line, Call), nb_setarg(1, HasCP, no)).
  158
  159avl_testclause(AVL, F, Head, Body) :-
  160    pairs_keys_values(AVL, ArgH, ArgB),
  161    Head =.. [F|ArgH],
  162    Body =.. [F|ArgB].
  163
  164sumarize_1(Key-LL, Key-[InfCurrent, InfOptimal]) :-
  165    transpose(LL, [CL, OL]),
  166    sum_list(CL, InfCurrent),
  167    sum_list(OL, InfOptimal).
  168
  169variant_sha1_nat(Term, Hash) :-
  170    copy_term_nat(Term, Tnat),
  171    variant_sha1(Tnat, Hash).
  172
  173performance_issue(_-[InfCurrent, InfOptimal]) :- InfCurrent < InfOptimal.
  174
  175profile_expander(M, Head, AssignedL, Expanded, Issues) :-
  176    findall(Key-[InfCurrent, InfOptimal],
  177            ( F1 = '__aux_test_clause_evl',
  178              TestH =.. [F1|AssignedL],
  179              functor(TestH, F1, A),
  180              F2 = '__aux_test_clause_seq',
  181              functor(TestL, F2, A),
  182              setup_call_cleanup(
  183                  assertz(M:TestH :- Expanded),
  184                  call_time(M:TestH, T1),
  185                  abolish(M:F1/A)),
  186              foldl(assign_value, AssignedL, _, AVL, []),
  187              avl_testclause(AVL, F2, TestB, TestL),
  188              setup_call_cleanup(
  189                  assertz(M:TestB),
  190                  call_time(M:TestL, T2),
  191                  abolish(M:F2/A)),
  192              variant_sha1_nat(M:Head, Key),
  193              InfCurrent = T1.inferences,
  194              InfOptimal = T2.inferences
  195            ), InfCurrentU),
  196    keysort(InfCurrentU, InfCurrentL),
  197    group_pairs_by_key(InfCurrentL, InfCurrentG),
  198    maplist(sumarize_1, InfCurrentG, InfCurrentS),
  199    include(performance_issue, InfCurrentS, Issues).
  200
  201do_call_checks(true, File, Line, Call) :- call_checkct(Call, File, Line, []).
  202do_call_checks(fail, _,    _,    Call) :- call(Call).
  203
  204term_expansion_hb(File, Line, M, Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL) :-
  205    once(( current_seq_lit(Right, !, LRight, SepBody),
  206           \+ current_seq_lit(SepBody, !, _, _)
  207           % We can not move the part above a cut to a separate clause
  208         ; LRight = true,
  209           SepBody = Right
  210         )),
  211    term_variables(Head, HVars),
  212    '$expand':mark_vars_non_fresh(HVars),
  213    expand_goal(M:Static, Expanded),
  214    freeze(NeckHead, track_deps(File, Line, M, NeckHead, Expanded)),
  215    HasCP = hascp(yes),
  216    term_variables(Head-Right, HNVarU),
  217    term_variables(Expanded, ExVarU),
  218    sort(HNVarU, HNVarL),
  219    sort(ExVarU, ExVarL),
  220    ord_intersection(ExVarL, HNVarL, AssignedL),
  221    ( memberchk(Neck, [neck, neck(_, _), necks, necks(_, _)]),
  222      Head \== '<declaration>',
  223      nonvar(SepBody),
  224      member(SepBody, [(_, _), (_;_), (_->_), \+ _]),
  225      expand_goal(M:SepBody, M:ExpBody),
  226      ExpBody \= true,
  227      term_variables(t(Head, Expanded, LRight), VarHU),
  228      '$expand':remove_var_attr(VarHU, '$var_info'),
  229      sort(VarHU, VarHL),
  230      term_variables(ExpBody, VarBU),
  231      sort(VarBU, VarBL),
  232      ord_intersection(VarHL, VarBL, ArgNB),
  233      variant_sha1(ArgNB-ExpBody, Hash),
  234      neck_prefix(NeckPrefix),
  235      format(atom(FNB), '~w~w:~w', [NeckPrefix, M, Hash]),
  236      SepHead =.. [FNB|ArgNB],
  237      conj(LRight, SepHead, NeckBody),
  238      findall(t(Pattern, Head), call_checks(Neck, File, Line, Expanded, HasCP), ClausePIL),
  239      ( '$get_predicate_attribute'(M:SepHead, defined, 1),
  240        '$get_predicate_attribute'(M:SepHead, number_of_clauses, _)
  241      ->true
  242      ; ClausePIL \= [_]
  243      )
  244    ->RTHead = SepHead,
  245      phrase(( findall((:- discontiguous IM:F/A),
  246                       distinct(IM:F/A,
  247                                ( member(t(_, H), ClausePIL),
  248                                  H \== '<declaration>',
  249                                  strip_module(M:H, IM, P),
  250                                  functor(P, F, A)
  251                                ))),
  252               ( { '$get_predicate_attribute'(M:SepHead, defined, 1),
  253                   '$get_predicate_attribute'(M:SepHead, number_of_clauses, _)
  254                 }
  255               ->[]
  256               ; [(SepHead :- ExpBody)]
  257               )
  258             ), ClauseL1)
  259    ; expand_goal(M:Right, M:NeckBody),
  260      findall(t(Pattern, Head), call_checks(Neck, File, Line, Expanded, HasCP), ClausePIL),
  261      RTHead = Head,
  262      ClauseL1 = []
  263    ),
  264    ( Head == '<declaration>'
  265    ->true
  266    ; HasCP = hascp(yes)
  267    ->true
  268    % Since this is a critical warning, we prevent app programmers to be able
  269    % to disable it, in any case there is always a possibility to refactorize
  270    % the code to prevent this warning --EMM
  271    % ; memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)])
  272    % ->true
  273    /*
  274    ; ClausePIL = [t(_, MHead)],
  275      strip_module(Head,  _, Head1),
  276      compound(Head1),
  277      strip_module(MHead, _, Head2),
  278      arg(1, Head1, Arg1),
  279      arg(1, Head2, Arg2),
  280      var(Arg1),
  281      nonvar(Arg2)
  282    ->true
  283    */
  284    ; % Compare performance with simple unification via a fact to see if neck is
  285      % improving the performance or not, it works with non deterministic
  286      % predicates assuming the worst case scenario (upper bound). But note that
  287      % this will compare interpreted prolog, not optimized/compiled code or
  288      % indexing effects:
  289      profile_expander(M, Head, AssignedL, Expanded, Issues),
  290      Issues \= []
  291    ->maplist(warning_nocp(File, Line, M, Head), Issues),
  292      fail
  293    ; true
  294    ),
  295    phrase(( findall(Clause, member(t(Clause, _), ClausePIL)),
  296             findall(Clause,
  297                     ( \+ memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)]),
  298                       Head \== '<declaration>',
  299                       SepBody \= true,
  300                       distinct(Clause, st_body(Head, M, RTHead, ClausePIL, Clause))
  301                     ))
  302           ), ClauseL, ClauseL1).
  303
  304term_expansion_hb(Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL) :-
  305    source_location(File, Line),
  306    '$current_source_module'(M),
  307    term_expansion_hb(File, Line, M, Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL).
  308
  309st_body(Head, M, RTHead, ClausePIL, Clause) :-
  310    member(t(_, Head), ClausePIL),
  311    resolve_calln(RTHead, RTHeadN),
  312    strip_module(M:RTHeadN, RTM, RTPred),
  313    functor(RTPred, RTF, RTA),
  314    member(Clause, [(:- discontiguous RTM:RTF/RTA) % silent random warnings
  315                    %(:- multifile RTM:RTF/RTA) % silent audit warnings
  316                   ]).
  317
  318warning_nocp(File, Line, M, H, _-[InfCurrent, InfOptimal]) :-
  319    print_message(
  320        warning,
  321        at_location(
  322            file(File, Line, -1, _),
  323            format("Ignored neck on ~w, since it could cause performance degradation (~w)",
  324                   [M:H, InfCurrent < InfOptimal]))).
  325
  326check_has_neck(Body, Neck, Static, Right) :-
  327    once(( current_seq_lit(Body, Neck, Static, Right),
  328           memberchk(Neck, [neck, neck(X, X), necki, necki(X, X),
  329                            necks, necks(X, X), neckis, neckis(X, X)])
  330         )).
  331
  332term_expansion((Head :- Body), ClauseL) :-
  333    check_has_neck(Body, Neck, Static, Right),
  334    term_expansion_hb(Head, Neck, Static, Right, Head, NB, (Head :- NB), ClauseL).
  335term_expansion((Head --> Body), ClauseL) :-
  336    current_seq_lit(Body, Neck1, _, _),
  337    memberchk(Neck1, [neck, necki, necks, neckis]),
  338    ( var(Head)
  339    ->dcg_translate_rule((call(Head) --> Body), _, (H1 :- B), _),
  340      freeze(Head, resolve_calln(H1, H))
  341    ; dcg_translate_rule((Head --> Body), _, (H :- B), _),
  342      H1 = H
  343    ),
  344    check_has_neck(B, Neck, Static, Right),
  345    term_expansion_hb(H1, Neck, Static, Right, H, NB, (H :- NB), ClauseL).
  346term_expansion((:- Body), ClauseL) :-
  347    check_has_neck(Body, Neck, Static, Right),
  348    term_expansion_hb('<declaration>', Neck, Static, Right, '<declaration>', NB, (:- NB), ClauseL).
  349
  350% Trick to continue translation: expand phrase/3 once the goal is instantiated
  351goal_expansion(phrase(Body, L, T), Expanded) :-
  352    nonvar(Body),
  353    % '$sink' is a kludge to avoid T be instantiated to [end_of_file] (?) --EMM
  354    dcg_translate_rule(('$head$' --> Body, '$sink$'), _, ('$head$'(L, _) :- Expanded, '$sink$'(T, _)), _)