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