p_execute_within

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@172 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

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);

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);
 	}

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);

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

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

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)
 

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,