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 ; findall(t(Pattern, Head), 280 ( call_checks(Neck, File, Line, Expanded, HasCP), 281 % expand_goal called inside here in case call_checks causes the 282 % instantiation of potential partial-evaluable expressions: 283 expand_goal(M:Right, M:NeckBody) 284 ), ClausePIL), 285 RTHead = Head, 286 ClauseL1 = [] 287 ), 288 ( Head == '<declaration>' 289 ->true 290 ; HasCP = hascp(yes) 291 ->true 292 % Since this is a critical warning, we prevent app programmers to be able 293 % to disable it, in any case there is always a possibility to refactorize 294 % the code to prevent this warning --EMM 295 % ; memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)]) 296 % ->true 297 /* 298 ; ClausePIL = [t(_, MHead)], 299 strip_module(Head, _, Head1), 300 compound(Head1), 301 strip_module(MHead, _, Head2), 302 arg(1, Head1, Arg1), 303 arg(1, Head2, Arg2), 304 var(Arg1), 305 nonvar(Arg2) 306 ->true 307 */ 308 ; % Compare performance with simple unification via a fact to see if neck is 309 % improving the performance or not, it works with non deterministic 310 % predicates assuming the worst case scenario (upper bound). But note that 311 % this will compare interpreted prolog, not optimized/compiled code or 312 % indexing effects: 313 profile_expander(M, Head, AssignedL, Expanded, Issues), 314 Issues \= [] 315 ->maplist(warning_nocp(File, Line, M, Head), Issues), 316 fail 317 ; true 318 ), 319 phrase(( findall(Clause, member(t(Clause, _), ClausePIL)), 320 findall(Clause, 321 ( \+ memberchk(Neck, [necks, necks(_, _), neckis, neckis(_, _)]), 322 Head \== '<declaration>', 323 SepBody \= true, 324 distinct(Clause, st_body(Head, M, RTHead, ClausePIL, Clause)) 325 )) 326 ), ClauseL, ClauseL1). 327 328term_expansion_hb(Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL) :- 329 source_location(File, Line), 330 '$current_source_module'(M), 331 term_expansion_hb(File, Line, M, Head, Neck, Static, Right, NeckHead, NeckBody, Pattern, ClauseL). 332 333st_body(Head, M, RTHead, ClausePIL, Clause) :- 334 member(t(_, Head), ClausePIL), 335 resolve_calln(RTHead, RTHeadN), 336 strip_module(M:RTHeadN, RTM, RTPred), 337 functor(RTPred, RTF, RTA), 338 member(Clause, [(:- discontiguous RTM:RTF/RTA) % silent random warnings 339 %(:- multifile RTM:RTF/RTA) % silent audit warnings 340 ]). 341 342warning_nocp(File, Line, M, H, _-[InfCurrent, InfOptimal]) :- 343 print_message( 344 warning, 345 at_location( 346 file(File, Line, -1, _), 347 format("Ignored neck on ~w, since it could cause performance degradation (~w)", 348 [M:H, InfCurrent < InfOptimal]))). 349 350check_has_neck(Body, Neck, Static, Right) :- 351 once(( current_seq_lit(Body, Neck, Static, Right), 352 memberchk(Neck, [neck, neck(X, X), necki, necki(X, X), 353 necks, necks(X, X), neckis, neckis(X, X)]) 354 )). 355 356term_expansion((Head :- Body), ClauseL) :- 357 check_has_neck(Body, Neck, Static, Right), 358 term_expansion_hb(Head, Neck, Static, Right, Head, NB, (Head :- NB), ClauseL). 359term_expansion((Head --> Body), ClauseL) :- 360 current_seq_lit(Body, Neck1, _, _), 361 memberchk(Neck1, [neck, necki, necks, neckis]), 362 ( var(Head) 363 ->dcg_translate_rule((call(Head) --> Body), _, (H1 :- B), _), 364 freeze(Head, resolve_calln(H1, H)) 365 ; dcg_translate_rule((Head --> Body), _, (H :- B), _), 366 H1 = H 367 ), 368 check_has_neck(B, Neck, Static, Right), 369 term_expansion_hb(H1, Neck, Static, Right, H, NB, (H :- NB), ClauseL). 370term_expansion((:- Body), ClauseL) :- 371 check_has_neck(Body, Neck, Static, Right), 372 term_expansion_hb('<declaration>', Neck, Static, Right, '<declaration>', NB, (:- NB), ClauseL). 373 374% Trick to continue translation: expand phrase/3 once the goal is instantiated 375goal_expansion(phrase(Body, L, T), Expanded) :- 376 nonvar(Body), 377 % '$sink' is a kludge to avoid T be instantiated to [end_of_file] (?) --EMM 378 dcg_translate_rule(('$head$' --> Body, '$sink$'), _, ('$head$'(L, _) :- Expanded, '$sink$'(T, _)), _)