| 1 | % (c) 2009-2019 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 | :- module(delay,[delay_setof_wf/7, | |
| 6 | delay_setof_check_wf/9, | |
| 7 | delay_setof_list/4, | |
| 8 | delay_call/2, delay_call/3, | |
| 9 | delay_not/3, not_with_enum_warning/2, | |
| 10 | compute_wait_variables/3]). | |
| 11 | ||
| 12 | % meta_predicate annotations should appear before loading any code: | |
| 13 | :- meta_predicate my_findall(-,0,-,-). | |
| 14 | :- meta_predicate my_findall_catch(-,0,-,-,-). | |
| 15 | :- meta_predicate my_findall_catch(-,0,-,-,-,-). | |
| 16 | :- meta_predicate my_findall_check(-,0,-,-,0,0,-). | |
| 17 | ||
| 18 | :- meta_predicate delay_setof_wf(-,0,-,-,-,-,-). | |
| 19 | %:- meta_predicate block_my_findall_catch_wf(-,-,0,-,-,-). | |
| 20 | ||
| 21 | :- meta_predicate delay_setof_check_wf(-,0,-,-,-,0,0,-,-). | |
| 22 | :- meta_predicate block_findall_check(-,-,0,-,0,0,-,-,-,-). | |
| 23 | ||
| 24 | :- meta_predicate delay_setof_list(-,0,-,-). | |
| 25 | :- meta_predicate block_my_findall_sort(-,-,0,-). | |
| 26 | ||
| 27 | ||
| 28 | :- meta_predicate delay_call(0,-,-). | |
| 29 | :- meta_predicate delay_call(0,-). | |
| 30 | ||
| 31 | :- meta_predicate delay_not(0,-,-). | |
| 32 | :- meta_predicate not_with_enum_warning(0,-). | |
| 33 | :- meta_predicate not_with_enum_warning2(0,-,-). | |
| 34 | ||
| 35 | % -------------- | |
| 36 | ||
| 37 | ||
| 38 | :- use_module(tools). | |
| 39 | ||
| 40 | :- use_module(module_information,[module_info/2]). | |
| 41 | :- module_info(group,kernel). | |
| 42 | :- module_info(description,'Utilities to delay calls until sufficiently instantiated.'). | |
| 43 | ||
| 44 | %:- use_module(self_check). | |
| 45 | ||
| 46 | :- use_module(debug). /* so that calls can call unqualified debug_prints */ | |
| 47 | ||
| 48 | :- use_module(error_manager). | |
| 49 | :- use_module(kernel_tools). | |
| 50 | ||
| 51 | ||
| 52 | :- use_module(tools_printing,[print_term_summary/1]). | |
| 53 | :- load_files(library(system), [when(compile_time), imports([environ/2])]). | |
| 54 | ||
| 55 | :- if(debug:global_debug_flag). | |
| 56 | my_findall(X,P,L,_) :- | |
| 57 | statistics(runtime,[Start,_]), | |
| 58 | findall(X,P,L), | |
| 59 | statistics(runtime,[End,_]), | |
| 60 | Tot is End-Start, | |
| 61 | (Tot>50 -> nl, %nl,print(Call),nl, | |
| 62 | print('*** FINDALL: '),print_term_summary(P), | |
| 63 | print('*** exceeded limit: '), print(Tot), print(' ms'),nl, | |
| 64 | length(L,Len), | |
| 65 | print('*** SOLUTIONS: '), print(Len), nl | |
| 66 | ; true). | |
| 67 | :- elif(environ(prob_safe_mode,xtrue)). | |
| 68 | :- use_module(tools_meta,[call_residue/2]). | |
| 69 | :- meta_predicate call_residue_check(-). | |
| 70 | call_residue_check(Call) :- | |
| 71 | call_residue(Call,Residue), | |
| 72 | (Residue = [] -> true | |
| 73 | ; add_internal_error('Call had residue: ',residue(Residue)/call(Call))). | |
| 74 | my_findall(X,P,L,ExpectedFinalResult) :- | |
| 75 | (ExpectedFinalResult==[] | |
| 76 | -> \+(P),L=[] % we know the end result to be empty; not necessary to try and find all solutions; <--- we should probably treat this somewhere else to ensure that we do not throw all_solutions enumeration warnings | |
| 77 | ; findall(X,call_residue_check(P),L)). | |
| 78 | :- else. | |
| 79 | my_findall(X,P,L,ExpectedFinalResult) :- | |
| 80 | (ExpectedFinalResult==[] | |
| 81 | -> \+(P),L=[] % we know the end result to be empty; not necessary to try and find all solutions; <--- we should probably treat this somewhere else to ensure that we do not throw all_solutions enumeration warnings | |
| 82 | ; findall(X,P,L)). | |
| 83 | %; findall(X,(P,print(sol(X)),nl,nl,trace),L)). | |
| 84 | :- endif. | |
| 85 | ||
| 86 | ||
| 87 | ||
| 88 | ||
| 89 | my_findall_catch(X,P,L,ExpectedFinalResult,Span) :- | |
| 90 | my_findall_catch(X,P,L,ExpectedFinalResult,EnumWarningWhichOcc,Span), | |
| 91 | (enum_warning_occ(EnumWarningWhichOcc) -> throw(EnumWarningWhichOcc) ; true). | |
| 92 | ||
| 93 | enum_warning_occ(EnumWarningWhichOcc) :- | |
| 94 | nonvar(EnumWarningWhichOcc),EnumWarningWhichOcc=enumeration_warning(_,_,_,_,_). | |
| 95 | ||
| 96 | my_findall_catch(X,P,L,ExpectedFinalResult,EnumWarningWhichOcc,Span) :- | |
| 97 | enter_new_error_scope(Level,my_findall_catch), | |
| 98 | throw_enumeration_warnings_in_scope(Level,critical,Span), % critical enumeration warnings are thrown straight away | |
| 99 | call_cleanup( | |
| 100 | my_findall(X,P,L,ExpectedFinalResult), | |
| 101 | (event_occurred_in_error_scope(enumeration_warning(A,B,C,D,E)) | |
| 102 | -> exit_error_scope(Level,_,my_findall_catch_error), | |
| 103 | % do we need to throw the enumeration warning ? | |
| 104 | EnumWarningWhichOcc=enumeration_warning(A,B,C,D,E), | |
| 105 | debug_println(9,my_findall_catch(enumeration_warning(A,B,C,D,E))), %trace, | |
| 106 | true %throw(enumeration_warning(A,B,C,D,E)) | |
| 107 | ; exit_error_scope(Level,_,my_findall_catch_no_error), | |
| 108 | EnumWarningWhichOcc=false)). | |
| 109 | ||
| 110 | :- use_module(runtime_profiler,[observe_runtime/3]). | |
| 111 | my_findall_check(X,P,L,ExpectedFinalResult,TimeOutCode,VirtualTimeOutCode,Span) :- | |
| 112 | statistics(runtime,[Start,_]), | |
| 113 | get_total_number_of_errors(Nr1), % now also does count stored wd errors, see WD_SetCompr_Error | |
| 114 | %format('Start closure expansion at ~w ms~n',[Start]),print_message_span(Span),nl, | |
| 115 | call_cleanup((my_findall_catch(X,P,L,ExpectedFinalResult,EnumWarningWhichOcc,Span),Ok=true), | |
| 116 | (Ok==true,EnumWarningWhichOcc==false | |
| 117 | -> get_total_number_of_errors(Nr2), %print(f(Nr1,Nr2)),nl, | |
| 118 | (Nr2>Nr1 -> add_error(well_definedness_error,'Error(s) occurred during expansion of set comprehension','',Span), | |
| 119 | fail % TO DO: see comment below in delay_setof_wf | |
| 120 | ; observe_runtime(Start,'Long closure expansion: ',Span) %, print(done),nl | |
| 121 | %,statistics(runtime,[End,_]), Tot is End-Start, | |
| 122 | %(Tot>10 -> length(L,Len),add_message(delay,'Long closure expansion:',ms_sols(Tot,Len),Span) ; true) | |
| 123 | ) | |
| 124 | ; /* failure or time-out; --> time-out as findall should never fail */ | |
| 125 | statistics(runtime,[End,_]), Tot is End-Start, | |
| 126 | (enum_warning_occ(EnumWarningWhichOcc) | |
| 127 | -> (VirtualTimeOutCode = _:true -> true | |
| 128 | ; print('### VIRTUAL TIME-OUT after: '), print(Tot), print(' ms'),nl, | |
| 129 | call(VirtualTimeOutCode) | |
| 130 | ), %print(throw(EnumWarningWhichOcc)),nl, | |
| 131 | throw(EnumWarningWhichOcc) % ??? this is a set-comprehension expression; failure would mean not-well-defined | |
| 132 | ; Tot>1000 -> % TO DO: could also be CTRL-C ! we could use catch_interrupt_assertion_call(my_findall_catch) or on_exception(user_interrupt_signal,my_finall_catch() | |
| 133 | call(TimeOutCode), % Warning: this call is also called if an outer-time-out is triggered ! | |
| 134 | print('Runtime until TIME-OUT: '),print(Tot),nl | |
| 135 | % WHY DON'T WE FAIL HERE ---> because exception is passed on to outer calls after call_cleanup | |
| 136 | ; true) % check if the findall is probably responsible for the time-out | |
| 137 | )). | |
| 138 | ||
| 139 | /* ----------------------------------------- */ | |
| 140 | ||
| 141 | /* Below is a findall that delays until all | |
| 142 | non-output variables have become ground. | |
| 143 | Ideally, one would want a delay_findall that | |
| 144 | figures out by itself when it has all the answers | |
| 145 | (by looking at call_residue) and that may | |
| 146 | even progressively instantiate the output list | |
| 147 | such as in: | |
| 148 | delay_findall(X,delay_member(X,[a|T]),R), delay_member(Z,R) | |
| 149 | But this will require more involved machinery. | |
| 150 | */ | |
| 151 | ||
| 152 | ||
| 153 | :- use_module(tools,[remove_variables/3]). | |
| 154 | :- use_module(kernel_objects,[equal_object_wf/4]). | |
| 155 | :- if(current_prolog_flag(dialect,sicstus)). | |
| 156 | :- if((current_prolog_flag(version_data,sicstus(4,X,_,_,_)),X<3)). | |
| 157 | :- use_module(library(terms),[term_variables/2]). % is built-in in SICSTUS 4.3 | |
| 158 | :- endif. | |
| 159 | :- endif. | |
| 160 | ||
| 161 | ||
| 162 | :- use_module(kernel_tools,[ground_value_check/2]). | |
| 163 | ||
| 164 | % the following is called by expand_normal_closure_direct | |
| 165 | delay_setof_wf(V,G,FullSetResult,WVars,Done,WF,Span) :- %print(delay_set_of(V)),nl, | |
| 166 | ground_value_check(WVars,GW), | |
| 167 | block_my_findall_catch_wf2(GW,V,G,FullSetResult,Done,WF,Span). | |
| 168 | % comment in to perform idling to allow outer co-routines to run; useful when WD condition attached to Body G | |
| 169 | %:- use_module(kernel_waitflags,[get_idle_wait_flag/3]). | |
| 170 | %:- block block_my_findall_catch_wf(-,?,?,?,?,?). | |
| 171 | %block_my_findall_catch_wf(_,V,G,FullSetResult,Done,WF) :- | |
| 172 | % get_idle_wait_flag(delay_setof_wf,WF,LWF), | |
| 173 | % print(idling(WF,LWF)),nl,trace, | |
| 174 | % block_my_findall_catch_wf2(LWF,V,G,FullSetResult,Done,WF,Span). | |
| 175 | :- block block_my_findall_catch_wf2(-,?,?,?,?,?,?). | |
| 176 | block_my_findall_catch_wf2(_,V,G,FullSetResult,Done,WF,Span) :- | |
| 177 | ? | get_total_number_of_errors(Nr1), |
| 178 | ? | my_findall_catch(V,G,RRes,FullSetResult,Span), |
| 179 | ? | transform_result_into_set(RRes,SetRes), |
| 180 | ? | get_total_number_of_errors(Nr2), %print(f(Nr1,Nr2)),nl, |
| 181 | ? | (Nr2>Nr1 |
| 182 | -> add_error(well_definedness_error,'Error(s) occurred during expansion of set comprehension','',Span), | |
| 183 | fail | |
| 184 | % TO DO?: we could add_abort error here instead of adding a real error | |
| 185 | % for this, however, the inner abort_errors should only be recorded, not yet raised for the user | |
| 186 | ; true), | |
| 187 | ? | equal_object_wf(SetRes,FullSetResult,delay_setof_wf,WF), |
| 188 | Done=true. | |
| 189 | ||
| 190 | ||
| 191 | delay_setof_check_wf(V,G,FullSetResult,WVars,Done,TimeOutCode,VirtualTimeOutCode,WF,Span) :- %print(delay_set_of(V)),nl, | |
| 192 | %% print(wait_vars(WVars,G)),nl, %% | |
| 193 | ground_value_check(WVars,GW), | |
| 194 | block_findall_check(GW,V,G,FullSetResult,TimeOutCode,VirtualTimeOutCode,Done,FullSetResult,WF,Span). | |
| 195 | ||
| 196 | :- block block_findall_check(-,?,?,?,?,?,?,?,?,?). | |
| 197 | block_findall_check(_,V,G,FullSetResult,TimeOutCode,VirtualTimeOutCode,Done,FullSetResult,WF,Span) :- | |
| 198 | ? | my_findall_check(V,G,RRes,FullSetResult,TimeOutCode,VirtualTimeOutCode,Span), |
| 199 | ? | transform_result_into_set(RRes,SetRes), |
| 200 | % will generate AVL tree | |
| 201 | % print(delay_setof_result(SetRes,FullSetResult)),nl, translate:print_bvalue(SetRes),nl, | |
| 202 | ? | equal_object_wf(SetRes,FullSetResult,delay_setof_check_wf,WF), |
| 203 | ? | Done=true. |
| 204 | ||
| 205 | :- use_module(tools_printing,[print_term_summary/1]). | |
| 206 | :- use_module(custom_explicit_sets,[convert_to_avl/2]). | |
| 207 | transform_result_into_set(RRes,SetRes) :- % print(transform_result_into_set(RRes,SetRes)), | |
| 208 | ? | (convert_to_avl(RRes,SetRes) % we are sure that RRes is ground !!?? |
| 209 | -> true | |
| 210 | ; print_term_summary(convert_to_avl_failed(RRes,SetRes)), | |
| 211 | convert_list_of_expressions_into_set(RRes,SetRes)). | |
| 212 | ||
| 213 | :- use_module(kernel_waitflags,[init_wait_flags/1,ground_wait_flags/1]). | |
| 214 | :- use_module(b_interpreter,[convert_list_of_expressions_into_set_wf/4]). | |
| 215 | convert_list_of_expressions_into_set(List,Set) :- | |
| 216 | init_wait_flags(WF), | |
| 217 | convert_list_of_expressions_into_set_wf(List,Set,set(any),WF), | |
| 218 | ground_wait_flags(WF). | |
| 219 | ||
| 220 | /* same as above but Result is a list of elements; */ | |
| 221 | /* the list should not be interpreted as a set, but each element is a value for a parameter */ | |
| 222 | /* There is a very small chance that the same value is represented twice in the list (e.g., once as closure once as explicit list) */ | |
| 223 | delay_setof_list(V,G,FullSetResult,OutputVars) :- | |
| 224 | term_variables(G,Vars), | |
| 225 | term_variables(OutputVars,RealOutputVars), | |
| 226 | remove_variables(Vars,RealOutputVars,WVars), | |
| 227 | ground_value_check(WVars,GW), | |
| 228 | block_my_findall_sort(GW,V,G,FullSetResult). | |
| 229 | ||
| 230 | :- block block_my_findall_sort(-,?,?,?). | |
| 231 | block_my_findall_sort(_,V,G,FullSetResult) :- | |
| 232 | %print_quoted(findall(V,G,RRes)),nl, | |
| 233 | ? | my_findall(V,G,RRes,FullSetResult), |
| 234 | %% print_message(delay_seotof_list_rres(RRes)), %% | |
| 235 | ? | ll_norm(RRes,NormRRes), |
| 236 | ? | sort(NormRRes,SNormRRes), % removes duplicates |
| 237 | ? | FullSetResult=SNormRRes. |
| 238 | ||
| 239 | ||
| 240 | % normalise a list of list of values; the inner lists are not sets but values for parameters | |
| 241 | ll_norm([],[]). | |
| 242 | ll_norm([El1|T1],[El2|T2]) :- l_check_norm_required(El1,El2,NormRequired), | |
| 243 | (var(NormRequired) -> T1=T2 % no normalisation required: simply copy rest of list | |
| 244 | % TO DO: we could also statically determine based on parameter types whether normalising is required | |
| 245 | ; ll_norm2(T1,T2)). | |
| 246 | ||
| 247 | :- use_module(store,[l_normalise_values/2]). | |
| 248 | ll_norm2([],[]). | |
| 249 | ll_norm2([El1|T1],[El2|T2]) :- l_normalise_values(El1,El2), ll_norm2(T1,T2). | |
| 250 | ||
| 251 | % normalise a value and return norm_required in last argument if it is needed | |
| 252 | l_check_norm_required([],[],_). | |
| 253 | l_check_norm_required([H|T],[NH|NT],NormRequired) :- | |
| 254 | check_norm_required(H,NH,NormRequired), | |
| 255 | l_check_norm_required(T,NT,NormRequired). | |
| 256 | ||
| 257 | check_norm_required(pred_true,R,_) :- !, R=pred_true. | |
| 258 | check_norm_required(pred_false,R,_) :- !, R=pred_false. | |
| 259 | check_norm_required(int(S),R,_) :- !, R=int(S). | |
| 260 | check_norm_required(fd(X,T),R,_) :- !, R=fd(X,T). | |
| 261 | check_norm_required(string(S),R,_) :- !, R=string(S). | |
| 262 | check_norm_required((A,B),(NA,NB),NormRequired) :- !, | |
| 263 | check_norm_required(A,NA,NormRequired), check_norm_required(B,NB,NormRequired). | |
| 264 | % to do: add record and freeval | |
| 265 | check_norm_required(V,NV,norm_required) :- store:normalise_value(V,NV). | |
| 266 | ||
| 267 | ||
| 268 | ||
| 269 | ||
| 270 | ||
| 271 | compute_wait_variables(WaitTerm,OutputVars,WaitVars) :- | |
| 272 | term_variables(WaitTerm,Vars), | |
| 273 | term_variables(OutputVars,RealOutputVars), | |
| 274 | remove_variables(Vars,RealOutputVars,WaitVars). | |
| 275 | ||
| 276 | delay_call(Call,WaitTerm,OutputVars) :- | |
| 277 | compute_wait_variables(WaitTerm,OutputVars,WaitVars), | |
| 278 | %print_message(delay(Call,WaitVars)), | |
| 279 | when(ground(WaitVars),Call). | |
| 280 | ||
| 281 | delay_call(Call,OutputVars) :- | |
| 282 | delay_call(Call,Call,OutputVars). | |
| 283 | ||
| 284 | % LocalWF: created by create_inner_wait_flags; enumeration finished waitflag should not be grounded here | |
| 285 | delay_not(Call,OutputVars, LocalWF) :- % print_message(informational,delay_not(Call,OutputVars,LocalWF)), | |
| 286 | delay_call( not_with_enum_warning(Call, LocalWF) , OutputVars). | |
| 287 | ||
| 288 | not_with_enum_warning(Call, LocalWF) :- | |
| 289 | %% print_term_summary(neg_call(Call, LocalWF)), %% | |
| 290 | enter_new_clean_error_scope(Level), | |
| 291 | call_cleanup(not_with_enum_warning2(Call,Level,LocalWF), | |
| 292 | exit_error_scope(Level,_ErrOccured,not_with_enum_warn)). | |
| 293 | ||
| 294 | :- use_module(kernel_waitflags,[pending_abort_error/1, ground_wait_flags/1]). | |
| 295 | not_with_enum_warning2(Call,Level,LocalWF) :- | |
| 296 | ? | (Call -> %% print(clearing_warnings(Level)),nl, %% |
| 297 | (pending_abort_error(LocalWF) | |
| 298 | -> debug_println(19,pending_abort_error(LocalWF)), | |
| 299 | PENDING_ABORT = true | |
| 300 | % we do not fail in this case, so that abort errors can be raised | |
| 301 | % relevant for test 1966 or predicate f={1|->2} & not(#s.(s:1..2 & f(s)=3)) with -p TRY_FIND_ABORT TRUE | |
| 302 | ; clear_events_in_error_scope(Level,enumeration_warning(_,_,_,_,_)), fail | |
| 303 | % call has succeeded without pending abort errors | |
| 304 | ) | |
| 305 | ; otherwise -> true | |
| 306 | ), | |
| 307 | % Note: everything else is ground; so Call should not trigger any other co-routines/enumeration ?! | |
| 308 | Event = enumeration_warning(_,_,_,_,_), | |
| 309 | (event_occurred_in_error_scope(Event) % critical ? only at this level ? or also below ? | |
| 310 | -> PENDING_ABORT==true, %print(grd(LocalWF)),nl, kernel_waitflags:portray_waitflags(LocalWF),nl, | |
| 311 | ground_wait_flags(LocalWF), % raise any potential abort errors | |
| 312 | debug_println(19,grounded_wait_flag_for_pending_abort_error), % THIS print is important due to issue SPRM-20473 in SICStus Prolog which will otherwise *not* activate the pending co-routines attached to LocalWF ! | |
| 313 | fail | |
| 314 | %, print_message(throwing(Event)), throw(Event) % or simply re-post enum warning ? | |
| 315 | % we could also simply fail and raise an enumeration warning; meaning we havent explored all possibilities | |
| 316 | % Note: at the moment the error is copied into the outer scope by copy_error_scope_events | |
| 317 | ; true) | |
| 318 | %% ,print_term_summary(done_neg_call(Call)),nl %% | |
| 319 | . | |
| 320 | ||
| 321 | ||
| 322 |