From 52a46e5c5d171f8a3e090475b5201108c7e5f73f Mon Sep 17 00:00:00 2001 From: vsc Date: Tue, 8 Feb 2005 04:05:39 +0000 Subject: [PATCH] fix mess with add clause improves on sigsegv handling git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1239 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/cdmgr.c | 18 ++++-- C/errors.c | 6 +- C/exec.c | 1 + C/stdpreds.c | 25 +++++++- C/sysbits.c | 132 ++++++++++++++++++++++++++++++++++++++- CLPBN/clpbn/evidence.yap | 35 +++++------ CLPBN/clpbn/vel.yap | 24 +++---- pl/boot.yap | 70 +++++++++------------ pl/consult.yap | 2 + pl/corout.yap | 4 ++ pl/debug.yap | 46 ++++++++------ pl/directives.yap | 20 ++++-- pl/init.yap | 10 ++- pl/modules.yap | 2 + pl/preds.yap | 2 +- pl/signals.yap | 13 +++- 16 files changed, 299 insertions(+), 111 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index f51187653..5c2001d05 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -11,8 +11,12 @@ * File: cdmgr.c * * comments: Code manager * * * -* Last rev: $Date: 2005-01-28 23:14:34 $,$Author: vsc $ * +* Last rev: $Date: 2005-02-08 04:05:23 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.150 2005/01/28 23:14:34 vsc +* move to Yap-4.5.7 +* Fix clause size +* * Revision 1.149 2005/01/05 05:35:01 vsc * get rid of debugging stub. * @@ -2058,12 +2062,16 @@ p_compile_dynamic(void) Term t1 = Deref(ARG2); Term mod = Deref(ARG4); yamop *code_adr; - int old_optimize; + int old_optimize, mode; - if (IsVarTerm(t1) || !IsAtomTerm(t1)) + if (IsVarTerm(t1) || !IsAtomicTerm(t1)) return FALSE; if (IsVarTerm(mod) || !IsAtomTerm(mod)) return FALSE; + if (IsAtomTerm(t1)) { + if (RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f') mode = asserta; + else mode = assertz; + } else mode = IntegerOfTerm(t1); old_optimize = optimizer_on; optimizer_on = FALSE; YAPEnterCriticalSection(); @@ -2074,7 +2082,7 @@ p_compile_dynamic(void) optimizer_on = old_optimize; - addclause(t, code_adr, RepAtom(AtomOfTerm(t1))->StrOfAE[0] == 'f', mod, &ARG5); + addclause(t, code_adr, mode , mod, &ARG5); } if (Yap_ErrorMessage) { if (!Yap_Error_Term) @@ -2425,7 +2433,7 @@ p_new_multifile(void) if (IsIntTerm(t)) arity = IntOfTerm(t); else - return (FALSE); + return FALSE; if (arity == 0) pe = RepPredProp(PredPropByAtom(at, mod)); else diff --git a/C/errors.c b/C/errors.c index a16581c85..43fc08495 100644 --- a/C/errors.c +++ b/C/errors.c @@ -299,8 +299,12 @@ dump_stack(void) static void error_exit_yap (int value) { - if (!Yap_PrologMode & BootMode) + if (!Yap_PrologMode & BootMode) { +#if DEBUG + fprintf(stderr,"%d garbage collections\n", GcCalls); +#endif dump_stack(); + } Yap_exit(value); } diff --git a/C/exec.c b/C/exec.c index 54bd2044e..5ddb13b0b 100644 --- a/C/exec.c +++ b/C/exec.c @@ -230,6 +230,7 @@ EnterCreepMode(Term t, Term mod) { LOCK(SignalLock); CreepFlag = CalculateStackGap(); UNLOCK(SignalLock); + yap_flags[SPY_CREEP_FLAG] = TRUE; P_before_spy = P; return (CallPredicate(PredCreep, B, PredCreep->CodeOfPred)); } diff --git a/C/stdpreds.c b/C/stdpreds.c index e652b10b0..72718a4ed 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -11,8 +11,11 @@ * File: stdpreds.c * * comments: General-purpose C implemented system predicates * * * -* Last rev: $Date: 2005-01-05 05:32:37 $,$Author: vsc $ * +* Last rev: $Date: 2005-02-08 04:05:35 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.80 2005/01/05 05:32:37 vsc +* Ricardo's latest version of profiler. +* * Revision 1.79 2004/12/28 22:20:36 vsc * some extra bug fixes for trail overflows: some cannot be recovered that easily, * some can. @@ -655,6 +658,23 @@ p_creep(void) return TRUE; } +static Int +p_delayed_creep(void) +{ + Atom at; + PredEntry *pred; + + at = Yap_FullLookupAtom("$creep"); + pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0)); + CreepCode = pred; + yap_flags[SPY_CREEP_FLAG] = FALSE; + do_signal(YAP_CREEP_SIGNAL); + LOCK(SignalLock); + CreepFlag = CalculateStackGap(); + UNLOCK(SignalLock); + return TRUE; +} + static Int p_stop_creep(void) { @@ -2959,7 +2979,8 @@ Yap_InitCPreds(void) /* they are defined in analyst.c */ /* Basic predicates for the debugger */ Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred("$stop_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred("$late_creep", 0, p_delayed_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred("$do_not_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); #ifdef DEBUG Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag|HiddenPredFlag); #endif diff --git a/C/sysbits.c b/C/sysbits.c index d8343dc16..bcb722888 100644 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -879,7 +879,8 @@ HandleSIGSEGV(int sig, siginfo_t *sip, ucontext_t *uap) { #if !USE_SYSTEM_MALLOC - if (sip->si_code != SI_NOINFO && + if ( + sip->si_code != SI_NOINFO && sip->si_code == SEGV_MAPERR && (void *)(sip->si_addr) > (void *)(Yap_HeapBase) && (void *)(sip->si_addr) < (void *)(Yap_TrailTop+64 * 1024L)) { @@ -950,6 +951,135 @@ my_signal(int sig, void (*handler)(int, siginfo_t *, ucontext_t *)) sigaction(sig,&sigact,NULL); } +#elif defined(__linux__) + +STATIC_PROTO (RETSIGTYPE HandleMatherr, (int)); +STATIC_PROTO (RETSIGTYPE HandleSIGSEGV, (int,siginfo_t *,void *)); +STATIC_PROTO (void my_signal_info, (int, void (*)(int,siginfo_t *,void *))); +STATIC_PROTO (void my_signal, (int, void (*)(int))); + +/******** Handling floating point errors *******************/ + + +/* old code, used to work with matherror(), deprecated now: + char err_msg[256]; + switch (x->type) + { + case DOMAIN: + case SING: + Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s", x->name); + return(0); + case OVERFLOW: + Yap_Error(EVALUATION_ERROR_FLOAT_OVERFLOW, TermNil, "%s", x->name); + return(0); + case UNDERFLOW: + Yap_Error(EVALUATION_ERROR_FLOAT_UNDERFLOW, TermNil, "%s", x->name); + return(0); + case PLOSS: + case TLOSS: + Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, "%s(%g) = %g", x->name, + x->arg1, x->retval); + return(0); + default: + Yap_Error(EVALUATION_ERROR_UNDEFINED, TermNil, NULL); + return(0); + } + */ + + +#if HAVE_FENV_H +#include +#endif + +static RETSIGTYPE +HandleMatherr(int sig) +{ +#if HAVE_FETESTEXCEPT + + /* This should work in Linux, but it doesn't seem to. */ + + int raised = fetestexcept(FE_ALL_EXCEPT); + + if (raised & FE_OVERFLOW) { + Yap_matherror = EVALUATION_ERROR_FLOAT_OVERFLOW; + } else if (raised & (FE_INVALID|FE_INEXACT)) { + Yap_matherror = EVALUATION_ERROR_UNDEFINED; + } else if (raised & FE_DIVBYZERO) { + Yap_matherror = EVALUATION_ERROR_ZERO_DIVISOR; + } else if (raised & FE_UNDERFLOW) { + Yap_matherror = EVALUATION_ERROR_FLOAT_UNDERFLOW; + } else +#endif + Yap_matherror = EVALUATION_ERROR_UNDEFINED; + /* something very bad happened on the way to the forum */ + set_fpu_exceptions(FALSE); + Yap_Error(Yap_matherror, TermNil, ""); +} + +static void +SearchForTrailFault(siginfo_t *siginfo) +{ + void *ptr = siginfo->si_addr; + + fprintf(stderr,"error at %p\n",ptr); + /* If the TRAIL is very close to the top of mmaped allocked space, + then we can try increasing the TR space and restarting the + instruction. In the worst case, the system will + crash again + */ +#if OS_HANDLES_TR_OVERFLOW && !USE_SYSTEM_MALLOC + if ((ptr > (void *)Yap_TrailTop-1024 && + TR < (void *)Yap_TrailTop+(64*1024))) { + if (!Yap_growtrail(64*1024, TRUE)) { + Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, "YAP failed to reserve %ld bytes in growtrail", 64*1024L); + } + /* just in case, make sure the OS keeps the signal handler. */ + /* my_signal_info(SIGSEGV, HandleSIGSEGV); */ + } else +#endif /* OS_HANDLES_TR_OVERFLOW */ + { + Yap_Error(FATAL_ERROR, TermNil, + "likely bug in YAP, segmentation violation at %p", ptr); + } +} + +static RETSIGTYPE +HandleSIGSEGV(int sig, siginfo_t *siginfo, void *context) +{ + if (Yap_PrologMode & ExtendStackMode) { + Yap_Error(FATAL_ERROR, TermNil, "OS memory allocation crashed at address %p, bailing out\n",Yap_TrailTop); + } + SearchForTrailFault(siginfo); +} + +static void +my_signal_info(int sig, void (*handler)(int,siginfo_t *,void *)) +{ + struct sigaction sigact; + + sigact.sa_sigaction = handler; + sigemptyset(&sigact.sa_mask); +#if HAVE_SIGINFO + sigact.sa_flags = SA_SIGINFO; +#else + sigact.sa_flags = 0; +#endif + + sigaction(sig,&sigact,NULL); +} + +static void +my_signal(int sig, void (*handler)(int)) +{ + struct sigaction sigact; + + sigact.sa_handler=handler; + sigemptyset(&sigact.sa_mask); + sigact.sa_flags = 0; + + sigaction(sig,&sigact,NULL); +} + #else /* if not (defined(__svr4__) || defined(__SVR4)) */ STATIC_PROTO (RETSIGTYPE HandleMatherr, (int)); diff --git a/CLPBN/clpbn/evidence.yap b/CLPBN/clpbn/evidence.yap index 93b361882..ef9435b05 100644 --- a/CLPBN/clpbn/evidence.yap +++ b/CLPBN/clpbn/evidence.yap @@ -3,6 +3,8 @@ % % + + :- module(evidence, [ store_evidence/1, incorporate_evidence/2 @@ -22,7 +24,7 @@ :- meta_predicate store_evidence(:). -:- dynamic node/4, reachable_from_evidence/2, evidence/2. +:- dynamic node/4, edge/2, evidence/2. % % new evidence storage algorithm. The idea is that instead of @@ -39,8 +41,7 @@ store_evidence(G) :- compute_evidence(G, PreviousSolver) :- catch(call_residue(G, Vars), Ball, evidence_error(Ball,PreviousSolver)), !, - store_graph(Vars,KEv), - mark_from_evidence(Vars,KEv), + store_graph(Vars), set_clpbn_flag(solver,PreviousSolver). compute_evidence(_, PreviousSolver) :- set_clpbn_flag(solver,PreviousSolver). @@ -50,22 +51,21 @@ evidence_error(Ball,PreviousSolver) :- set_clpbn_flag(solver,PreviousSolver), throw(Ball). -store_graph([], _). -store_graph([_-node(K,Dom,CPT,TVs,Ev)|Vars], Kev) :- +store_graph([]). +store_graph([_-node(K,Dom,CPT,TVs,Ev)|Vars]) :- \+ node(K,_,_,_), !, assert(node(K,Dom,CPT,TVs)), - ( nonvar(Ev) -> assert(evidence(K,Ev)), Kev = K ; true), - store_graph(Vars, Kev). -store_graph([_|Vars], Kev) :- - store_graph(Vars, Kev). + ( nonvar(Ev) -> assert(evidence(K,Ev)) ; true), + add_links(TVs,K), + store_graph(Vars). +store_graph([_|Vars]) :- + store_graph(Vars). + +add_links([],_). +add_links([K0|TVs],K) :- + assert(edge(K,K0)), + add_links(TVs,K). -mark_from_evidence([], _). -mark_from_evidence([_-node(K,_,_,_,_)|Vars], Kev) :- - \+ reachable_from_evidence(K,Kev), !, - assert(reachable_from_evidence(K,Kev)), - mark_from_evidence(Vars, Kev). -mark_from_evidence([_|Vars], Kev) :- - mark_from_evidence(Vars, Kev). incorporate_evidence(Vs,AllVs) :- new(Cache0), @@ -116,6 +116,5 @@ add_evidence(_, _). check_for_evidence(_, V, Vf, Vf, C, C) :- clpbn:get_atts(V, [evidence(_)]), !. check_for_evidence(K, _, Vf0, Vff, C0, Ci) :- - findall(Rt,reachable_from_evidence(K,Rt),Rts), + findall(Rt,edge(Rt,K),Rts), add_variables(Rts, _, Vf0, Vff, C0, Ci). - diff --git a/CLPBN/clpbn/vel.yap b/CLPBN/clpbn/vel.yap index 0a8158405..ea02a73f8 100644 --- a/CLPBN/clpbn/vel.yap +++ b/CLPBN/clpbn/vel.yap @@ -68,11 +68,11 @@ get_rid_of_ev_vars([V|LVs0],[V|LVs]) :- find_all_clpbn_vars([], [], [], []) :- !. -find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Deps,Sizes)|Tables]) :- - var_with_deps(V, Table, Deps, Sizes, Ev, Vals), !, +find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Sizes)|Tables]) :- + var_with_deps(V, Table, Parents, Sizes, Ev, Vals), !, % variables with evidence should not be processed. (var(Ev) -> - Var = var(V,I,Sz,Vals,Ev,_,_), + Var = var(V,I,Sz,Vals,Parents,Ev,_,_), get_dist_size(V,Sz), ProcessedVars = [Var|ProcessedVars0] ; @@ -81,9 +81,9 @@ find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Deps,Sizes)| find_all_clpbn_vars(Vs, LV, ProcessedVars0, Tables). var_with_deps(V, Table, Deps, Sizes, Ev, Vals) :- - clpbn:get_atts(V, [dist(Vals,OTable,VDeps)]), + clpbn:get_atts(V, [dist(Vals,OTable,Parents)]), ( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true), - reorder_table([V|VDeps],Sizes0,OTable,Deps0,Table0), + reorder_table([V|Parents],Sizes0,OTable,Deps0,Table0), simplify_evidence(Deps0, Table0, Deps0, Sizes0, Table, Deps, Sizes). get_sizes([], []). @@ -146,7 +146,7 @@ add_table_deps([V|Deps], I, Deps0, Table, Sizes, DepGraph0, [V-tab(Table,Deps0,S add_table_deps(Deps, I, Deps0, Table, Sizes, DepGraph0, DepGraph). add_table_deps_to_variables([], []). -add_table_deps_to_variables([var(V,_,_,_,_,Deps,K)|LV], DepGraph) :- +add_table_deps_to_variables([var(V,_,_,_,_,_,Deps,K)|LV], DepGraph) :- steal_deps_for_variable(DepGraph, V, NDepGraph, Deps), compute_size(Deps,[],K), % ( clpbn:get_atts(V,[key(Key)]) -> write(Key:K), nl ; true), @@ -186,14 +186,16 @@ process(LV0, _, Out) :- find_best([], V, _TF, V, _, [], _). %:- % clpbn:get_atts(V,[key(K)]), write(chosen:K:TF), nl. -find_best([var(V,I,Sz,Vals,Ev,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :- +% root_with_single_child +%find_best([var(V,I,_,_,[],Ev,[Dep],K)|LV], _, _, V, [Dep], LVF, Inputs) :- !. +find_best([var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV], _, Threshold, VF, NWorktables, LVF, Inputs) :- ( K < Threshold ; Threshold < 0), clpbn_not_var_member(Inputs, V), !, find_best(LV, V, K, VF, WorkTables,LV0, Inputs), (V == VF -> LVF = LV0, Deps = NWorktables ; - LVF = [var(V,I,Sz,Vals,Ev,Deps,K)|LV0], WorkTables = NWorktables + LVF = [var(V,I,Sz,Vals,Parents,Ev,Deps,K)|LV0], WorkTables = NWorktables ). find_best([V|LV], V0, Threshold, VF, WorkTables, [V|LVF], Inputs) :- find_best(LV, V0, Threshold, VF, WorkTables, LVF, Inputs). @@ -227,7 +229,7 @@ generate_szs_with_evidence([_|Out],Ev,[not_ok|Evs]) :- fetch_tables([], []). -fetch_tables([var(_,_,_,_,_,Deps,_)|LV0], Tables) :- +fetch_tables([var(_,_,_,_,_,_,Deps,_)|LV0], Tables) :- append(Deps,Tables0,Tables), fetch_tables(LV0, Tables0). @@ -326,10 +328,10 @@ project_inner_loop(I,Sz,[_|Evs],NBase,F,Table,Ent0,Ent) :- !, include([],_,_,[]). -include([var(V,P,VSz,D,Ev,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Ev,Tabs,Est)|NLV]) :- +include([var(V,P,VSz,D,Parents,Ev,Tabs,Est)|LV],tab(T,Vs,Sz),V1,[var(V,P,VSz,D,Parents,Ev,Tabs,Est)|NLV]) :- clpbn_not_var_member(Vs,V), !, include(LV,tab(T,Vs,Sz),V1,NLV). -include([var(V,P,VSz,D,Ev,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,Ev,NTabs,NEst)|NLV]) :- +include([var(V,P,VSz,D,Parents,Ev,Tabs,_)|LV],Table,NV,[var(V,P,VSz,D,Parents,Ev,NTabs,NEst)|NLV]) :- update_tables(Tabs,NTabs,Table,NV), compute_size(NTabs, [], NEst), % ( clpbn:get_atts(V,[key(Key)]) -> write(Key:NEst), nl ; true), diff --git a/pl/boot.yap b/pl/boot.yap index 665e7186c..758f32ac8 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -122,7 +122,7 @@ true :- true. format(user_error, '% trace~n', []) ; recorded('$debug', on, _) -> - format(user_error, '% debug~n', []) + format(user_error, '% debug~n', []) ), fail. '$enter_top_level' :- @@ -260,25 +260,18 @@ repeat :- '$repeat'. '$process_directive'(G, top, _) :- !, '$do_error'(context_error((:- G),clause),query). % -% always allow directives. -% -'$process_directive'(D, Mode, M) :- - '$directive'(D), !, - ( '$exec_directive'(D, Mode, M) -> true ; true ). -% -% allow multiple directives -% -'$process_directive'((G1,G2), Mode, M) :- - '$all_directives'(G1), - '$all_directives'(G2), !, - '$exec_directives'(G1, Mode, M), - '$exec_directives'(G2, Mode, M). -% % allow modules % '$process_directive'(M:G, Mode, _) :- !, '$process_directive'(G, Mode, M). % +% default case +% +'$process_directive'(Gs, Mode, M) :- + '$all_directives'(Gs), !, + '$exec_directives'(Gs, Mode, M). + +% % ISO does not allow goals (use initialization). % '$process_directive'(D, _, M) :- @@ -288,15 +281,8 @@ repeat :- '$repeat'. % but YAP and SICStus does. % '$process_directive'(G, _, M) :- - ( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ). - -'$all_directives'(_:G1) :- !, - '$all_directives'(G1). -'$all_directives'((G1,G2)) :- !, - '$all_directives'(G1), - '$all_directives'(G2). -'$all_directives'(G) :- !, - '$directive'(G). + ( '$do_yes_no'(G,M) -> true ; format(user_error,':- ~w:~w failed.~n',[M,G]) ), + '$do_not_creep'. '$continue_with_command'(reconsult,V,G,Source) :- '$go_compile_clause'(G,V,5,Source), @@ -305,7 +291,8 @@ repeat :- '$repeat'. '$go_compile_clause'(G,V,13,Source), fail. '$continue_with_command'(top,V,G,_) :- - '$query'(G,V). + '$query'(G,V), + '$do_not_creep'. % % not 100% compatible with SICStus Prolog, as SICStus Prolog would put @@ -384,16 +371,16 @@ repeat :- '$repeat'. '$yes_no'(G,(?-)). '$query'(G,V) :- ( - ( recorded('$trace',on,_) -> '$creep' ; true), + ( recorded('$trace',on,_) -> '$creep' ; true), '$execute'(G), - '$do_stop_creep', + '$do_not_creep', '$extract_goal_vars_for_dump'(V,LIV), '$show_frozen'(G,LIV,LGs), '$write_answer'(V, LGs, Written), '$write_query_answer_true'(Written), '$another', !, fail ; - '$do_stop_creep', + '$do_not_creep', ( '$undefined'('$print_message'(_,_),prolog) -> '$present_answer'(user_error,"no~n", []) ; @@ -405,7 +392,7 @@ repeat :- '$repeat'. '$yes_no'(G,C) :- '$current_module'(M), '$do_yes_no'(G,M), - '$do_stop_creep', + '$do_not_creep', '$show_frozen'(G, [], LGs), '$write_answer'([], LGs, Written), ( Written = [] -> @@ -414,7 +401,7 @@ repeat :- '$repeat'. ), fail. '$yes_no'(_,_) :- - '$do_stop_creep', + '$do_not_creep', ( '$undefined'('$print_message'(_,_),prolog) -> '$present_answer'(user_error,"no~n", []) ; @@ -422,15 +409,11 @@ repeat :- '$repeat'. ), fail. -% make sure we have Prolog code to force running any delayed goals. -'$do_stop_creep' :- - '$stop_creep'. - - '$do_yes_no'([X|L], M) :- !, '$csult'([X|L], M). '$do_yes_no'(G, M) :- ( recorded('$trace',on,_) -> '$creep' ; true), '$execute'(M:G). + '$extract_goal_vars_for_dump'([],[]). '$extract_goal_vars_for_dump'([[_|V]|VL],[V|LIV]) :- '$extract_goal_vars_for_dump'(VL,LIV). @@ -845,8 +828,10 @@ break :- ; '$print_message'(informational, loading(consulting, File)) ), + ( recorded('$trace', on, TraceR) -> erase(TraceR) ; true), '$loop'(Stream,consult), '$end_consult', + ( nonvar(TraceR) -> recorda('$trace', on, _) ; true), set_value('$consulting',Old), set_value('$consulting_file',OldF), '$current_module'(NewMod,OldModule), @@ -955,7 +940,7 @@ break :- '$find_in_path'(user_input,user_input, _) :- !. '$find_in_path'(S,NewFile, _) :- S =.. [Name,File], !, - user:file_search_path(Name, Dir), + ( user:file_search_path(Name, Dir) -> '$do_not_creep' ; '$do_not_creep'), '$dir_separator'(D), atom_codes(A,[D]), atom_concat([Dir,A,File],NFile), @@ -990,11 +975,13 @@ break :- expand_term(Term,Expanded) :- ( \+ '$undefined'(term_expansion(_,_), user), - user:term_expansion(Term,Expanded) + user:term_expansion(Term,Expanded), + '$do_not_creep' ; + '$do_not_creep', '$expand_term_grammar'(Term,Expanded) ), - !. +!. % @@ -1090,15 +1077,14 @@ throw(Ball) :- G \= '$', '$current_module'(M), '$system_catch'(once(M:G), M, Error, user:'$LoopError'(Error, top)), + '$do_not_creep', fail. '$exec_initialisation_goals'. '$run_toplevel_hooks' :- get_value('$break',0), recorded('$toplevel_hooks',H,_), !, - ( '$execute'(H) -> true ; true). + ( '$execute'(H) -> true ; true), + '$do_not_creep'. '$run_toplevel_hooks'. - - - diff --git a/pl/consult.yap b/pl/consult.yap index 69f4c1cac..e8b92b8c0 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -126,8 +126,10 @@ reconsult(Fs) :- '$remove_multifile_clauses'(File), recorda('$initialisation','$',_), '$print_message'(informational, loading(reconsulting, File)), + ( recorded('$trace', on, TraceR) -> erase(TraceR) ; true), '$loop'(Stream,reconsult), '$end_consult', + ( nonvar(TraceR) -> recorda('$trace', on, _) ; true), '$clear_reconsulting', set_value('$consulting',Old), set_value('$consulting_file',OldF), diff --git a/pl/corout.yap b/pl/corout.yap index 1bdb1e402..9b6d5d6a9 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -617,9 +617,11 @@ call_residue(Goal,Residue) :- '$project_module'([Mod|LMods], LIV, LAV) :- \+ '$undefined'(project_attributes(LIV, LAV), Mod), '$execute'(Mod:project_attributes(LIV, LAV)), !, + '$do_not_creep', attributes:all_attvars(NLAV), '$project_module'(LMods,LIV,NLAV). '$project_module'([_|LMods], LIV, LAV) :- + '$do_not_creep', '$project_module'(LMods,LIV,LAV). @@ -634,11 +636,13 @@ call_residue(Goal,Residue) :- '$do_convert_att_vars'([V|LAV], LIV, NGs) :- var(V), attributes:convert_att_var(V,G), + '$do_not_creep', G \= true, !, '$split_goals_for_catv'(G,V,NGs,IGs), '$do_convert_att_vars'(LAV, LIV, IGs). '$do_convert_att_vars'([_|LAV], LIV, Gs) :- + '$do_not_creep', '$do_convert_att_vars'(LAV, LIV, Gs). '$split_goals_for_catv'((G,NG),V,[V-G|Gs],Gs0) :- !, diff --git a/pl/debug.yap b/pl/debug.yap index 8a6aba3b3..29786c502 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -23,7 +23,6 @@ :- op(900,fx,[spy,nospy]). -:- thread_local([idb:'$debug',idb:'$trace',idb:'$spy_skip',idb:'$spy_stop']). % First part : setting and reseting spy points @@ -271,10 +270,11 @@ debugging :- % last argument to do_spy says that we are at the end of a context. It % is required to know whether we are controlled by the debugger. '$do_spy'(_, _, _, _) :- - '$stop_debugging', fail. + '$do_not_creep', fail. '$do_spy'(!, _, CP, _) :- !, '$cut_by'(CP). '$do_spy'('$cut_by'(M), _, _, _) :- !, '$cut_by'(M). '$do_spy'(true, _, _, _) :- !. +%'$do_spy'(fail, _, _, _) :- !, fail. '$do_spy'(M:G, _, CP, InControl) :- !, '$do_spy'(G, M, CP, InControl). '$do_spy'((A,B), M, CP, InControl) :- !, @@ -285,14 +285,16 @@ debugging :- ; '$do_spy'(B, M, CP, InControl) ). -'$do_spy'((A;B), M, CP, InControl) :- !, - ( - '$do_spy'(A, M, CP, yes) +'$do_spy'((T->A|B), M, CP, InControl) :- !, + ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ; '$do_spy'(B, M, CP, InControl) ). -'$do_spy'((T->A|B), M, CP, InControl) :- !, - ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) +'$do_spy'((T->A), M, CP, InControl) :- !, + ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ). +'$do_spy'((A;B), M, CP, InControl) :- !, + ( + '$do_spy'(A, M, CP, yes) ; '$do_spy'(B, M, CP, InControl) ). @@ -321,7 +323,7 @@ debugging :- % handle weird things happening in the debugger. '$loop_spy_event'(_, _, _, _, _) :- - '$stop_debugging', fail. + '$do_not_creep', fail. '$loop_spy_event'('$retry_spy'(G0), GoalNumber, G, Module, InControl) :- G0 >= GoalNumber, !, '$loop_spy'(GoalNumber, G, Module, InControl). @@ -355,20 +357,21 @@ debugging :- '$spycall'(G, Module, InControl), /* go execute the predicate */ ( - '$stop_debugging', + '$do_not_creep', '$show_trace'(exit,G,Module,GoalNumber), /* output message at exit */ '$continue_debugging'(InControl) - ; /* exit */ + ; + /* exit */ /* we get here when we want to redo a goal */ - '$stop_debugging', + '$do_not_creep', '$show_trace'(redo,G,Module,GoalNumber), /* inform user_error */ - '$continue_debugging'(InControl), + '$continue_debugging'(InControl,G,Module), fail /* to backtrack to spycalls */ ) ; - '$stop_debugging', + '$do_not_creep', '$show_trace'(fail,G,Module,GoalNumber), /* inform at fail port */ - '$continue_debugging'(InControl), + '$continue_debugging'(InControl,G,Module), fail ). @@ -410,11 +413,11 @@ debugging :- % use the interpreter CP is '$last_choice_pt', '$clause'(G, M, Cl), - '$stop_debugging', + '$do_not_creep', '$do_spy'(Cl, M, CP, InControl). '$spycall'(G, M, InControl) :- % I lost control here. - '$continue_debugging'(InControl), + '$continue_debugging'(InControl,G,M), '$execute_nonstop'(G, M). @@ -568,15 +571,18 @@ debugging :- fail. % if we are in the interpreter, don't need to care about forcing a trace, do we? -'$continue_debugging'(no) :- !. +'$continue_debugging'(no,_,_) :- !. +'$continue_debugging'(Flag,G,M) :- + '$system_predicate'(G,M), !, + ( '$access_yap_flags'(10,1) -> '$late_creep' ; true). +'$continue_debugging'(Flag,_,_) :- + '$continue_debugging'(Flag). + '$continue_debugging'(_) :- '$access_yap_flags'(10,1), !, '$creep'. '$continue_debugging'(_). -'$stop_debugging' :- - '$stop_creep'. - '$action_help' :- format(user_error,"newline creep a abort~n", []), format(user_error,"c creep e exit~n", []), diff --git a/pl/directives.yap b/pl/directives.yap index a9b11730e..470d82cd5 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -15,6 +15,14 @@ * * *************************************************************************/ +'$all_directives'(_:G1) :- !, + '$all_directives'(G1). +'$all_directives'((G1,G2)) :- !, + '$all_directives'(G1), + '$all_directives'(G2). +'$all_directives'(G) :- !, + '$directive'(G). + '$directive'(multifile(_)). '$directive'(discontiguous(_)). '$directive'(initialization(_)). @@ -42,6 +50,12 @@ '$directive'(uncutable(_)). '$directive'(thread_local(_)). +'$exec_directives'((G1,G2), Mode, M) :- !, + '$exec_directives'(G1, Mode, M), + '$exec_directives'(G2, Mode, M). +'$exec_directives'(G, Mode, M) :- + '$exec_directive'(G, Mode, M). + '$exec_directive'(multifile(D), _, M) :- '$system_catch'('$multifile'(D, M), M, Error, @@ -102,12 +116,6 @@ '$uncutable'(PredSpec, M). -'$exec_directives'((G1,G2), Mode, M) :- !, - '$exec_directives'(G1, Mode, M), - '$exec_directives'(G2, Mode, M). -'$exec_directives'(G, Mode, M) :- - '$exec_directive'(G, Mode, M). - yap_flag(V,Out) :- var(V), !, '$show_yap_flag_opts'(V,Out). diff --git a/pl/init.yap b/pl/init.yap index 5ae802536..51b4b2792 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -20,12 +20,18 @@ % These are pseudo declarations % so that the user will get a redefining system predicate -otherwise. fail :- fail. + false :- fail. + +otherwise. + !. + (:- G) :- '$execute'(G), !. + '$$!'(CP) :- '$cut_by'(CP). + [] :- true. @@ -66,6 +72,8 @@ false :- fail. 'threads.yap', 'yapor.yap']. +:- thread_local([idb:'$debug'/0,idb:'$trace'/0,idb:'$spy_skip'/0,idb:'$spy_stop'/0]). + :- ['protect.yap']. version(yap,[4,1]). diff --git a/pl/modules.yap b/pl/modules.yap index cdc7eea91..c36efa143 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -413,6 +413,8 @@ module(N) :- :- dynamic_predicate('$meta_predicate'/4,logical). +:- multifile '$meta_predicate'/4. + '$meta_predicate'((P,Ps), M) :- !, '$meta_predicate'(P, M), '$meta_predicate'(Ps, M). diff --git a/pl/preds.yap b/pl/preds.yap index fd9777e64..371036cf9 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -388,7 +388,7 @@ nth_clause(V,I,R) :- M1 = M. '$nth_clause_ref'(P,M,I,R) :- '$nth_instancep'(M:P,I,R). - + retract(M:C) :- !, '$retract'(C,M). retract(C) :- diff --git a/pl/signals.yap b/pl/signals.yap index 92467ece1..61a31cf37 100644 --- a/pl/signals.yap +++ b/pl/signals.yap @@ -31,8 +31,15 @@ % if more signals alive, set creep flag '$continue_signals', '$wake_up_goal'(G, LG). -'$do_signal'(sig_creep, G) :- - '$start_creep'(G). +'$do_signal'(sig_creep, [M|G]) :- + ( '$access_yap_flags'(10,0) -> + % we're not allowed to creep for now, + % maybe we're inside builtin. + '$late_creep', + '$execute'(M:G) + ; + '$start_creep'([M|G]) + ). '$do_signal'(sig_delay_creep, [M|G]) :- '$execute'(M:G), '$creep'. @@ -93,7 +100,7 @@ '$creep', '$execute_nonstop'(G,Mod). '$start_creep'([Mod|G]) :- - '$stop_debugging', + '$do_not_creep', CP is '$last_choice_pt', '$do_spy'(G, Mod, CP, yes).