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.

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, 215 ( NeckHead = A:B 216 ->freeze(A, freeze(B, track_deps(File, Line, M, NeckHead, Expanded))) 217 ; track_deps(File, Line, M, NeckHead, Expanded) 218 )), 219 HasCP = hascp(yes), 220 term_variables(Head-Right, HNVarU), 221 term_variables(Expanded, ExVarU), 222 sort(HNVarU, HNVarL), 223 sort(ExVarU, ExVarL), 224 ord_intersection(ExVarL, HNVarL, AssignedL), 225 ( memberchk(Neck, [neck, neck(_, _), necks, necks(_, _)]), 226 Head \== '<declaration>', 227 nonvar(SepBody), 228 member(SepBody, [(_, _), (_;_), (_->_), \+ _]), 229 expand_goal(M:SepBody, M:ExpBody), 230 ExpBody \= true, 231 term_variables(t(Head, Expanded, LRight), VarHU), 232 '$expand':remove_var_attr(VarHU, '$var_info'), 233 sort(VarHU, VarHL), 234 term_variables(ExpBody, VarBU), 235 sort(VarBU, VarBL), 236 ord_intersection(VarHL, VarBL, ArgNB), 237 variant_sha1(ArgNB-ExpBody, Hash), 238 neck_prefix(NeckPrefix), 239 format(atom(FNB), '~w~w:~w', [NeckPrefix, M, Hash]), 240 SepHead =.. [FNB|ArgNB], 241 conj(LRight, SepHead, NeckBody), 242 findall(t(Pattern, Head), call_checks(Neck, File, Line, Expanded, HasCP), ClausePIL), 243 ( '$get_predicate_attribute'(M:SepHead, defined, 1), 244 '$get_predicate_attribute'(M:SepHead, number_of_clauses, _) 245 ->true 246 ; ClausePIL \= [_] 247 ) 248 ->RTHead = SepHead, 249 phrase(( findall((:- discontiguous IM:F/A), 250 distinct(IM:F/A, 251 ( member(t(_, H), ClausePIL), 252 H \== '<declaration>', 253 strip_module(M:H, IM, P), 254 functor(P, F, A) 255 ))), 256 ( { '$get_predicate_attribute'(M:SepHead, defined, 1), 257 '$get_predicate_attribute'(M:SepHead, number_of_clauses, _) 258 } 259 ->[] 260 ; [(SepHead :- ExpBody)] 261 ) 262 ), ClauseL1) 263 ; expand_goal(M:Right, M:NeckBody), 264 findall(t(Pattern, Head), call_checks(Neck, File, Line, Expanded, HasCP), ClausePIL), 265 RTHead = Head, 266 ClauseL1 = [] 267 ), 268 ( Head == '<declaration>' 269 ->true 270 ; HasCP = hascp(yes) 271 ->true 272 % Since this is a critical warning, we prevent app programmers to be able 273 % to disable it, in any case there is always a possibility to refactorize 274 % the code to prevent this warning --EMM 275 % ; memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)]) 276 % ->true 277 /* 278 ; ClausePIL = [t(_, MHead)], 279 strip_module(Head, _, Head1), 280 compound(Head1), 281 strip_module(MHead, _, Head2), 282 arg(1, Head1, Arg1), 283 arg(1, Head2, Arg2), 284 var(Arg1), 285 nonvar(Arg2) 286 ->true 287 */ 288 ; % Compare performance with simple unification via a fact to see if neck is 289 % improving the performance or not, it works with non deterministic 290 % predicates assuming the worst case scenario (upper bound). But note that 291 % this will compare interpreted prolog, not optimized/compiled code or 292 % indexing effects: 293 profile_expander(M, Head, AssignedL, Expanded, Issues), 294 Issues \= [] 295 ->maplist(warning_nocp(File, Line, M, Head), Issues), 296 fail 297 ; true 298 ), 299 phrase(( findall(Clause, member(t(Clause, _), ClausePIL)), 300 findall(Clause, 301 ( \+ memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)]), 302 Head \== '<declaration>', 303 SepBody \= true, 304 distinct(Clause, st_body(Head, M, RTHead, ClausePIL, Clause)) 305 )) 306 ), ClauseL, ClauseL1). 307 308term_expansion_hb(Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL) :- 309 source_location(File, Line), 310 '$current_source_module'(M), 311 term_expansion_hb(File, Line, M, Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL). 312 313st_body(Head, M, RTHead, ClausePIL, Clause) :- 314 member(t(_, Head), ClausePIL), 315 resolve_calln(RTHead, RTHeadN), 316 strip_module(M:RTHeadN, RTM, RTPred), 317 functor(RTPred, RTF, RTA), 318 member(Clause, [(:- discontiguous RTM:RTF/RTA) % silent random warnings 319 %(:- multifile RTM:RTF/RTA) % silent audit warnings 320 ]). 321 322warning_nocp(File, Line, M, H, _-[InfCurrent, InfOptimal]) :- 323 print_message( 324 warning, 325 at_location( 326 file(File, Line, -1, _), 327 format("Ignored neck on ~w, since it could cause performance degradation (~w)", 328 [M:H, InfCurrent < InfOptimal]))). 329 330check_has_neck(Body, Neck, Static, Right) :- 331 once(( current_seq_lit(Body, Neck, Static, Right), 332 memberchk(Neck, [neck, neck(X, X), necki, necki(X, X), 333 necks, necks(X, X), neckis, neckis(X, X)]) 334 )). 335 336term_expansion((Head :- Body), ClauseL) :- 337 check_has_neck(Body, Neck, Static, Right), 338 term_expansion_hb(Head, Neck, Static, Right, Head, NB, (Head :- NB), ClauseL). 339term_expansion((Head --> Body), ClauseL) :- 340 current_seq_lit(Body, Neck1, _, _), 341 memberchk(Neck1, [neck, necki, necks, neckis]), 342 ( var(Head) 343 ->dcg_translate_rule((call(Head) --> Body), _, (H1 :- B), _), 344 freeze(Head, resolve_calln(H1, H)) 345 ; dcg_translate_rule((Head --> Body), _, (H :- B), _), 346 H1 = H 347 ), 348 check_has_neck(B, Neck, Static, Right), 349 term_expansion_hb(H1, Neck, Static, Right, H, NB, (H :- NB), ClauseL). 350term_expansion((:- Body), ClauseL) :- 351 check_has_neck(Body, Neck, Static, Right), 352 term_expansion_hb('<declaration>', Neck, Static, Right, '<declaration>', NB, (:- NB), ClauseL). 353 354% Trick to continue translation: expand phrase/3 once the goal is instantiated 355goal_expansion(phrase(Body, L, T), Expanded) :- 356 nonvar(Body), 357 % '$sink' is a kludge to avoid T be instantiated to [end_of_file] (?) --EMM 358 dcg_translate_rule(('$head$' --> Body, '$sink$'), _, ('$head$'(L, _) :- Expanded, '$sink$'(T, _)), _)