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.
83neck.
84
85neck --> [].
94necki.
95
96necki --> [].
105necks.
106
107necks --> [].
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 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 269 270 271 272 273 284 ; 285 286 287 288 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) 315 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
351goal_expansion(phrase(Body, L, T), Expanded) :-
352 nonvar(Body),
353 354 dcg_translate_rule(('$head$' --> Body, '$sink$'), _, ('$head$'(L, _) :- Expanded, '$sink$'(T, _)), _)
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.
*/