diff --git a/C/absmi.c b/C/absmi.c index b0f837f44..73433b9f7 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -549,6 +549,24 @@ static inline Term rbig(MP_INT *big) #include "arith2.h" +/* + I can creep if I am not a prolog builtin that has been called + by a prolog builtin, + exception: meta-calls +*/ +static PredEntry * +creep_allowed(PredEntry *p, PredEntry *p0) +{ + if (p0 == PredMetaCall) + return p0; + if (!p0->ModuleOfPred && + (!p->ModuleOfPred + || + p->PredFlags & StandardPredFlag)) + return NULL; + return p; +} + #ifdef COROUTINING /* Imagine we are interrupting the execution, say, because we have a spy @@ -2348,9 +2366,9 @@ Yap_absmi(int inp) ENDOp(); /* commit_b_x Xi */ - Op(commit_b_x, x); + Op(commit_b_x, xp); BEGD(d0); - d0 = XREG(PREG->u.x.x); + d0 = XREG(PREG->u.xp.x); #ifdef COROUTINING CACHE_Y_AS_ENV(YREG); check_stack(NoStackCommitX, H); @@ -2358,7 +2376,7 @@ Yap_absmi(int inp) do_commit_b_x: #endif /* skip a void call and a label */ - PREG = NEXTOP(NEXTOP(NEXTOP(PREG, x),sbpp),l); + PREG = NEXTOP(NEXTOP(NEXTOP(PREG, xp),sbpp),l); { choiceptr pt0; #if defined(SBA) && defined(FROZEN_STACKS) @@ -2395,16 +2413,16 @@ Yap_absmi(int inp) ENDOp(); /* commit_b_y Yi */ - Op(commit_b_y, y); + Op(commit_b_y, yp); BEGD(d0); - d0 = YREG[PREG->u.y.y]; + d0 = YREG[PREG->u.yp.y]; #ifdef COROUTINING CACHE_Y_AS_ENV(YREG); check_stack(NoStackCommitY, H); ENDCACHE_Y_AS_ENV(); do_commit_b_y: #endif - PREG = NEXTOP(NEXTOP(NEXTOP(PREG, y),sbpp),l); + PREG = NEXTOP(NEXTOP(NEXTOP(PREG, yp),sbpp),l); { choiceptr pt0; #if defined(SBA) && defined(FROZEN_STACKS) @@ -2488,6 +2506,7 @@ Yap_absmi(int inp) NoStackExecute: SREG = (CELL *) PREG->u.pp.p; + PP = PREG->u.pp.p0; if (ActiveSignals & YAP_CDOVF_SIGNAL) { ASP = YREG+E_CB; if (ASP > (CELL *)PROTECT_FROZEN_B(B)) @@ -2629,48 +2648,12 @@ Yap_absmi(int inp) ENDBOp(); NoStackCall: + PP = PREG->u.sbpp.p0; /* on X86 machines S will not actually be holding the pointer to pred */ if (ActiveSignals & YAP_CREEP_SIGNAL) { PredEntry *ap = PREG->u.sbpp.p; - if (ap->PredFlags & HiddenPredFlag) { - CACHE_Y_AS_ENV(YREG); - CACHE_A1(); - ENV = ENV_YREG; - /* Try to preserve the environment */ - ENV_YREG = (CELL *) (((char *) YREG) + PREG->u.sbpp.s); - CPREG = NEXTOP(PREG, sbpp); - ALWAYS_LOOKAHEAD(ap->OpcodeOfPred); - PREG = ap->CodeOfPred; - /* for profiler */ - save_pc(); - check_depth(DEPTH, ap); -#ifdef FROZEN_STACKS - { - choiceptr top_b = PROTECT_FROZEN_B(B); -#ifdef SBA - if (ENV_YREG > (CELL *) top_b || ENV_YREG < H) ENV_YREG = (CELL *) top_b; -#else - if (ENV_YREG > (CELL *) top_b) ENV_YREG = (CELL *) top_b; -#endif - } -#else - if (ENV_YREG > (CELL *) B) { - ENV_YREG = (CELL *) B; - } -#endif /* FROZEN_STACKS */ - WRITEBACK_Y_AS_ENV(); - /* setup GB */ - ENV_YREG[E_CB] = (CELL) B; -#ifdef YAPOR - SCH_check_requests(); -#endif /* YAPOR */ - ALWAYS_GONext(); - ALWAYS_END_PREFETCH(); - ENDCACHE_Y_AS_ENV(); - } else { - SREG = (CELL *) ap; - goto creepc; - } + SREG = (CELL *) ap; + goto creepc; } SREG = (CELL *) PREG->u.sbpp.p; if (ActiveSignals & YAP_CDOVF_SIGNAL) { @@ -2742,6 +2725,7 @@ Yap_absmi(int inp) /* This is easier: I know there is an environment so I cannot do allocate */ NoStackCommitY: + PP = PREG->u.yp.p0; /* find something to fool S */ if (!ActiveSignals || ActiveSignals & YAP_CDOVF_SIGNAL) { goto do_commit_b_y; @@ -2757,6 +2741,7 @@ Yap_absmi(int inp) /* Problem: have I got an environment or not? */ NoStackCommitX: + PP = PREG->u.xp.p0; /* find something to fool S */ if (!ActiveSignals || ActiveSignals & YAP_CDOVF_SIGNAL) { goto do_commit_b_x; @@ -2787,6 +2772,7 @@ Yap_absmi(int inp) /* Problem: have I got an environment or not? */ NoStackFail: + PP = NULL; /* find something to fool S */ if (!ActiveSignals || ActiveSignals & YAP_CDOVF_SIGNAL) { goto fail; @@ -2800,6 +2786,7 @@ Yap_absmi(int inp) /* don't forget I cannot creep at ; */ NoStackEither: + PP = PREG->u.sblp.p0; if (ActiveSignals & YAP_CREEP_SIGNAL) { goto either_notest; } @@ -2876,8 +2863,9 @@ Yap_absmi(int inp) goto creep; NoStackDExecute: + PP = PREG->u.pp.p0; if (ActiveSignals & YAP_CREEP_SIGNAL) { - PredEntry *ap = PREG->u.p.p; + PredEntry *ap = PREG->u.pp.p; if (ap->PredFlags & HiddenPredFlag) { CACHE_Y_AS_ENV(YREG); @@ -3014,6 +3002,10 @@ Yap_absmi(int inp) #ifdef SHADOW_S S = SREG; #endif + /* tell whether we can creep or not, this is hard because we will + lose the info RSN + */ + PP = creep_allowed((PredEntry*)SREG,PP); BEGD(d0); d0 = ((PredEntry *)(SREG))->ArityOfPE; if (d0 == 0) { @@ -3061,9 +3053,9 @@ Yap_absmi(int inp) H += 2; LOCK(SignalLock); - CreepFlag = CalculateStackGap(); #ifdef COROUTINING if (ActiveSignals & YAP_WAKEUP_SIGNAL) { + CreepFlag = CalculateStackGap(); ActiveSignals &= ~YAP_WAKEUP_SIGNAL; UNLOCK(SignalLock); ARG2 = Yap_ListOfWokenGoals(); @@ -3072,13 +3064,16 @@ Yap_absmi(int inp) Yap_UpdateTimedVar(WokenGoals, TermNil); } else #endif - SREG = (CELL *) CreepCode; + { + CreepFlag = CalculateStackGap(); + SREG = (CELL *) CreepCode; + } UNLOCK(SignalLock); + PREG = ((PredEntry *)SREG)->CodeOfPred; #ifdef LOW_LEVEL_TRACER if (Yap_do_low_level_trace) low_level_trace(enter_pred,(PredEntry *)(SREG),XREGS+1); #endif /* LOW_LEVEL_TRACE */ - PREG = ((PredEntry *)(SREG))->CodeOfPred; /* for profiler */ save_pc(); CACHE_A1(); @@ -13428,6 +13423,7 @@ Yap_absmi(int inp) ENDD(d0); NoStackPExecute2: + PP = PredMetaCall; SREG = (CELL *) pen; ASP = ENV_YREG; /* setup GB */ @@ -13624,6 +13620,7 @@ Yap_absmi(int inp) ENDD(d0); NoStackPExecute: + PP = PredMetaCall; SREG = (CELL *) pen; ASP = ENV_YREG; /* setup GB */ @@ -13891,6 +13888,7 @@ Yap_absmi(int inp) ENDD(d0); ENDP(pt0); NoStackPTExecute: + PP = NULL; WRITEBACK_Y_AS_ENV(); SREG = (CELL *) pen; ASP = ENV_YREG; diff --git a/C/amasm.c b/C/amasm.c index 0683e85b5..4f720ca92 100644 --- a/C/amasm.c +++ b/C/amasm.c @@ -553,6 +553,33 @@ a_v(op_numbers opcodex, op_numbers opcodey, yamop *code_p, int pass_no, struct P return code_p; } +inline static yamop * +a_vp(op_numbers opcodex, op_numbers opcodey, yamop *code_p, int pass_no, struct PSEUDO *cpc, clause_info *clinfo) +{ + Ventry *ve = (Ventry *) cpc->rnd1; + OPREG var_offset; + int is_y_var = (ve->KindOfVE == PermVar); + + var_offset = Var_Ref(ve, is_y_var); + if (is_y_var) { + if (pass_no) { + code_p->opc = emit_op(opcodey); + code_p->u.yp.y = emit_yreg(var_offset); + code_p->u.yp.p0 = clinfo->CurrentPred; + } + GONEXT(yp); + } + else { + if (pass_no) { + code_p->opc = emit_op(opcodex); + code_p->u.xp.x = emit_xreg(var_offset); + code_p->u.xp.p0 = clinfo->CurrentPred; + } + GONEXT(xp); + } + return code_p; +} + inline static yamop * a_uv(Ventry *ve, op_numbers opcodex, op_numbers opcodexw, op_numbers opcodey, op_numbers opcodeyw, yamop *code_p, int pass_no) { @@ -3099,7 +3126,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp code_p = a_v(_save_b_x, _save_b_y, code_p, pass_no, cip->cpc); break; case commit_b_op: - code_p = a_v(_commit_b_x, _commit_b_y, code_p, pass_no, cip->cpc); + code_p = a_vp(_commit_b_x, _commit_b_y, code_p, pass_no, cip->cpc, &clinfo); break; case save_pair_op: code_p = a_uv((Ventry *) cip->cpc->rnd1, _save_pair_x, _save_pair_x_write, _save_pair_y, _save_pair_y_write, code_p, pass_no); diff --git a/C/cdmgr.c b/C/cdmgr.c index 15025348f..1a5c8ab51 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -3987,9 +3987,12 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) { #endif /* TABLING_INNER_CUTS */ pc = NEXTOP(pc,e); break; + /* instructions type xp */ + case _commit_b_x: + pc = NEXTOP(pc,xp); + break; /* instructions type x */ case _save_b_x: - case _commit_b_x: case _get_list: case _put_list: case _write_x_var: @@ -4011,9 +4014,12 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) { case _p_cut_by_x: pc = NEXTOP(pc,xl); break; + /* instructions type yp */ + case _commit_b_y: + pc = NEXTOP(pc,yp); + break; /* instructions type y */ case _save_b_y: - case _commit_b_y: case _write_y_var: case _write_y_val: case _write_y_loc: diff --git a/C/exec.c b/C/exec.c index bd255bd36..9e62c0f76 100644 --- a/C/exec.c +++ b/C/exec.c @@ -383,6 +383,7 @@ EnterCreepMode(Term t, Term mod) { return do_execute(ARG1, mod); } } + PP = PredMetaCall; PredCreep = RepPredProp(PredPropByFunc(FunctorCreep,1)); if (mod) { ARG1 = MkPairTerm(mod,t); @@ -623,6 +624,11 @@ p_execute_clause(void) } else { code = Yap_ClauseFromTerm(clt)->ClCode; } + LOCK(SignalLock); + if (ActiveSignals & YAP_CREEP_SIGNAL) { + Yap_signal(YAP_CREEP_SIGNAL); + } + UNLOCK(SignalLock); return CallPredicate(RepPredProp(pe), cut_cp, code); } @@ -745,6 +751,11 @@ p_execute_nonstop(void) } /* N = arity; */ /* call may not define new system predicates!! */ + LOCK(SignalLock); + if (ActiveSignals & YAP_CREEP_SIGNAL) { + Yap_signal(YAP_CREEP_SIGNAL); + } + UNLOCK(SignalLock); if (RepPredProp(pe)->PredFlags & SpiedPredFlag) { return CallPredicate(RepPredProp(pe), B, RepPredProp(pe)->cs.p_code.TrueCodeOfPred); } else if ((RepPredProp(pe)->PredFlags & (AsmPredFlag|CPredFlag)) && @@ -2040,6 +2051,12 @@ p_uncaught_throw(void) return out; } +static Int +p_creep_allowed(void) +{ + return (PP != NULL); +} + void Yap_InitExecFs(void) { @@ -2089,6 +2106,7 @@ Yap_InitExecFs(void) Yap_InitCPred("$clean_ifcp", 1, p_clean_ifcp, SafePredFlag|HiddenPredFlag); Yap_InitCPred("qpack_clean_up_to_disjunction", 0, p_cut_up_to_next_disjunction, SafePredFlag); Yap_InitCPred("$jump_env_and_store_ball", 1, p_jump_env, HiddenPredFlag); + Yap_InitCPred("$creep_allowed", 0, p_creep_allowed, HiddenPredFlag); Yap_InitCPred("$generate_pred_info", 4, p_generate_pred_info, HiddenPredFlag); Yap_InitCPred("$uncaught_throw", 0, p_uncaught_throw, HiddenPredFlag); } diff --git a/C/stdpreds.c b/C/stdpreds.c index 5c18e6465..b19983384 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -503,7 +503,7 @@ p_creep(void) } static Int -p_delayed_creep(void) +p_signal_creep(void) { Atom at; PredEntry *pred; @@ -511,13 +511,43 @@ p_delayed_creep(void) at = Yap_FullLookupAtom("$creep"); pred = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, 1),0)); CreepCode = pred; - do_signal(YAP_CREEP_SIGNAL); LOCK(SignalLock); - CreepFlag = CalculateStackGap(); + ActiveSignals |= YAP_CREEP_SIGNAL; UNLOCK(SignalLock); return TRUE; } +static Int +p_disable_creep(void) +{ + LOCK(SignalLock); + if (ActiveSignals & YAP_CREEP_SIGNAL) { + ActiveSignals &= ~YAP_CREEP_SIGNAL; + if (!ActiveSignals) + CreepFlag = CalculateStackGap(); + UNLOCK(SignalLock); + return TRUE; + } + UNLOCK(SignalLock); + return FALSE; +} + +/* never fails */ +static Int +p_disable_docreep(void) +{ + LOCK(SignalLock); + if (ActiveSignals & YAP_CREEP_SIGNAL) { + ActiveSignals &= ~YAP_CREEP_SIGNAL; + if (!ActiveSignals) + CreepFlag = CalculateStackGap(); + UNLOCK(SignalLock); + } else { + UNLOCK(SignalLock); + } + return TRUE; +} + static Int p_stop_creep(void) { @@ -3925,8 +3955,10 @@ Yap_InitCPreds(void) /* basic predicates for the prolog machine tracer */ /* they are defined in analyst.c */ /* Basic predicates for the debugger */ - Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred("$late_creep", 0, p_delayed_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred("$creep", 0, p_creep, SafePredFlag|HiddenPredFlag); + Yap_InitCPred("$signal_creep", 0, p_signal_creep, SafePredFlag|HiddenPredFlag); + Yap_InitCPred("$disable_creep", 0, p_disable_creep, SafePredFlag|HiddenPredFlag); + Yap_InitCPred("$disable_docreep", 0, p_disable_docreep, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$do_not_creep", 0, p_stop_creep, SafePredFlag|SyncPredFlag|HiddenPredFlag); #ifdef DEBUG Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag|HiddenPredFlag); diff --git a/C/tracer.c b/C/tracer.c index f07e73e89..a0496a460 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -164,8 +164,6 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) LOCK(Yap_heap_regs->low_level_trace_lock); sc = Yap_heap_regs; vsc_count++; - if (vsc_count < 82500) - return; #ifdef THREADS Yap_heap_regs->thread_handle[worker_id].thread_inst_count++; #endif diff --git a/H/Regs.h b/H/Regs.h index eb6666d10..091b9a07c 100644 --- a/H/Regs.h +++ b/H/Regs.h @@ -117,8 +117,8 @@ typedef struct choiceptr B_FZ_; tr_fr_ptr TR_FZ_; #endif /* SBA || TABLING */ -#if defined(YAPOR) || defined(THREADS) struct pred_entry *PP_; +#if defined(YAPOR) || defined(THREADS) /* recursive write-locks for PredEntry */ yamop **PREG_ADDR_; unsigned int worker_id_; @@ -699,9 +699,9 @@ EXTERN inline void restore_B(void) { #define B_FZ Yap_REGS.B_FZ_ #define TR_FZ Yap_REGS.TR_FZ_ #endif /* SBA || TABLING */ +#define PP (Yap_REGS.PP_) #if defined(YAPOR) || defined(THREADS) #define worker_id (Yap_REGS.worker_id_) -#define PP (Yap_REGS.PP_) #define PREG_ADDR (Yap_REGS.PREG_ADDR_) #ifdef SBA #define BSEG Yap_REGS.BSEG_ diff --git a/H/YapOpcodes.h b/H/YapOpcodes.h index 2cd268219..10debba61 100644 --- a/H/YapOpcodes.h +++ b/H/YapOpcodes.h @@ -38,8 +38,8 @@ OPCODE(cut_e ,e), OPCODE(save_b_x ,x), OPCODE(save_b_y ,y), - OPCODE(commit_b_x ,x), - OPCODE(commit_b_y ,y), + OPCODE(commit_b_x ,xp), + OPCODE(commit_b_y ,yp), OPCODE(execute ,pp), OPCODE(dexecute ,pp), OPCODE(fcall ,sbpp), diff --git a/H/amidefs.h b/H/amidefs.h index b8b183402..abdb9b39d 100644 --- a/H/amidefs.h +++ b/H/amidefs.h @@ -522,7 +522,12 @@ typedef struct yami { } x; struct { wamreg x; - CELL c; + struct pred_entry *p0; + CELL next; + } xp; + struct { + wamreg x; + CELL c; CELL next; } xc; struct { @@ -591,6 +596,11 @@ typedef struct yami { yslot y; CELL next; } y; + struct { + yslot y; + struct pred_entry *p0; + CELL next; + } yp; struct { yslot y; struct yami *F; diff --git a/H/rclause.h b/H/rclause.h index 237e3aafc..0407093a1 100644 --- a/H/rclause.h +++ b/H/rclause.h @@ -480,7 +480,6 @@ restore_opcodes(yamop *pc) pc = NEXTOP(pc,sssllp); break; /* instructions type x */ - case _commit_b_x: case _get_list: case _put_list: case _save_b_x: @@ -554,6 +553,12 @@ restore_opcodes(yamop *pc) pc->u.xllll.l4 = PtoOpAdjust(pc->u.xllll.l4); pc = NEXTOP(pc,xllll); break; + /* instructions type xp */ + case _commit_b_x: + pc->u.xp.x = XAdjust(pc->u.xp.x); + pc->u.xp.p0 = PtoPredAdjust(pc->u.xp.p0); + pc = NEXTOP(pc,xp); + break; /* instructions type xx */ case _get_x_val: case _get_x_var: @@ -627,7 +632,6 @@ restore_opcodes(yamop *pc) pc = NEXTOP(pc,xy); break; /* instructions type y */ - case _commit_b_y: case _save_b_y: case _write_y_loc: case _write_y_val: @@ -650,6 +654,12 @@ restore_opcodes(yamop *pc) pc->u.yl.F = PtoOpAdjust(pc->u.yl.F); pc = NEXTOP(pc,yl); break; + /* instructions type yp */ + case _commit_b_y: + pc->u.yp.y = YAdjust(pc->u.yp.y); + pc->u.yp.p0 = PtoPredAdjust(pc->u.yp.p0); + pc = NEXTOP(pc,yp); + break; /* instructions type yx */ case _get_y_val: case _get_y_var: diff --git a/pl/boot.yap b/pl/boot.yap index 1bf331f88..a9b769144 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -1164,3 +1164,9 @@ throw(Ball) :- nb_setval('$system_mode',off), ( nb_getval('$trace',on) -> '$creep' ; true). +'$donotrace'(G) :- + '$disable_creep', !, + '$execute'(G), + '$creep'. +'$donotrace'(G) :- + '$execute'(G). diff --git a/pl/debug.yap b/pl/debug.yap index ac0374b93..338f79607 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -275,10 +275,10 @@ debugging :- % $spy may be called from user code, so be careful. '$spy'([Mod|G]) :- nb_getval('$debug',off), !, - '$execute_nonstop'(G,Mod). + '$execute'(G,Mod). '$spy'([Mod|G]) :- nb_getval('$system_mode',on), !, - '$execute_nonstop'(G,Mod). + '$execute'(G,Mod). '$spy'([Mod|G]) :- CP is '$last_choice_pt', '$do_spy'(G, Mod, CP, yes). @@ -289,79 +289,79 @@ debugging :- '$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) :- !, +'$do_spy'(M:G, _, CP, CalledFromDebugger) :- !, + '$do_spy'(G, M, CP, CalledFromDebugger). +'$do_spy'((A,B), M, CP, CalledFromDebugger) :- !, '$do_spy'(A, M, CP, yes), - '$do_spy'(B, M, CP, InControl). -'$do_spy'((T->A;B), M, CP, InControl) :- !, + '$do_spy'(B, M, CP, CalledFromDebugger). +'$do_spy'((T->A;B), M, CP, CalledFromDebugger) :- !, ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ; - '$do_spy'(B, M, CP, InControl) + '$do_spy'(B, M, CP, CalledFromDebugger) ). -'$do_spy'((T->A|B), M, CP, InControl) :- !, +'$do_spy'((T->A|B), M, CP, CalledFromDebugger) :- !, ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ; - '$do_spy'(B, M, CP, InControl) + '$do_spy'(B, M, CP, CalledFromDebugger) ). '$do_spy'((T->A), M, CP, _) :- !, ( '$do_spy'(T, M, CP, yes) -> '$do_spy'(A, M, CP, yes) ). -'$do_spy'((A;B), M, CP, InControl) :- !, +'$do_spy'((A;B), M, CP, CalledFromDebugger) :- !, ( '$do_spy'(A, M, CP, yes) ; - '$do_spy'(B, M, CP, InControl) + '$do_spy'(B, M, CP, CalledFromDebugger) ). -'$do_spy'((A|B), M, CP, InControl) :- !, +'$do_spy'((A|B), M, CP, CalledFromDebugger) :- !, ( '$do_spy'(A, M, CP, yes) ; - '$do_spy'(B, M, CP, InControl) + '$do_spy'(B, M, CP, CalledFromDebugger) ). -'$do_spy'((\+G), M, CP, InControl) :- !, - \+ '$do_spy'(G, M, CP, InControl). -'$do_spy'((not(G)), M, CP, InControl) :- !, - \+ '$do_spy'(G, M, CP, InControl). -'$do_spy'(G, Module, _, InControl) :- +'$do_spy'((\+G), M, CP, CalledFromDebugger) :- !, + \+ '$do_spy'(G, M, CP, CalledFromDebugger). +'$do_spy'((not(G)), M, CP, CalledFromDebugger) :- !, + \+ '$do_spy'(G, M, CP, CalledFromDebugger). +'$do_spy'(G, Module, _, CalledFromDebugger) :- nb_getval('$spy_gn',L), /* get goal no. */ L1 is L+1, /* bump it */ nb_setval('$spy_gn',L1), /* and save it globaly */ b_getval('$spy_glist',History), /* get goal list */ b_setval('$spy_glist',[info(L,Module,G,_Retry,_Det)|History]), /* and update it */ - '$loop_spy'(L, G, Module, InControl). /* set creep on */ + '$loop_spy'(L, G, Module, CalledFromDebugger). /* set creep on */ % we are skipping, so we can just call the goal, % while leaving the minimal structure in place. -'$loop_spy'(GoalNumber, G, Module, InControl) :- +'$loop_spy'(GoalNumber, G, Module, CalledFromDebugger) :- yap_hacks:current_choice_point(CP), - '$system_catch'('$loop_spy2'(GoalNumber, G, Module, InControl, CP), + '$system_catch'('$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP), Module, Event, - '$loop_spy_event'(Event, GoalNumber, G, Module, InControl)). + '$loop_spy_event'(Event, GoalNumber, G, Module, CalledFromDebugger)). % handle weird things happening in the debugger. -'$loop_spy_event'('$retry_spy'(G0), GoalNumber, G, Module, InControl) :- +'$loop_spy_event'('$retry_spy'(G0), GoalNumber, G, Module, CalledFromDebugger) :- G0 >= GoalNumber, !, - '$loop_spy'(GoalNumber, G, Module, InControl). + '$loop_spy'(GoalNumber, G, Module, CalledFromDebugger). '$loop_spy_event'('$retry_spy'(GoalNumber), _, _, _, _) :- !, throw('$retry_spy'(GoalNumber)). -'$loop_spy_event'('$fail_spy'(G0), GoalNumber, G, Module, InControl) :- +'$loop_spy_event'('$fail_spy'(G0), GoalNumber, G, Module, CalledFromDebugger) :- G0 >= GoalNumber, !, - '$loop_fail'(GoalNumber, G, Module, InControl). + '$loop_fail'(GoalNumber, G, Module, CalledFromDebugger). '$loop_spy_event'('$fail_spy'(GoalNumber), _, _, _, _) :- !, throw('$fail_spy'(GoalNumber)). -'$loop_spy_event'('$done_spy'(G0,G), GoalNumber, G, _, _) :- +'$loop_spy_event'('$done_spy'(G0,G), GoalNumber, G, _, CalledFromDebugger) :- G0 >= GoalNumber, !, - '$continue_debugging'. + '$continue_debugging'(CalledFromDebugger). '$loop_spy_event'('$done_spy'(GoalNumber), _, _, _, _) :- !, throw('$done_spy'(GoalNumber)). '$loop_spy_event'(abort, _, _, _, _) :- !, throw('$abort'). -'$loop_spy_event'(Event, GoalNumber, G, Module, InControl) :- +'$loop_spy_event'(Event, GoalNumber, G, Module, CalledFromDebugger) :- '$debug_error'(Event), '$system_catch'( ('$trace'(exception,G,Module,GoalNumber,_),fail), Module,NewEvent, - '$loop_spy_event'(NewEvent, GoalNumber, G, Module, InControl)). + '$loop_spy_event'(NewEvent, GoalNumber, G, Module, CalledFromDebugger)). '$debug_error'(Event) :- @@ -371,18 +371,19 @@ debugging :- % just fail here, don't really need to call debugger, the user knows what he % wants to do -'$loop_fail'(_GoalNumber, _G, _Module, _InControl) :- - '$continue_debugging', +'$loop_fail'(_GoalNumber, _G, _Module, _CalledFromDebugger) :- + '$continue_debugging'(CalledFromDebugger), fail. % if we are in -'$loop_spy2'(GoalNumber, G, Module, InControl, CP) :- +'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :- /* the following choice point is where the predicate is called */ b_getval('$spy_glist',[info(_,_,_,Retry,Det)|_]), /* get goal list */ ( /* call port */ '$enter_goal'(GoalNumber, G, Module), - '$spycall'(G, Module, InControl, Retry), + '$spycall'(G, Module, CalledFromDebugger, Retry), + '$disable_docreep', ( '$debugger_deterministic_goal'(G) -> Det=true @@ -402,23 +403,23 @@ debugging :- ; true ), - '$continue_debugging' + '$continue_debugging'(CalledFromDebugger) ; /* backtracking from exit */ /* we get here when we want to redo a goal */ /* redo port */ - '$show_trace'(redo,G,Module,GoalNumber,_), /* inform user_error */ - '$continue_debugging'(InControl,G,Module), - fail /* to backtrack to spycalls */ + '$disable_docreep', + '$show_trace'(redo,G,Module,GoalNumber,_), /* inform user_error */ + '$continue_debugging'(CalledFromDebugger), + fail /* to backtrack to spycalls */ ) ; '$show_trace'(fail,G,Module,GoalNumber,_), /* inform at fail port */ - '$continue_debugging', + '$continue_debugging'(CalledFromDebugger), /* fail port */ fail ). - - + '$enter_goal'(GoalNumber, G, Module) :- '$zip'(GoalNumber, G, Module), !. '$enter_goal'(GoalNumber, G, Module) :- @@ -449,47 +450,49 @@ debugging :- ). + % '$spycall'(G, M, _, _) :- nb_getval('$debug_run',StopPoint), StopPoint \= off, !, - '$execute_nonstop'(G, M). + '$execute'(M:G). '$spycall'(G, M, _, _) :- '$system_predicate'(G,M), - \+ '$is_metapredicate'(G,M), - !, - '$execute_nonstop'(G, M). -'$spycall'(G, M, InControl, _) :- + \+ '$is_metapredicate'(G,M), + '$execute'(M:G). +'$spycall'(G, M, _, _) :- '$tabled_predicate'(G,M), !, - '$continue_debugging'(InControl, G, M), - '$execute_nonstop'(G, M). -'$spycall'(G, M, InControl, InRedo) :- + '$continue_debugging'(no, '$execute_nonstop'(G,M)). +'$spycall'(G, M, CalledFromDebugger, InRedo) :- '$flags'(G,M,F,F), F /\ 0x18402000 =\= 0, !, % dynamic procedure, logical semantics, user-C, or source % use the interpreter CP is '$last_choice_pt', '$clause'(G, M, Cl), - ( '$do_spy'(Cl, M, CP, InControl) ; InRedo = true ). -'$spycall'(G, M, InControl, InRedo) :- + ( '$do_spy'(Cl, M, CP, CalledFromDebugger) ; InRedo = true ). +'$spycall'(G, M, CalledFromDebugger, InRedo) :- '$undefined'(G, M), !, ( recorded('$import','$import'(NM,M,Goal,G,_,_),_) -> - '$spycall'(Goal, NM, InControl, InRedo) + '$spycall'(Goal, NM, CalledFromDebugger, InRedo) ; '$enter_undefp', '$find_undefp_handler'(G,M,Goal,NM) -> - '$spycall'(Goal, NM, InControl, InRedo) + '$spycall'(Goal, NM, CalledFromDebugger, InRedo) ). -'$spycall'(G, M, InControl, InRedo) :- +'$spycall'(G, M, _, InRedo) :- % I lost control here. CP is '$last_choice_pt', '$static_clause'(G,M,_,R), - '$continue_debugging'(InControl, G, M), - ( '$execute_clause'(G, M, R, CP) ; InRedo = true ). + ( + '$continue_debugging'(no, '$execute_clause'(G, M, R, CP)) + ; + InRedo = true + ). '$tabled_predicate'(G,M) :- '$flags'(G,M,F,F), @@ -656,20 +659,34 @@ debugging :- '$ilgl'(C), fail. -% if we are in the interpreter, don't need to care about forcing a trace, do we? -'$continue_debugging'(no,_,_) :- !. -'$continue_debugging'(_,G,M) :- - '$system_predicate'(G,M), !, - '$late_creep'. -'$continue_debugging'(_,_,_) :- - 'nb_getval'('$debug_run',Zip), - (Zip == nodebug ; number(Zip) ; Zip = spy(_) ), !. -'$continue_debugging'(_,_,_) :- - '$continue_debugging'. - -'$continue_debugging' :- +'$continue_debugging'(yes). +% do not need to debug! +'$continue_debugging'(no) :- '$creep'. +% if we are in the interpreter, don't need to care about forcing a trace, do we? +'$continue_debugging'(yes,G) :- !, + '$execute_dgoal'(G). +% do not need to debug! +'$continue_debugging'(_,G) :- + 'nb_getval'('$debug_run',Zip), + (Zip == nodebug ; number(Zip) ; Zip = spy(_) ), !, + '$execute_dgoal'(G). +'$continue_debugging'(_,G) :- + '$execute_creep_dgoal'(G). + +'$execute_dgoal'('$execute_nonstop'(G,M)) :- + '$execute_nonstop'(G,M). +'$execute_dgoal'('$execute_clause'(G, M, R, CP)) :- + '$execute_clause'(G, M, R, CP). + +'$execute_creep_dgoal'('$execute_nonstop'(G,M)) :- + '$signal_creep', + '$execute_nonstop'(G,M). +'$execute_creep_dgoal'('$execute_clause'(G, M, R, CP)) :- + '$signal_creep', + '$execute_clause'(G, M, R, CP). + '$show_ancestors'(HowMany) :- b_getval('$spy_glist',[_|History]), ( diff --git a/pl/preds.yap b/pl/preds.yap index 2456635b4..aef24e946 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -984,4 +984,4 @@ current_key(A,K) :- '$notrace'(G, Mod) :- \+ '$undefined'(G, Mod), - call(Mod:G). + '$donotrace'(Mod:G). diff --git a/pl/signals.yap b/pl/signals.yap index 0d2100d3f..2821fcb51 100644 --- a/pl/signals.yap +++ b/pl/signals.yap @@ -31,8 +31,13 @@ % if more signals alive, set creep flag '$continue_signals', '$wake_up_goal'(G, LG). +% never creep on entering system mode!!! '$do_signal'(sig_creep, [M|G]) :- + '$creep_allowed', !, '$start_creep'([M|G]). +'$do_signal'(sig_creep, [M|G]) :- + '$signal_creep', + '$execute_nonstop'(G,M). '$do_signal'(sig_delay_creep, [M|G]) :- '$execute'(M:G), '$creep'. @@ -97,18 +102,13 @@ '$creep'. '$start_creep'([Mod|G]) :- '$hidden_predicate'(G,Mod), !, - '$creep', - '$execute_nonstop'(G,Mod). -'$start_creep'([Mod|G]) :- - '$system_predicate'(G, Mod), - '$protected_env', !, - '$creep', - '$execute_nonstop'(G,Mod). + '$execute_nonstop'(G,Mod), + '$creep'. % do not debug if we are zipping through. '$start_creep'([Mod|G]) :- nb_getval('$debug_zip',on), '$zip'(-1, G, Mod), !, - '$creep', + '$signal_creep', '$execute_nonstop'(G,Mod). '$start_creep'([Mod|G]) :- CP is '$last_choice_pt', @@ -171,35 +171,4 @@ read_sig :- read_sig. -'$protected_env' :- - yap_hacks:current_continuations([Env|Envs]), - yap_hacks:continuation(Env,_,Addr,_), -%'$envs'(Envs, Addr), - '$skim_envs'(Envs,Addr,Mod,Name,Arity), - \+ '$external_call_seen'(Mod,Name,Arity). - - -'$envs'([Env|Envs], Addr0) :- - yap_hacks:cp_to_predicate(Addr0,Mod0,Name0,Arity0,ClId), - format(user_error,'~a:~w/~w ~d~n',[Mod0,Name0,Arity0,ClId]), - yap_hacks:continuation(Env,_,Addr,_), - '$envs'(Envs, Addr). -'$envs'([], _) :- format(user_error,'*****done*****~n',[]). - -'$skim_envs'([Env|Envs],Addr0,Mod,Name,Arity) :- - yap_hacks:cp_to_predicate(Addr0, Mod0, Name0, Arity0, _ClId), - '$debugger_env'(Mod0,Name0,Arity0), !, - yap_hacks:continuation(Env,_,Addr,_), - '$skim_envs'(Envs,Addr,Mod,Name,Arity). -'$skim_envs'(_,Addr,Mod,Name,Arity) :- - yap_hacks:cp_to_predicate(Addr, Mod, Name, Arity, _ClId). - -'$debugger_env'(prolog,'$start_creep',1). - -'$external_call_seen'(prolog,Name,Arity) :- !, - '$allowed'(Name,Arity). -'$external_call_seen'(_,_,_). - - '$allowed'('$spycall',4). - '$allowed'('$query',2).