diff --git a/C/absmi.c b/C/absmi.c index 77a4d4e80..38c9349b8 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -11244,6 +11244,142 @@ absmi(int inp) } ENDBOp(); + + BOp(p_execute_within, sla); + { + PredEntry *pen; + + CACHE_Y_AS_ENV(Y); + CACHE_A1(); + BEGD(d0); + d0 = ARG1; + if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { + d0 = ExecuteCallMetaCall(); + } + deref_head(d0, execute_within_unk); + execute_within_nvar: + if (IsApplTerm(d0)) { + Functor f = FunctorOfTerm(d0); + if (IsExtensionFunctor(f)) { + d0 = ExecuteCallMetaCall(); + goto execute_within_nvar; + } + pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr)); + if (pen->PredFlags & MetaPredFlag) { + d0 = ExecuteCallMetaCall(); + goto execute_within_nvar; + } + BEGP(pt1); + pt1 = RepAppl(d0); + BEGD(d2); + for (d2 = ArityOfFunctor(f); d2; d2--) { +#if SBA + BEGD(d1); + d1 = pt1[d2]; + if (d1 == 0) + XREGS[d2] = (CELL)(pt1+d2); + else + XREGS[d2] = d1; +#else + XREGS[d2] = pt1[d2]; +#endif + } + ENDD(d2); + ENDP(pt1); + } else if (IsAtomTerm(d0)) { + if (AtomOfTerm(d0) == AtomCut) { + choiceptr pt0; + + pt0 = (choiceptr)(ENV[E_CB]); + if (TopB != NULL && YOUNGER_CP(TopB,pt0)) { + pt0 = TopB; + if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB)) + DelayedB = pt0; + } + /* find where to cut to */ + if (SHOULD_CUT_UP_TO(B,pt0)) { +#ifdef YAPOR + /* Wow, we're gonna cut!!! */ + CUT_prune_to(pt0); +#else + /* Wow, we're gonna cut!!! */ + B = pt0; +#endif /* YAPOR */ + HB = PROTECT_FROZEN_H(B); + } + PREG = NEXTOP(PREG, sla); + JMPNext(); + }else + pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), *CurrentModulePtr)); + } else { + d0 = ExecuteCallMetaCall(); + goto execute_within_nvar; + } + +#ifndef NO_CHECKING + check_stack(NoStackPWExec, H); +#endif + /* code copied from call */ + ENV = E_Y; + /* Try to preserve the environment */ + E_Y = (CELL *) (((char *) Y) + PREG->u.sla.s); + CPREG = + (yamop *) NEXTOP(PREG, sla); + ALWAYS_LOOKAHEAD(pen->OpcodeOfPred); + PREG = (yamop *) pen->CodeOfPred; +#ifdef DEPTH_LIMIT + if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */ + if (pen->ModuleOfPred) { + if (DEPTH == MkIntTerm(0)) + FAIL(); + else DEPTH = RESET_DEPTH(); + } + } else if (pen->ModuleOfPred) + DEPTH -= MkIntConstant(2); +#endif /* DEPTH_LIMIT */ +#ifdef LOW_LEVEL_TRACER + if (do_low_level_trace) + low_level_trace(enter_pred,pen,XREGS+1); +#endif /* LOW_LEVEL_TRACER */ +#ifdef FROZEN_REGS + { + choiceptr top_b = PROTECT_FROZEN_B(B); +#ifdef SBA + if (E_Y > (CELL *) top_b || E_Y < H) E_Y = (CELL *) top_b; +#else + if (E_Y > (CELL *) top_b) E_Y = (CELL *) top_b; +#endif + } +#else + if (E_Y > (CELL *) B) { + E_Y = (CELL *) B; + } +#endif /* FROZEN_REGS */ + WRITEBACK_Y_AS_ENV(); + /* setup GB */ + E_Y[E_CB] = ENV[E_CB]; +#ifdef YAPOR + SCH_check_requests(); +#endif /* YAPOR */ + ALWAYS_GONext(); + ALWAYS_END_PREFETCH(); + + BEGP(pt1); + deref_body(d0, pt1, execute_within_unk, execute_within_nvar); + d0 = ExecuteCallMetaCall(); + goto execute_within_nvar; + ENDP(pt1); + ENDD(d0); + ENDCACHE_Y_AS_ENV(); + + NoStackPWExec: + /* on X86 machines S will not actually be holding the pointer to pred */ + SREG = (CELL *) pen; + goto NoStackCallGotS; + + } + ENDBOp(); + #if !USE_THREADED_CODE default: PREG = Error(SYSTEM_ERROR, MkIntegerTerm(opcode), "trying to execute invalid YAAM instruction %d", opcode); diff --git a/C/amasm.c b/C/amasm.c index e45145273..ac55b1f60 100644 --- a/C/amasm.c +++ b/C/amasm.c @@ -770,6 +770,8 @@ a_p(op_numbers opcode) } else { if (RepPredProp(fe)->FunctorOfPred == FunctorExecuteInMod) code_p->opc = emit_op(_p_execute); + else if (RepPredProp(fe)->FunctorOfPred == FunctorExecuteWithin) + code_p->opc = emit_op(_p_execute_within); else code_p->opc = emit_op(_call_cpred); } diff --git a/C/init.c b/C/init.c index 3a2d113d2..3eb6b8d7e 100644 --- a/C/init.c +++ b/C/init.c @@ -548,7 +548,7 @@ InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int f pe->PredFlags = flags | StandardPredFlag | CPredFlag; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; - p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); + p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); p_code->u.sla.l2 = (CELL)NIL; p_code->u.sla.s = -Signed(RealEnvSize); p_code->u.sla.p = (CODEADDR)pe; @@ -561,7 +561,6 @@ InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int f cmp_funcs[NUMBER_OF_CMPFUNCS].p = pe; cmp_funcs[NUMBER_OF_CMPFUNCS].f = cmp_code; NUMBER_OF_CMPFUNCS++; - pe->OpcodeOfPred = opcode(_Ystop); } void @@ -945,6 +944,7 @@ InitCodes(void) heap_regs->functor_csult = MkFunctor(AtomCsult, 1); heap_regs->functor_eq = MkFunctor(AtomEq, 2); heap_regs->functor_execute_in_mod = MkFunctor(LookupAtom("$execute_in_mod"), 2); + heap_regs->functor_execute_within = MkFunctor(LookupAtom("$execute_within"), 1); heap_regs->functor_g_atom = MkFunctor(LookupAtom("atom"), 1); heap_regs->functor_g_atomic = MkFunctor(LookupAtom("atomic"), 1); heap_regs->functor_g_compound = MkFunctor(LookupAtom("compound"), 1); diff --git a/C/save.c b/C/save.c index a96b3df7f..9e4015f73 100644 --- a/C/save.c +++ b/C/save.c @@ -1072,6 +1072,7 @@ restore_codes(void) heap_regs->functor_csult = FuncAdjust(heap_regs->functor_csult); heap_regs->functor_eq = FuncAdjust(heap_regs->functor_eq); heap_regs->functor_execute_in_mod = FuncAdjust(heap_regs->functor_execute_in_mod); + heap_regs->functor_execute_within = FuncAdjust(heap_regs->functor_execute_within); heap_regs->functor_g_atom = FuncAdjust(heap_regs->functor_g_atom); heap_regs->functor_g_atomic = FuncAdjust(heap_regs->functor_g_atomic); heap_regs->functor_g_compound = FuncAdjust(heap_regs->functor_g_compound); @@ -1729,6 +1730,7 @@ RestoreClause(Clause *Cl) case _either: case _or_else: case _p_execute: + case _p_execute_within: #ifdef YAPOR case _or_last: #endif diff --git a/H/Heap.h b/H/Heap.h index 5fb6060c2..7cca5ea02 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -10,7 +10,7 @@ * File: Heap.h * * mods: * * comments: Heap Init Structure * -* version: $Id: Heap.h,v 1.10 2001-10-30 16:42:05 vsc Exp $ * +* version: $Id: Heap.h,v 1.11 2001-10-30 20:35:19 vsc Exp $ * *************************************************************************/ /* information that can be stored in Code Space */ @@ -228,6 +228,7 @@ typedef struct various_codes { functor_cut_by, functor_eq, functor_execute_in_mod, + functor_execute_within, functor_g_atom, functor_g_atomic, functor_g_compound, @@ -416,6 +417,7 @@ typedef struct various_codes { #define FunctorCutBy heap_regs->functor_cut_by #define FunctorEq heap_regs->functor_eq #define FunctorExecuteInMod heap_regs->functor_execute_in_mod +#define FunctorExecuteWithin heap_regs->functor_execute_within #define FunctorGAtom heap_regs->functor_g_atom #define FunctorGAtomic heap_regs->functor_g_atomic #define FunctorGCompound heap_regs->functor_g_compound diff --git a/H/YapOpcodes.h b/H/YapOpcodes.h index 0f2e7fe7f..f6f1eaac5 100644 --- a/H/YapOpcodes.h +++ b/H/YapOpcodes.h @@ -354,5 +354,6 @@ OPCODE(p_func2f_xy ,xyx), OPCODE(p_func2f_yx ,yxx), OPCODE(p_func2f_yy ,yyx), - OPCODE(p_execute ,sla) + OPCODE(p_execute ,sla), + OPCODE(p_execute_within ,sla) diff --git a/H/amidefs.h b/H/amidefs.h index 52a4e271e..de14a10e1 100644 --- a/H/amidefs.h +++ b/H/amidefs.h @@ -54,7 +54,7 @@ typedef enum { } op_numbers; -#define _std_top _p_func2f_yy +#define _std_top _p_execute_within typedef enum { _atom,