1 % (c) 2009-2025 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5
6 :- module(memoization,[store_memo_expansion/3,
7 get_stored_memo_expansion/3,
8 compute_memo_hash/2,
9 store_memo_computation_time/2, % for profiling
10
11 register_memoization_function/6,
12 get_registered_function/2, get_registered_function/3,
13 get_registered_function_name/2,
14 is_registered_function_name/1, is_registered_function_name/2,
15 is_memoization_closure/2, is_memoization_closure/4,
16 get_memoization_closure_value/4,
17 %expand_memoize_stored_function_reference/2,
18 store_memo_result/6,
19 get_stored_memo_result/4,
20 apply_to_memoize/8,
21 get_complete_memoization_expansion/6,
22 element_of_memoization_closure/6,
23 not_element_of_memoization_closure/6,
24 is_lambda_value_domain_memoization_closure/5,
25
26 tcltk_get_memo_profile_table/1,
27 print_memo_profile/0,
28 reset_memo_table/0,
29 reset_memo_with_statistics/0]).
30
31 :- use_module(error_manager).
32 :- use_module(debug).
33
34 :- use_module(module_information,[module_info/2]).
35 :- module_info(group,kernel).
36 :- module_info(description,'This module provides memoization features (for closure expansion, closure1,...).').
37 % used when use_closure_expansion_memoization is true
38
39 :- use_module(probsrc(closures),[is_symbolic_closure/3]).
40 :- use_module(probsrc(kernel_waitflags),[add_error_wf/5, add_message_wf/5, add_warning_wf/5]).
41
42
43
44 :- use_module(eventhandling,[register_event_listener/3]).
45 :- register_event_listener(startup_prob,init_memo_table,
46 'Initialise Preferences').
47 :- register_event_listener(clear_specification,reset_memo_table,
48 'Reset Temporary Preferences.').
49
50
51
52 % ---------------- Memoization for set comprehension / lambda / closure1 expansion:
53
54 get_stored_memo_expansion(Hash,Term,Result) :-
55 stored_memo_expansion(Hash,Term,Result),
56 inc_counter(memoization_reuse_counter,_).
57
58 :- dynamic stored_memo_expansion/3.
59
60 store_memo_expansion(Hash,LookupTerm,StoredResult) :-
61 assertz(stored_memo_expansion(Hash,LookupTerm,StoredResult)).
62
63 :- if(current_prolog_flag(dialect, sicstus)).
64 :- use_module(library(terms),[term_hash/3]).
65 compute_memo_hash(LookupTerm,Hash) :-
66 inc_counter(memoization_hash_counter,_),
67 term_hash(LookupTerm,
68 [range(smallint),algorithm(sdbm), depth(infinite),if_var(ignore)],Hash).
69 %hashing:my_term_hash(closure(Parameters,ParameterTypes,ClosureBody),Hash),
70 %inc(Hash), %
71 :- else.
72 :- use_module(hashing,[my_term_hash/2]).
73 compute_memo_hash(LookupTerm,Hash) :-
74 inc_counter(memoization_hash_counter,_),
75 my_term_hash(LookupTerm,Hash).
76 :- endif.
77
78 % ---------------- Memoization for function application
79
80 :- dynamic registered_value_packed/3, registered_value_name/2, memoization_expansion_completed/1.
81
82 % we register the functions to be memoized
83 get_registered_function(Id,Val) :- registered_value(Id,_,Val).
84 get_registered_function(Id,Name,Val) :- registered_value(Id,Name,Val).
85 get_registered_function_name(Id,Name) :- registered_value_name(Id,Name).
86 is_registered_function_name(Name) :- registered_value_name(_,Name).
87 is_registered_function_name(Name,Expanded) :- registered_value_name(ID,Name),
88 (memoization_expansion_completed(ID) -> Expanded=true ; Expanded=false).
89
90 :- use_module(tools,[remove_variables/3]).
91 :- use_module(kernel_tools,[ground_value_check/2, value_variables/2]).
92 % register a (usually symbolic closure) value as a function
93 % ElType is the type of the elements of the function and MemoResultClosure is a closure that
94 % can and should be used instead of BValue to ensure memoization works
95 register_memoization_function(Name,BValue,ElType,RecursionInfo,MemoID,MemoResultClosure) :-
96 value_variables(BValue,Vars),
97 %print(vars(Name,Vars,LHSValue)),nl, print(bvalue(BValue)),nl,
98 (RecursionInfo='$recursion_value'(RecValue)
99 -> remove_variables(Vars,[RecValue],WVars), % do not wait on RecValue; it will be set by registering MEMOID
100 RecValue = MemoResultClosure,
101 InnerMemoID=MemoID % already instantiate MemoID before asserting closure; cyclic use
102 ; WVars=Vars
103 ),
104 ground_value_check(WVars,Ground),
105 %print(register(Name,MemoID,Ground,BValue)),nl,nl,
106 construct_memoization_closure(MemoID,BValue,ElType,MemoResultClosure),
107 register_memoization_function_aux(Ground,Name,BValue,InnerMemoID,MemoID).
108
109 :- block register_memoization_function_aux(-,?,?,?,?).
110 register_memoization_function_aux(_,Name,BValue,InnerMemoID,MemoID) :-
111 inc_counter(memoization_function_counter,InnerMemoID),
112 formatsilent('Registering function ~w for memoization: ~w~n',[InnerMemoID,Name]),
113 (ground_value(BValue) -> true ; add_internal_error('Non ground memo closure: ',InnerMemoID:BValue)),
114 %(BValue=closure(_,_,BB) -> bsyntaxtree:check_used_ids_in_ast(BB) ; true),
115 compile_value(BValue,InnerMemoID),
116 assertz(registered_value_name(InnerMemoID,Name)),
117 assert_registered_value(InnerMemoID,Name,BValue),
118 %if(MemoID=InnerMemoID, format('Finish ~w~n',[MemoID]),format('FAILURE ~w~n',[InnerMemoID])).
119 MemoID=InnerMemoID. % only unify after assertz; in case co-routines are triggered which call get_registered_function
120
121 :- use_module(state_packing,[pack_value/2,unpack_value/2]).
122 assert_registered_value(InnerMemoID,Name,BValue) :-
123 pack_value(BValue,PValue),
124 % mainly useful when COMPRESSION preference is full or
125 % when force_state_packing_for_closures is true so that closure bodies packed
126 assertz(registered_value_packed(InnerMemoID,Name,PValue)).
127
128 registered_value(InnerMemoID,Name,BValue) :-
129 registered_value_packed(InnerMemoID,Name,PValue),
130 unpack_value(PValue,BValue).
131
132 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
133 :- if(environ(cogen,true)).
134 compile_value(closure(Paras,Ty,Body),InnerMemoID) :-
135 compile_closure(Paras,Ty,Body,InnerMemoID),!.
136 compile_value(_,_).
137 :- use_module(b_cogen).
138 :- else.
139 compile_value(_,_).
140 reset_cogen.
141 :- endif.
142
143 construct_memoization_closure(MemoID,BValue,ElType,Result) :-
144 get_infos(BValue,BInfos),
145 XFC = b(external_function_call('MEMOIZE_STORED_FUNCTION',[b(value(int(MemoID)),integer,[])]),set(ElType),[]),
146 TID = b(identifier('_zzzz_unary'),ElType,[]),
147 Body = b(member(TID,XFC),pred,[prob_annotation('MEMOIZE'(MemoID))|BInfos]),
148 %bsyntaxtree:check_used_ids_in_ast(Body),
149 Result = closure(['_zzzz_unary'],[ElType], Body).
150
151 :- use_module(bsyntaxtree,[get_texpr_info/2, extract_info_wo_used_ids/2, extract_pos_infos/2]). % extract_info_wo_used_ids
152 % extract important infos,
153 get_infos(Var,Res) :- var(Var),!,Res=[].
154 get_infos(closure(_,_,B),Res) :- extract_info_wo_used_ids(B,Infos),!,
155 get_texpr_info(B,AllInfos),extract_pos_infos(AllInfos,Pos),
156 append(Pos,Infos,Res).
157 get_infos(_,[]). % :- print(no_infos(A)),nl.
158
159 is_memoization_closure(closure(Ids,T,Body),MemoID) :-
160 is_memoization_closure(Ids,T,Body,MemoID).
161
162 :- use_module(bsyntaxtree, [get_texpr_id/2]).
163 is_memoization_closure([ID],_T,b(Body,_,INFO),MemoID) :-
164 ? member(prob_annotation('MEMOIZE'(MemoID)),INFO),
165 % check Body has not been rewritten:
166 Body = member(TID,b(RHS,_,_)),
167 get_texpr_id(TID,ID),
168 is_memoize_stored_function_reference(RHS,MemoID).
169
170 is_memoize_stored_function_reference(external_function_call('MEMOIZE_STORED_FUNCTION',[Arg]),MemoID) :-
171 Arg=b(value(int(MemoID)),_,_).
172
173 % check if we have a memoization closure and get its stored value
174 get_memoization_closure_value(P,T,B,Value) :-
175 is_memoization_closure(P,T,B,MemoID),
176 number(MemoID),
177 registered_value(MemoID,_,Value).
178
179 % expand an (untyped) expression term referring to a stored function into full value:
180 %expand_memoize_stored_function_reference(Expr,Value) :-
181 % is_memoize_stored_function_reference(Expr,MemoID),
182 % number(MemoID), % in case this is called before function registered
183 % registered_value(MemoID,_,Value).
184
185 :- use_module(probsrc(closures),[is_lambda_value_domain_normal_closure/5]).
186 :- dynamic stored_lambda_value_domain/3.
187 % Note: the caller must check that DomainValue, Expr are not equal to fail
188 is_lambda_value_domain_memoization_closure(P,T,Pred, DomainValue,Expr) :-
189 ? is_memoization_closure(P,T,Pred,MemoID),
190 number(MemoID),
191 (stored_lambda_value_domain(MemoID,DV,E)
192 -> true %print(get_domain(MemoID)),nl
193 ; registered_value(MemoID,_,closure(P2,T2,Pred2)),
194 %print(storing(lambda_domain(MemoID))),nl,
195 (is_lambda_value_domain_normal_closure(P2,T2,Pred2, DV,E)
196 -> assertz(stored_lambda_value_domain(MemoID,DV,E))
197 ; assertz(stored_lambda_value_domain(MemoID,fail,fail)),
198 fail
199 )
200 ),
201 DomainValue=DV, Expr = E.
202
203
204 % ----------------------------------------------
205 % providing stored_memo_result_id/4 fact interface
206 % some MemoID are stored in separate table
207 :- dynamic stored_memo_result1/3, stored_memo_result2/3,
208 stored_memo_result3/3, stored_memo_result4/3,
209 stored_memo_result5/3, stored_memo_result6/3,
210 stored_memo_result7/3, stored_memo_result8/3,
211 stored_memo_result/4.
212 stored_memo_result_id(1,ArgHash,Argument,StoredResult) :- !,
213 stored_memo_result1(ArgHash,Argument,StoredResult).
214 stored_memo_result_id(2,ArgHash,Argument,StoredResult) :- !,
215 stored_memo_result2(ArgHash,Argument,StoredResult).
216 stored_memo_result_id(3,ArgHash,Argument,StoredResult) :- !,
217 stored_memo_result3(ArgHash,Argument,StoredResult).
218 stored_memo_result_id(4,ArgHash,Argument,StoredResult) :- !,
219 stored_memo_result4(ArgHash,Argument,StoredResult).
220 stored_memo_result_id(5,ArgHash,Argument,StoredResult) :- !,
221 ? stored_memo_result5(ArgHash,Argument,StoredResult).
222 stored_memo_result_id(6,ArgHash,Argument,StoredResult) :- !,
223 ? stored_memo_result6(ArgHash,Argument,StoredResult).
224 stored_memo_result_id(7,ArgHash,Argument,StoredResult) :- !,
225 ? stored_memo_result7(ArgHash,Argument,StoredResult).
226 stored_memo_result_id(8,ArgHash,Argument,StoredResult) :- !,
227 ? stored_memo_result8(ArgHash,Argument,StoredResult).
228 stored_memo_result_id(MemoID,ArgHash,Argument,StoredResult) :-
229 ? stored_memo_result(ArgHash,MemoID,Argument,StoredResult).
230
231 assert_stored_memo_result_id(1,ArgHash,Argument,StoredResult) :- !,
232 assertz(stored_memo_result1(ArgHash,Argument,StoredResult)).
233 assert_stored_memo_result_id(2,ArgHash,Argument,StoredResult) :- !,
234 assertz(stored_memo_result2(ArgHash,Argument,StoredResult)).
235 assert_stored_memo_result_id(3,ArgHash,Argument,StoredResult) :- !,
236 assertz(stored_memo_result3(ArgHash,Argument,StoredResult)).
237 assert_stored_memo_result_id(4,ArgHash,Argument,StoredResult) :- !,
238 assertz(stored_memo_result4(ArgHash,Argument,StoredResult)).
239 assert_stored_memo_result_id(5,ArgHash,Argument,StoredResult) :- !,
240 assertz(stored_memo_result5(ArgHash,Argument,StoredResult)).
241 assert_stored_memo_result_id(6,ArgHash,Argument,StoredResult) :- !,
242 assertz(stored_memo_result6(ArgHash,Argument,StoredResult)).
243 assert_stored_memo_result_id(7,ArgHash,Argument,StoredResult) :- !,
244 assertz(stored_memo_result7(ArgHash,Argument,StoredResult)).
245 assert_stored_memo_result_id(8,ArgHash,Argument,StoredResult) :- !,
246 assertz(stored_memo_result8(ArgHash,Argument,StoredResult)).
247 assert_stored_memo_result_id(MemoID,ArgHash,Argument,StoredResult) :-
248 assertz(stored_memo_result(ArgHash,MemoID,Argument,StoredResult)).
249
250 retractall_stored_memo_result :-
251 retractall(stored_memo_result1(_,_,_)),
252 retractall(stored_memo_result2(_,_,_)),
253 retractall(stored_memo_result3(_,_,_)),
254 retractall(stored_memo_result4(_,_,_)),
255 retractall(stored_memo_result5(_,_,_)),
256 retractall(stored_memo_result6(_,_,_)),
257 retractall(stored_memo_result7(_,_,_)),
258 retractall(stored_memo_result8(_,_,_)),
259 retractall(stored_memo_result(_,_,_,_)).
260
261 % this clause is only ok if we have just a single function; otherwise we get collisions between different functions
262 compute_funcall_memo_hash(int(X),MemoID,R) :- MemoID <9, !,
263 R=X. % avoid computing hash for simple integer values; only drawback: indexing not good for too large integers
264 % TO DO: we could register with each registered_value fact also a dynamic table_memo fact
265 % then we can avoid clashes between different memoized functions
266 compute_funcall_memo_hash(X,MemoID,ArgHash) :-
267 compute_memo_hash((MemoID,X),ArgHash).
268
269
270 % --------------------------------------------
271
272 % last argument should be left free when calling
273 get_stored_memo_result(MemoID,Argument,ArgHash,StoredResult) :-
274 stored_memo_result_id(MemoID,ArgHash,Argument,StoredResult),
275 %print(get_stored(MemoID,ArgHash,StoredResult)),nl,
276 count_reuse(MemoID).
277
278
279 :- use_module(kernel_waitflags,[add_wd_error_span/4]).
280 :- use_module(tools_strings,[ajoin/2]).
281 :- use_module(store,[normalise_value_for_var/3]).
282 store_memo_result(MemoID,Argument,ArgHash,Result,Span,WF) :-
283 normalise_value_for_var(MemoID,Result,NormResult),
284 store_norm_memo_result(MemoID,Argument,ArgHash,NormResult,Span,WF).
285
286 :- use_module(kernel_objects,[equal_object/2]).
287 store_norm_memo_result(MemoID,Argument,ArgHash,Result,Span,WF) :-
288 stored_memo_result_id(MemoID,ArgHash,Argument,StoredResult),
289 !,
290 (Result=StoredResult -> true
291 ; equal_object(Result,StoredResult) -> format('Two representations for memoized function (~w) result.~n',[MemoID])
292 ; ajoin(['Memoized function ',MemoID,' has multiple results for: '],Msg),
293 Relation = [(Argument,StoredResult),(Argument,Result)],
294 add_wd_error_span(Msg,'@fun'(Argument,Relation),Span,WF)
295 %,print('stored: '),translate:print_bvalue(StoredResult),nl,print('new: '),translate:print_bvalue(Result),nl
296 ).
297 store_norm_memo_result(MemoID,Argument,ArgHash,Result,_,_) :-
298 %format('Storing memo result for ~w, argument =',[MemoID]),
299 %translate:print_bvalue(Argument),nl, translate:print_bvalue(Result),nl,
300 assert_stored_memo_result_id(MemoID,ArgHash,Argument,Result).
301 %assertz(stored_memo_result(ArgHash,MemoID,Argument,Result)).
302 %print(stored_memo_result(ArgHash,MemoID,Argument,Result)),nl.
303
304
305 % function application for memoized function:
306 apply_to_memoize(MemoID,P,T,B,X,Y,Span,WF) :-
307 ground_value_check(X,XV),
308 block_apply_closure_memo_groundx(XV,MemoID,X,Y,P,T,B,raise_wd,Span,WF).
309
310 :- use_module(kernel_tools,[ground_value/1]).
311 :- use_module(kernel_objects,[equal_object_wf/3]).
312
313 :- block block_apply_closure_memo_groundx(-,?, ?,?, ?,?,?, ?,?,?),
314 block_apply_closure_memo_groundx(?,-, ?,?, ?,?,?, ?,?,?).
315
316
317 block_apply_closure_memo_groundx(_,MemoID, X,Y, P,T,B, RaiseWD, Span,WF) :-
318 % MemoID is ground, meaning body B is ground as well
319 % TODO: obtain stored value directly
320 compute_funcall_memo_hash(X,MemoID,ArgHash),
321 if(get_stored_memo_result(MemoID,X,ArgHash,StoredResult),
322 equal_object_wf(Y,StoredResult,WF),
323 (start_profile_function_application(MemoID,Timer),
324 if(check_element_of_function_closure_nowf(MemoID,X,ComputedResult,P,T,B,Span,WF),
325 % ground WF to compute ground value for ComputedResult
326 (stop_profile_function_application(MemoID,X,Timer,WF),
327 (ground_value(ComputedResult)
328 -> store_memo_result(MemoID,X,ArgHash,ComputedResult,Span,WF)
329 ; add_error_wf(memoization,'Could not compute ground value for function application',MemoID,Span,WF),
330 print('Argument: '),translate:print_bvalue(X),nl,
331 print('Result: '), print(ComputedResult),nl,
332 print('Function: '),registered_value(MemoID,_Name,FunValue), translate:print_bvalue(FunValue),nl,nl
333 ),
334 % To do: check if we compute two or more solutions for f(X) and add WD error
335 equal_object_wf(Y,ComputedResult,WF)
336 ),
337 (RaiseWD=raise_wd,
338 add_wd_error_span('function applied outside of domain (#8-Memo): ', '@fun'(X,closure(P,T,B)),Span,WF)
339 )
340 )
341 )
342 ).
343
344 :- use_module(kernel_waitflags, [init_wait_flags/2, init_wait_flags_and_push_call_stack/3,ground_wait_flags/1]).
345 :- use_module(custom_explicit_sets,[check_element_of_function_closure/6]).
346 check_element_of_function_closure_nowf(MemoID,X,ComputedResult,_,_,_,Span,OuterWF) :-
347 registered_value(MemoID,Name,closure(P,T,B)),!, % can be expensive if closure contains large values
348 init_wait_flags_and_push_call_stack(OuterWF,function_call(Name,X,Span),WF), % slows down test 1968 with recursion
349 check_element_of_function_closure(X,ComputedResult,P,T,B,WF),
350 ground_wait_flags(WF).
351 check_element_of_function_closure_nowf(_,X,ComputedResult,P,T,B,_Span,_OuterWF) :-
352 init_wait_flags(WF,[check_element_of_function_closure_nowf]),
353 check_element_of_function_closure(X,ComputedResult,P,T,B,WF),
354 ground_wait_flags(WF).
355
356 :- use_module(library(avl),[avl_domain/2]).
357 :- use_module(library(lists),[maplist/2]).
358
359 % store the complete expansion of a memoized function for later re-use
360 % and also passes result and done flag to an outer call
361 :- block store_memoization_closure_expansion(?,-,?,?,?,?,?).
362 store_memoization_closure_expansion(MemoID,_,Res,OuterDone,OuterRes,Span,WF) :-
363 my_avl_domain(Res,List),
364 !,
365 debug_println(19,storing_expansion_of_memoized_function(MemoID)),
366 (maplist(store_function_result(MemoID,Span,WF),List)
367 -> assertz(memoization_expansion_completed(MemoID))
368 ; add_internal_error(memoization,'Error storing expansion for memoized function:',MemoID,Span)),
369 equal_object_wf(Res,OuterRes,WF), OuterDone=true.
370 store_memoization_closure_expansion(MemoID,_,R,OuterDone,OuterRes,Span,WF) :-
371 add_warning_wf(memoization,'Cannot store expansion for memoized function:',MemoID:R,Span,WF),
372 equal_object_wf(R,OuterRes,WF), OuterDone=true.
373
374 my_avl_domain(avl_set(A),List) :- avl_domain(A,List).
375 my_avl_domain([],[]).
376
377 store_function_result(MemoID,Span,WF,(X,ComputedResult)) :-
378 compute_funcall_memo_hash(X,MemoID,ArgHash),
379 store_memo_result(MemoID,X,ArgHash,ComputedResult,Span,WF). % TO DO: we could use special version that also allows relations
380
381 :- use_module(kernel_objects,[equal_object_optimized_wf/4]).
382 % succeeds if function has been completely memoized and returns expansion
383 try_get_complete_memoization_expansion(MemoID,Result,WF) :-
384 memoization_expansion_completed(MemoID),
385 debug_println(19,recovering_full_value_for_memoized_function(MemoID)),
386 findall((X,Y),stored_memo_result_id(MemoID,_,X,Y),List), % probably not sorted !
387 equal_object_optimized_wf(List,Result,expand_normal_closure_memo,WF).
388
389 % always succeeds to obtain the full expansion; also stores it for reuse
390 :- block get_complete_memoization_expansion(-,?,?,?,?,?).
391 get_complete_memoization_expansion(MemoID,Result,Done,_,_PP,WF) :-
392 try_get_complete_memoization_expansion(MemoID,Cached,WF),
393 !,
394 Result=Cached, Done=true.
395 get_complete_memoization_expansion(MemoID,Result,Done,Span,PP,WF) :-
396 registered_value(MemoID,Name,Val), nonvar(Val),
397 !,
398 get_complete_memoization_expansion_aux(Val,MemoID,Name,Result,Done,Span,PP,WF).
399 get_complete_memoization_expansion(MemoID,_,_,Span,PP,WF) :-
400 add_error_wf(get_complete_memoization_expansion,'Memoized function ID not registered:',MemoID:PP,Span,WF),
401 fail.
402
403
404 get_complete_memoization_expansion_aux(Val,_MemoID,_,Result,Done,_Span,_PP,_WF) :- expanded_value(Val), !,
405 Result=Val,Done=true.
406 get_complete_memoization_expansion_aux(closure(P,T,B),MemoID,Name,Result,Done,Span,PP,WF) :- !,
407 debug_println(19,expanding_memoized_function(MemoID,PP)),
408 (custom_explicit_sets:is_infinite_or_very_large_closure(P,T,B,200000)
409 -> add_warning_wf(PP,'Expanding infinite or very large memoized function: ',Name,B,WF)
410 ? ; is_symbolic_closure(P,T,B)
411 -> add_message_wf(PP,'Fully expanding symbolic memoized function: ',Name,B,WF)
412 ; true),
413 % bsyntaxtree:check_used_ids_in_ast(B),
414 custom_explicit_sets:expand_normal_closure_direct(P,T,B,Expansion,DoneExp,WF),
415 store_memoization_closure_expansion(MemoID,DoneExp,Expansion,Done,Result,Span,WF).
416 get_complete_memoization_expansion_aux(Val,MemoID,Name,_,_,Span,PP,WF) :-
417 add_error_wf(memoization(PP),'Illegal value stored for memoized function:',MemoID:Name,Span,WF),
418 print(Val),nl,
419 fail.
420
421 expanded_value(avl_set(_)).
422 expanded_value(global_set(_)).
423 expanded_value([]).
424 expanded_value([_|_]).
425
426 :- use_module(kernel_tools,[ground_value/1]).
427 :- use_module(kernel_objects,[check_element_of_wf/3]).
428 % special treatment for element of memoization closure; possibly not a function call
429 element_of_memoization_closure(MemoID,Element,WF,P,T,B) :-
430 nonvar(Element), Element = (X,Y),
431 % we can do a function application; we assume that we only store functions
432 ground_value_check(X,GrX),
433 !, %print(fun_apply_reuse(MemoID,Element)),nl,
434 Span=B,
435 % do_not_raise_wd: do not raise outside of domain errors
436 block_apply_closure_memo_groundx(GrX,MemoID, X,Y, P,T,B, do_not_raise_wd, Span,WF).
437 element_of_memoization_closure(MemoID,Element,WF,_,_,B) :-
438 % TO DO: delay before computing complete memoization
439 get_complete_memoization_expansion(MemoID,Set,_Done,B,element_of_memoization_closure,WF),
440 !, %print(el_of(MemoID,Element)),nl,
441 check_element_of_wf(Element,Set,WF).
442
443 :- use_module(kernel_objects,[not_equal_object_wf/3]).
444 :- use_module(kernel_objects,[not_element_of_wf/3]).
445
446 not_element_of_memoization_closure(MemoID,Element,WF,P,T,B) :-
447 nonvar(Element), Element = (X,Y),
448 % we can do a function application; we assume that we only store functions
449 ground_value_check(X,GrX),
450 !,
451 block_not_apply_closure_memo_groundx(GrX,MemoID, X,Y, P,T,B, do_not_raise_wd, B,WF).
452 not_element_of_memoization_closure(MemoID,Element,WF,_,_,B) :-
453 % TO DO: delay before computing complete memoization
454 get_complete_memoization_expansion(MemoID,Set,_Done,B,not_element_of_memoization_closure,WF),
455 !,
456 not_element_of_wf(Element,Set,WF).
457
458
459 :- block block_not_apply_closure_memo_groundx(-,?, ?,?, ?,?,?, ?,?,?).
460
461 block_not_apply_closure_memo_groundx(GrX,MemoID, X,Y, P,T,B, RaiseWD, Span,WF) :-
462 if(block_apply_closure_memo_groundx(GrX,MemoID, X,YRes, P,T,B, RaiseWD, Span,WF),
463 not_equal_object_wf(Y,YRes,wf),
464 true).
465
466 % -------------------------------
467
468 :- dynamic function_application_time/2.
469 :- use_module(preferences,[preference/2,get_preference/2]).
470 :- load_files(library(system), [when(compile_time), imports([environ/2])]).
471 :- if(\+ environ(prob_profile,false)).
472 %:- print('Profiling Memoizations'),nl.
473 count_reuse(MemoID) :-
474 my_bb_get_reuse_counter(MemoID,Cnt), C1 is Cnt+1, bb_put(MemoID,C1),
475 inc_counter(memoization_function_reuse_counter,_).
476 my_bb_get_reuse_counter(Key,Val) :- (bb_get(Key,V) -> V=Val ; Val=0).
477 bb_reset_reuse_counter(Key) :- bb_put(Key,0).
478 start_profile_function_application(_,Walltime) :- preference(prob_profiling_on,false),!, Walltime=0.
479 start_profile_function_application(_,Walltime) :- statistics(walltime,[Walltime,_]).
480 :- use_module(probsrc(performance_messages),[perf_format_wf/3]).
481 stop_profile_function_application(_,_,_,_) :- preference(prob_profiling_on,false),!.
482 stop_profile_function_application(MemoID,X,Walltime1,WF) :- statistics(walltime,[Walltime2,_]),
483 Delta is Walltime2-Walltime1,
484 (Delta>0 ->
485 (Delta > 1000
486 -> perf_format_wf('Long /* @memo ~w */ function application : ~w ms : arg: ~w~n',[MemoID,Delta,X],WF) ; true),
487 (retract(function_application_time(MemoID,Old))
488 -> New is Old+Delta ; New = Delta),
489 assertz(function_application_time(MemoID,New))
490 ; true
491 ).
492 function_application_time_available :- get_preference(prob_profiling_on,true).
493 :- else.
494 count_reuse(_MemoID) :-
495 inc_counter(memoization_function_reuse_counter,_).
496 my_bb_get_reuse_counter(_,'?').
497 bb_reset_reuse_counter(_).
498 start_profile_function_application(_,0).
499 stop_profile_function_application(_,_,_,_).
500 function_application_time_available :- fail.
501 :- endif.
502
503 % -------------------------------
504 % utilities to profile expansions
505 :- public inc/1.
506 :- dynamic hash_count/2.
507 inc(Hash) :- (retract(hash_count(Hash,Nr)) -> N1 is Nr+1 ; N1 = 1), assertz(hash_count(Hash,N1)).
508 :- dynamic hash_time/2.
509 store_memo_computation_time(Hash,Time) :- % for closure expansions, not for funct. applications
510 retractall(hash_time(Hash,_)), assertz(hash_time(Hash,Time)).
511
512 % reused and walltime info requires prob_profile flag
513 tcltk_get_memo_profile_table(list([Header|Entries])) :-
514 Header = list(['ID','Name','Fully','Stored Values','Reused','Walltime (ms)']),
515 findall(Entry,get_memo_entry_info(Entry),Entries).
516
517 get_memo_entry_info(list([MemoID,Name,Complete,NrStored,ReuseCnt,Walltime])) :-
518 registered_value(MemoID,Name,_FunValue),
519 (memoization_expansion_completed(MemoID) -> Complete='true' ; Complete = 'false'),
520 get_memo_profile_info(MemoID,NrStored,Walltime,ReuseCnt).
521
522 % get some profile info about a MemoID
523 get_memo_profile_info(MemoID,NrStored,Walltime,ReuseCnt) :-
524 my_bb_get_reuse_counter(MemoID,ReuseCnt),
525 findall(1,stored_memo_result_id(MemoID,_Hash,_,_),Stored), length(Stored,NrStored),
526 (\+ function_application_time_available -> Walltime='?'
527 ; function_application_time(MemoID,Walltime) -> true ; Walltime=0).
528
529
530 print_memo_profile :-
531 ((stored_memo_expansion(_,_,_) ; registered_value_packed(_,_,_))
532 -> print('MEMO Table:'),nl,
533 print_memo_table
534 ; true).
535
536 :- use_module(library(terms), [term_size/2]).
537 % memoization:print_memo.
538 print_memo_table :-
539 stored_memo_expansion(Hash,LookupTerm,PackedValue),
540 (hash_count(Hash,Count) -> print(Count), print(' : ') ; true),
541 (hash_time(Hash,Time) -> print(Time),print(' --> ') ; true),
542 print_memo_entry(LookupTerm),
543 nl, print(' : '),translate:print_bvalue(PackedValue),nl,fail.
544 print_memo_table :-
545 debug_mode(on),
546 registered_value(MemoID,Name,FunValue),
547 (memoization_expansion_completed(MemoID)
548 -> Compl=' (completely evaluated)' ; Compl=''),
549 format('MemoID ~w stored FUNCTION ~w~w ',[MemoID,Name,Compl]),
550 nl, print(' : '),translate:print_bvalue(FunValue),nl,fail.
551 print_memo_table :-
552 debug_mode(on),
553 registered_value_name(MemoID,Name),
554 stored_memo_result_id(MemoID,_Hash,LookupTerm,PackedValue),
555 term_size(LookupTerm,LSz),
556 format('MemoID ~w (~w) result for argument (size=~w) ',[MemoID,Name,LSz]),
557 print_memo_entry(LookupTerm),
558 term_size(PackedValue,PSz),
559 format('~n : (size=~w) ',[PSz]),translate:print_bvalue(PackedValue),nl,fail.
560 print_memo_table :-
561 stored_memo_result(Hash,MemoID1,T1,_),
562 stored_memo_result(Hash,MemoID2,T2,_),
563 dif((MemoID1,T1),(MemoID2,T2)),
564 format('Hash COLLISION ~w, ~w:~w vs ~w:~w~n',[Hash,MemoID1,T1,MemoID2,T2]),
565 fail.
566 print_memo_table :- format('Summary of reuse per memoization ID:~n',[]),
567 registered_value_name(MemoID,Name),
568 get_memo_profile_info(MemoID,NrStored,Walltime,ReuseCnt),
569 format('MemoID ~w (~w) : Values Stored: ~w (~w ms to compute), Reused ~w~n',[MemoID,Name,NrStored,Walltime,ReuseCnt]),
570 fail.
571 print_memo_table :- get_counter(memoization_hash_counter,Hash),
572 get_counter(memoization_reuse_counter,RHit),
573 format('Hashes computed: ~w, expansions reused: ~w~n',[Hash,RHit]),
574 get_counter(memoization_function_counter,F),
575 get_counter(memoization_function_reuse_counter,FR),
576 format('Memoization functions registered: ~w, results reused: ~w~n',[F,FR]).
577
578 print_memo_entry(closure(Parameters,ParameterTypes,ClosureBody)) :- !,
579 translate:print_bvalue(closure(Parameters,ParameterTypes,ClosureBody)).
580 print_memo_entry(closure1_for_explicit_set(A)) :- !,
581 print('closure1('),translate:print_bvalue(avl_set(A)), print(')').
582 print_memo_entry(A) :- translate:print_bvalue(A).
583
584 :- use_module(extension('counter/counter'),[counter_init/0, reset_counter/1,
585 new_counter/1, inc_counter/2,
586 get_counter/2]).
587 init_memo_table :-
588 counter_init,
589 new_counter(memoization_reuse_counter), new_counter(memoization_hash_counter),
590 new_counter(memoization_function_counter), new_counter(memoization_function_reuse_counter),
591 reset_memo_table.
592
593 reset_memo_table :-
594 ? retract(registered_value_packed(MemoID,_,_)),
595 bb_reset_reuse_counter(MemoID),
596 retract(registered_value_name(MemoID,_)),
597 fail.
598 reset_memo_table :-
599 reset_counter(memoization_reuse_counter),
600 reset_counter(memoization_hash_counter),
601 reset_counter(memoization_function_counter),
602 reset_counter(memoization_function_reuse_counter),
603 ? (stored_memo_expansion(_,_,_) -> debug_println(19,'Resetting MEMO table') ; true),
604 retractall(hash_count(_,_)),
605 retractall(hash_time(_,_)),
606 retractall(stored_memo_expansion(_,_,_)),
607 retractall(registered_value_packed(_,_,_)),
608 retractall(registered_value_name(_,_)),
609 retractall(function_application_time(_,_)),
610 retractall(memoization_expansion_completed(_)),
611 retractall(stored_lambda_value_domain(_,_,_)),
612 retractall_stored_memo_result,
613 reset_cogen.
614
615 :- use_module(probsrc(tools),[retract_with_statistics/2]).
616 reset_memo_with_statistics :-
617 retract_with_statistics(memoization,
618 [stored_memo_expansion(_,_,_),
619 registered_value_packed(_,_,_),registered_value_name(_,_,_),
620 memoization_expansion_completed(_),
621 stored_lambda_value_domain(_,_,_),
622 stored_memo_result1(_,_,_), stored_memo_result2(_,_,_),
623 stored_memo_result3(_,_,_), stored_memo_result4(_,_,_),
624 stored_memo_result5(_,_,_), stored_memo_result6(_,_,_),
625 stored_memo_result7(_,_,_), stored_memo_result8(_,_,_),
626 stored_memo_result(_,_,_,_)]),
627 reset_memo_table.
628