/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2008-2017, University of Amsterdam
                              VU University Amsterdam
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Implementation of the Virtual Machine Instructions (VMI).

Each VMI has the structure below. Using this structure we are completely
flexible in how we implement the instruction   and  we can easily create
the derived tables, which is done by the program mkvmi.c.

	VMI(Name, Flags, #Args, (ArgType, ...))
	{
	}

Within the scope of this file,   the following virtual machine variables
are available.

	* FR
	Current environment frame

	* NFR
	Next frame (used to share in various calling instructions)

	* BFR
	Backtrack frame: current choicepoint

	* PC
	Program Counter

	* ARGP
	Argument pointer

	* CL
	Running clause (= FR->clause)

	* DEF
	Running definition

Virtual machine instructions can return with one of:

	* NEXT_INSTRUCTION
	Proceed

	* CLAUSE_FAILED
	Failed unifying the head: backtrack to next clause

	* BODY_FAILED
	Failure of in-body instructions (I_FAIL, B_UNIFY_EXIT, ...)

	* FRAME_FAILED
	Other failures: deep backtracking.

	* VMI_GOTO(VMI)
	Continue executing another virtual instruction.  Note this is
	called GOTO as it is a jump rather than a call.

Virtual machine instruction names.  Prefixes:

  I_	General instructions
  B_	Body specific version
  H_	Head specific versin
  A_	Arithmetic compilation specific
  C_	Control (compilation of ;/2, etc.)
  S_    Supervisor instructions.  See pl-supervisor.c
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
				ISSUES


Sometime multiple instructions share variables. This   is done using the
code below, so we can at  least   identify  them easily. Ultimately, the
dependencies must be removed, probably  mostly   by  moving the reusable
code into functions.

	BEGIN_SHAREDVARS
	Decls
	VMI(...)
	VMI(...)
	END_SHAREDVARS
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#define BEGIN_SHAREDVARS {
#define END_SHAREDVARS   }


		 /*******************************
		 *	 ATTRIBUTED VARS	*
		 *******************************/

#ifdef O_ATTVAR
#define CHECK_WAKEUP \
	if ( unlikely(LD->alerted & ALERT_WAKEUP) ) \
	{ LD->alerted &= ~ALERT_WAKEUP; \
	  if ( *valTermRef(LD->attvar.head) ) \
	    goto wakeup; \
	}
#else
#define CHECK_WAKEUP (void)0
#endif


		 /*******************************
		 *	    DEBUGGING		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
D_BREAK implements break-points in the  code.   A  break-point is set by
replacing  an  instruction  by  a   D_BREAK  instruction.  The  orininal
instruction is saved in a table. replacedBreak() fetches it.

We simply switch to trace-mode, which will   trap the tracer on the next
breakable instruction (which is what D_BREAK is supposed to replace).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(D_BREAK, 0, 0, ())
{ code c = replacedBreak(PC-1);
  break_action a;
  int pop;				/* arithmetic stack to pop */

  switch(c)
  { case I_ENTER:
      ARGP = argFrameP(lTop, 0);	/* enter body mode */
      break;
  }

  DEBUG(CHK_SECURE, checkStacks(NULL));

  LD->query->next_environment = lTop;
  SAVE_REGISTERS(qid);
  setLTopInBody();
  DEBUG(0, memset(lTop, 0xbf, sizeof(word)*100));
  DEBUG(CHK_SECURE, checkStacks(NULL));
  a = callBreakHook(FR, BFR, PC-1, decode(c), &pop PASS_LD);
  switch ( a )
  { case BRK_TRACE:
      tracemode(TRUE, NULL);
      break;
    case BRK_DEBUG:
      debugmode(TRUE, NULL);
      break;
    default:
      break;
  }
  LOAD_REGISTERS(qid);
  lTop = LD->query->next_environment;
  LD->query->next_environment = NULL;
  DEBUG(CHK_SECURE, checkStacks(NULL));

  switch ( a )
  { case BRK_ERROR:
    case BRK_TRACE:
    case BRK_DEBUG:
    case BRK_CONTINUE:
      break;
    case BRK_CALL:
      if ( pop )			/* reset arithmetic stack */
      { popArgvArithStack(pop PASS_LD);
	AR_END();
      }
      PC = stepPC(PC-1);		/* skip the old calling instruction */
      updateAlerted(LD);
      VMI_GOTO(I_USERCALL0);
  }
  updateAlerted(LD);
  if ( a == BRK_ERROR )
    goto b_throw;

#if VMCODE_IS_ADDRESS
  { void *addr = (void *)c;
    goto *addr;
  }
#else
  thiscode = c;
  goto resumebreak;
#endif
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_NOP
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_NOP, 0, 0, ())
{ NEXT_INSTRUCTION;
}

		 /*******************************
		 *	     HEAD UNIFY		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_ATOM is used for an atom in the head of the clause. ARGP points to the
current argument to be matched. ARGP is   derefenced  and unified with a
constant argument. This is the same as   H_SMALLINT, except that we must
mark atoms if AGC is in progress because the AGC marker may already have
visited our stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
BEGIN_SHAREDVARS
word c;
Word k;

VMI(H_ATOM, 0, 1, (CA1_DATA))
{ IF_WRITE_MODE_GOTO(B_ATOM);

  c = (word)*PC++;
  pushVolatileAtom(c);
  goto h_const;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_SMALLINT is used for  small integer  in the head  of the clause.  ARGP
points to the current argument to  be   matched.  ARGP is derefenced and
unified with a constant argument.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_SMALLINT, 0, 1, (CA1_DATA))
{ IF_WRITE_MODE_GOTO(B_SMALLINT);

  c = (word)*PC++;
h_const:
  deRef2(ARGP, k);
  if ( *k == c )
  { ARGP++;
    NEXT_INSTRUCTION;
  }
  if ( canBind(*k) )
  { if ( !hasGlobalSpace(0) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(0, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }
    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  }
  CLAUSE_FAILED;
}
END_SHAREDVARS


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_NIL is used for [] in the head.  See H_ATOM for details.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_NIL, 0, 0, ())
{ word c;
  Word k;

  IF_WRITE_MODE_GOTO(B_NIL);

  c = ATOM_nil;
  deRef2(ARGP, k);
  if ( *k == c )
  { ARGP++;
    NEXT_INSTRUCTION;
  }
  if ( canBind(*k) )
  { if ( !hasGlobalSpace(0) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(0, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }
    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  }
  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_INTEGER: Long integer in  the  head.   Note  that  small  integers are
handled through H_SMALLINT. Copy to the  global stack if the argument is
variable, compare the numbers otherwise.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_INTEGER, 0, 1, (CA1_INTEGER))
{ Word k;

  IF_WRITE_MODE_GOTO(B_INTEGER);

  deRef2(ARGP, k);
  if ( canBind(*k) )
  { Word p;
    word c;
    union
    { int64_t val;
      word w[WORDS_PER_INT64];
    } cvt;
    Word vp = cvt.w;

    if ( !hasGlobalSpace(2+WORDS_PER_INT64) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(2+WORDS_PER_INT64, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }

    p = gTop;
    gTop += 2+WORDS_PER_INT64;
    c = consPtr(p, TAG_INTEGER|STG_GLOBAL);

    cvt.val = (int64_t)(intptr_t)*PC++;
    *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);
    cpInt64Data(p, vp);
    *p = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);

    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  } else if ( isBignum(*k) && valBignum(*k) == (intptr_t)*PC++ )
  { ARGP++;
    NEXT_INSTRUCTION;
  }

  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_INT64: 64-bit integer in the head. Only applicable for 32-bit hardware
as this is the same as H_INTEGER on 64-bit hardware.

TBD: Compile conditionally
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_INT64, 0, WORDS_PER_INT64, (CA1_INT64))
{ Word k;

  IF_WRITE_MODE_GOTO(B_INT64);

  deRef2(ARGP, k);
  if ( canBind(*k) )
  { Word p;
    word c;

    if ( !hasGlobalSpace(2+WORDS_PER_INT64) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(2+WORDS_PER_INT64, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }

    p = gTop;
    gTop += 2+WORDS_PER_INT64;
    c = consPtr(p, TAG_INTEGER|STG_GLOBAL);

    *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);
    cpInt64Data(p, PC);
    *p = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);

    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  } else if ( isBignum(*k) )
  { Word vk = valIndirectP(*k);
    size_t i;

    for(i=0; i<WORDS_PER_INT64; i++)
    { if ( *vk++ != (word)*PC++ )
	CLAUSE_FAILED;
    }
    ARGP++;
    NEXT_INSTRUCTION;
  }

  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_FLOAT: Float in the head. The  float   follows  the instruction and is
represented as a native C-double.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_FLOAT, 0, WORDS_PER_DOUBLE, (CA1_FLOAT))
{ Word k;

  IF_WRITE_MODE_GOTO(B_FLOAT);

  deRef2(ARGP, k);
  if ( canBind(*k) )
  { Word p;
    word c;

    if ( !hasGlobalSpace(2+WORDS_PER_DOUBLE) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(2+WORDS_PER_DOUBLE, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }

    p = gTop;
    gTop += 2+WORDS_PER_DOUBLE;
    c = consPtr(p, TAG_FLOAT|STG_GLOBAL);

    *p++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
    cpDoubleData(p, PC);
    *p++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);

    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  } else if ( isFloat(*k) )
  { Word p = valIndirectP(*k);

    switch(WORDS_PER_DOUBLE) /* depend on compiler to clean up */
    { case 2:
	if ( *p++ != *PC++ )
	  CLAUSE_FAILED;
      case 1:
	if ( *p++ == *PC++ )
	{ ARGP++;
	  NEXT_INSTRUCTION;
	}
	CLAUSE_FAILED;
      default:
	assert(0);
    }
  }

  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_MPZ and H_STRING are used for an mpz   number  and string in the head.
They are both implemented using the generic  code for indirects, but the
decompiler must be able to recognise  the   instruction  which is why we
have two instructions.

TBD:	Deal with multiple identical instructions
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_MPZ, 0, VM_DYNARGC, (CA1_MPZ))
{ SEPERATE_VMI;
  VMI_GOTO(H_STRING);
}


VMI(H_STRING, 0, VM_DYNARGC, (CA1_STRING))
{ Word k;

  IF_WRITE_MODE_GOTO(B_STRING);

  deRef2(ARGP, k);
  if ( canBind(*k) )
  { word c;
    size_t sz = gsizeIndirectFromCode(PC);

    if ( !hasGlobalSpace(sz) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(sz, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, k);
    }

    c = globalIndirectFromCode(&PC);
    bindConst(k, c);
    ARGP++;
    NEXT_INSTRUCTION;
  }
  if ( isIndirect(*k) && equalIndirectFromCode(*k, &PC) )
  { ARGP++;
    NEXT_INSTRUCTION;
  }
  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_VOID: A singleton variable in the   head.  Just increment the argument
pointer. Also generated for non-singleton   variables appearing on their
own in the head and  encountered  for   the  first  time.  Note that the
compiler suppresses H_VOID when there are   no other instructions before
I_ENTER or I_EXIT.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_VOID, 0, 0, ())
{ ARGP++;
  NEXT_INSTRUCTION;
}


VMI(H_VOID_N, 0, 1, (CA1_INTEGER))
{ ARGP += (int)*PC++;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_VAR: A variable in the head which is   not an anonymous one and is not
used for the first time. Invoke general unification between the argument
pointer and the variable, whose offset is given relative to the frame.

When in write-mode, ARGP points  to   uninitialised  data  on the global
stack that must be treated as a variable.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_VAR, 0, 1, (CA1_VAR))
{ Word k = varFrameP(FR, (int)*PC++);
  int rc;

  if ( umode == uwrite )
  { if ( LD->prolog_flag.occurs_check == OCCURS_CHECK_FALSE )
    { deRef(k);
      if ( isVar(*k) )
      { if ( k > ARGP )			/* k on local stack */
	{ if ( tTop+1 > tMax )
	  { int rc;

	    SAVE_REGISTERS(qid);
	    rc = ensureTrailSpace(1);
	    LOAD_REGISTERS(qid);
	    if ( rc != TRUE )
	    { raiseStackOverflow(rc);
	      THROW_EXCEPTION;
	    }
	    k = varFrameP(FR, (int)PC[-1]);
	    deRef(k);
	  }
	  setVar(*ARGP);
	  Trail(k, makeRefG(ARGP));
	} else
	{ *ARGP = makeRefG(k);		/* ARGP on global, so k also */
	}
      } else if ( isAttVar(*k) )
      { *ARGP = makeRefG(k);
      } else
      { *ARGP = *k;
      }

      ARGP++;
      NEXT_INSTRUCTION;
    } else
    { setVar(*ARGP);
    }
  }

  SAVE_REGISTERS(qid);
  rc = unify_ptrs(k, ARGP, ALLOW_GC|ALLOW_SHIFT PASS_LD);
  LOAD_REGISTERS(qid);
  if ( rc )
  { ARGP++;
    NEXT_INSTRUCTION;
  }
  if ( exception_term )
    THROW_EXCEPTION;
  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_FIRSTVAR: A variable  in  the  head,   which  is  not  anonymous,  but
encountered for the first time. So we know  that the variable is still a
variable. Copy or make a reference.  Trailing   is  not needed as we are
writing in this frame. As ARGP is pointing   in the argument list, it is
on the local stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_FIRSTVAR, 0, 1, (CA1_FVAR))
{ if ( umode == uwrite )
  { setVar(*ARGP);
    varFrame(FR, *PC++) = makeRefG(ARGP);
  } else
  { varFrame(FR, *PC++) = (needsRef(*ARGP) ? makeRef(ARGP) : *ARGP);
  }
  ARGP++;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_FUNCTOR: A functor in the head. If  the current argument is a variable
we instantiate it with a  new  term,   all  whose  arguments  are set to
variables. Otherwise we check the functor  definition. In both case ARGP
is pushed on the  argument  stack  and   set  to  point  to the leftmost
argument of the  term.  Note  that   the  instantiation  is  trailed  as
dereferencing might have caused we are now pointing in a parent frame or
the global stack (should we check? Saves trail! How often?).

H_RFUNCTOR: Right-most functor.  Achieves right-argument optimization of
the argument stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_FUNCTOR, 0, 1, (CA1_FUNC))
{ pushArgumentStack((Word)((intptr_t)(ARGP + 1)|umode));
  VMI_GOTO(H_RFUNCTOR);
}

VMI(H_RFUNCTOR, 0, 1, (CA1_FUNC))
{ functor_t f;
  Word p;

  IF_WRITE_MODE_GOTO(B_RFUNCTOR);

  f = (functor_t) *PC++;
  deRef2(ARGP, p);
  if ( canBind(*p) )
  { size_t arity = arityFunctor(f);
    Word ap;
    word c;

    if ( !hasGlobalSpace(1+arity) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(1+arity, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      deRef2(ARGP, p);
    }

    ap = gTop;
    gTop += 1+arity;
    c = consPtr(ap, TAG_COMPOUND|STG_GLOBAL);
    *ap++ = f;
    ARGP = ap;
    while(arity-->0)			/* must clear if we want to do GC */
      setVar(*ap++);
    bindConst(p, c);
    umode = uwrite;
    NEXT_INSTRUCTION;
  }
  if ( hasFunctor(*p, f) )
  { ARGP = argTermP(*p, 0);
    NEXT_INSTRUCTION;
  }
  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_LIST:  As H_FUNCTOR, but using ./2 as predefined functor.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_LIST, 0, 0, ())
{ pushArgumentStack((Word)((intptr_t)(ARGP + 1)|umode));

  VMI_GOTO(H_RLIST);
}


VMI(H_RLIST, 0, 0, ())
{ Word p;
  word w;

  IF_WRITE_MODE_GOTO(B_RLIST);

  deRef2(ARGP, p);
  w = *p;

  switch(tag(w))
  { case TAG_COMPOUND:
      if ( valueTerm(w)->definition == FUNCTOR_dot2 )
      { ARGP = argTermP(w, 0);
	NEXT_INSTRUCTION;
      }
      CLAUSE_FAILED;
    case TAG_VAR:
    case TAG_ATTVAR:
    { Word ap;
      word c;

      if ( !hasGlobalSpace(3) )
      { int rc;

	SAVE_REGISTERS(qid);
	rc = ensureGlobalSpace(3, ALLOW_GC);
	LOAD_REGISTERS(qid);
	if ( rc != TRUE )
	{ raiseStackOverflow(rc);
	  THROW_EXCEPTION;
	}
	deRef2(ARGP, p);
      }

      ap = gTop;
      gTop += 3;
      c = consPtr(ap, TAG_COMPOUND|STG_GLOBAL);
      *ap++ = FUNCTOR_dot2;
      setVar(ap[0]);			/* must clear for GC */
      setVar(ap[1]);
      bindConst(p, c);
      ARGP = ap;
      umode = uwrite;
      NEXT_INSTRUCTION;
    }
    default:
      CLAUSE_FAILED;
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_POP: Pop the saved argument pointer pushed by H_FUNCTOR and H_LIST.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_POP, 0, 0, ())
{ ARGP = *--aTop;
  umode = ((int)(uintptr_t)ARGP & uwrite);
  ARGP = (Word)((intptr_t)ARGP&~uwrite);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
H_LIST_FF: [Var1|Var2] in the head where both   Var1 and Var2 appear for
the  first  time.  This  appears    quite  commonly  in  list-processing
predicates:

	pred([], ...).
	pred([H|T], ...) :-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(H_LIST_FF, 0, 2, (CA1_FVAR,CA1_FVAR))
{ Word p;

  if ( umode == uwrite )
  { p = ARGP;
    goto write;
  } else
  { deRef2(ARGP, p);

    if ( isList(*p) )
    { p = argTermP(*p, 0);
      varFrame(FR, *PC++) = (needsRef(*p) ? makeRef(p) : *p);
      p++;
      varFrame(FR, *PC++) = (needsRef(*p) ? makeRef(p) : *p);
    } else if ( canBind(*p) )
    { word c;
      Word ap;

    write:
      if ( !hasGlobalSpace(3) )
      { int rc;

	SAVE_REGISTERS(qid);
	rc = ensureGlobalSpace(3, ALLOW_GC);
	LOAD_REGISTERS(qid);
	if ( rc != TRUE )
	{ raiseStackOverflow(rc);
	  THROW_EXCEPTION;
	}
	if ( umode == uwrite )
	  p = ARGP;
	else
	  deRef2(ARGP, p);
      }

      ap = gTop;
      gTop = ap+3;
      c = consPtr(ap, TAG_COMPOUND|STG_GLOBAL);
      *ap++ = FUNCTOR_dot2;
      setVar(*ap); varFrame(FR, *PC++) = makeRefG(ap); ap++;
      setVar(*ap); varFrame(FR, *PC++) = makeRefG(ap);
      if ( umode == uwrite )
	*p = c;
      else
	bindConst(p, c);
    } else
    { CLAUSE_FAILED;
    }
  }

  ARGP++;
  NEXT_INSTRUCTION;
}


		 /*******************************
		 *	 BODY UNIFICATION	*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_ATOM, B_SMALLINT, B_NIL: An atomic constant in the body of a clause. We
know that ARGP is pointing to a not yet instantiated argument of the next
frame and therefore can just fill the argument. Trailing is not needed as
this is above the stack anyway.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_ATOM, 0, 1, (CA1_DATA))
{ word c = (word)*PC++;
  pushVolatileAtom(c);
  *ARGP++ = c;
  NEXT_INSTRUCTION;
}

VMI(B_SMALLINT, 0, 1, (CA1_DATA))
{ *ARGP++ = (word)*PC++;
  NEXT_INSTRUCTION;
}

VMI(B_NIL, 0, 0, ())
{ *ARGP++ = ATOM_nil;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_INTEGER: Long following PC for integers   that  cannot be expressed as
tagged integer.

TBD:	Merge the code writing longs to the stack
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_INTEGER, 0, 1, (CA1_INTEGER))
{ Word p;
  union
  { int64_t val;
    word w[WORDS_PER_INT64];
  } cvt;
  Word vp = cvt.w;

  if ( !hasGlobalSpace(2+WORDS_PER_INT64) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(2+WORDS_PER_INT64, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  p = gTop;
  gTop += 2+WORDS_PER_INT64;

  cvt.val = (int64_t)(intptr_t)*PC++;
  *ARGP++ = consPtr(p, TAG_INTEGER|STG_GLOBAL);
  *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);
  cpInt64Data(p, vp);
  *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_INT64: 64-bit (int64_t) in the body.  See H_INT64
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_INT64, 0, WORDS_PER_INT64, (CA1_INT64))
{ Word p;
  size_t i;

  if ( !hasGlobalSpace(2+WORDS_PER_INT64) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(2+WORDS_PER_INT64, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  p = gTop;
  gTop += 2+WORDS_PER_INT64;

  *ARGP++ = consPtr(p, TAG_INTEGER|STG_GLOBAL);
  *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);
  for(i=0; i<WORDS_PER_INT64; i++)
    *p++ = (word)*PC++;
  *p++ = mkIndHdr(WORDS_PER_INT64, TAG_INTEGER);

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_FLOAT: Float in the  body.  PC  is   followed  by  a  double in native
representation.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_FLOAT, 0, WORDS_PER_DOUBLE, (CA1_FLOAT))
{ Word p;

  if ( !hasGlobalSpace(2+WORDS_PER_DOUBLE) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(2+WORDS_PER_DOUBLE, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  p = gTop;
  gTop += 2+WORDS_PER_DOUBLE;

  *ARGP++ = consPtr(p, TAG_FLOAT|STG_GLOBAL);
  *p++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
  cpDoubleData(p, PC);
  *p++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_MPZ: MPZ number in body
B_STRING: string in body

Both copy following indirect to the  global   stack.  See also H_MPZ and
H_STRING.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_MPZ, 0, VM_DYNARGC, (CA1_MPZ))
{ SEPERATE_VMI;
  VMI_GOTO(B_STRING);
}

VMI(B_STRING, 0, VM_DYNARGC, (CA1_STRING))
{ size_t sz = gsizeIndirectFromCode(PC);

  if ( !hasGlobalSpace(sz) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(sz, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  *ARGP++ = globalIndirectFromCode(&PC);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_ARGVAR: A variable in the body which is   not an anonymous one, is not
used for the first time and is nested in a term (with B_FUNCTOR). We now
know that *ARGP is a variable, so  we   either  copy the value or make a
reference. The difference between this one and B_VAR is the direction of
the reference link in case *k turns out to be variable.

ARGP is pointing into the term on the global stack we are creating.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_ARGVAR, 0, 1, (CA1_VAR))
{ Word k = varFrameP(FR, *PC++);

  deRef(k);
  if ( isVar(*k) )
  { if ( ARGP < k )
    { if ( tTop+1 > tMax )
      { int rc;

	SAVE_REGISTERS(qid);
	rc = ensureTrailSpace(1);
	LOAD_REGISTERS(qid);
	if ( rc != TRUE )
	{ raiseStackOverflow(rc);
	  assert(exception_term);
	  THROW_EXCEPTION;
	}
	k = varFrameP(FR, (int)PC[-1]);
	deRef(k);
      }
      setVar(*ARGP);
      Trail(k, makeRefG(ARGP++));
      NEXT_INSTRUCTION;
    }
    *ARGP++ = makeRefG(k);	/* both on global stack! */
#ifdef O_ATTVAR
  } else if ( isAttVar(*k) )
  { *ARGP++ = makeRefG(k);
#endif
  } else
  { *ARGP++ = *k;
  }

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_VAR, B_VAR<N>: A variable in the body   which  is not an anonymous one
and is not used for  the  first  time.   We  now  know  that  *ARGP is a
variable, so we either copy the value   or make a reference. Trailing is
not needed as we are writing above the stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_VAR0, 0, 0, ())
{ *ARGP++ = linkVal(varFrameP(FR, VAROFFSET(0)));
  NEXT_INSTRUCTION;
}

VMI(B_VAR1, 0, 0, ())
{ *ARGP++ = linkVal(varFrameP(FR, VAROFFSET(1)));
  NEXT_INSTRUCTION;
}

VMI(B_VAR2, 0, 0, ())
{ *ARGP++ = linkVal(varFrameP(FR, VAROFFSET(2)));
  NEXT_INSTRUCTION;
}

VMI(B_VAR, 0, 1, (CA1_VAR))
{ int n = (int)*PC++;

  *ARGP++ = linkVal(varFrameP(FR, n));
  NEXT_INSTRUCTION;
}


#ifdef O_COMPILE_IS
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_UNIFY_VAR, B_UNIFY_EXIT: Unification in the body. We compile A = Term
into one of the following:

    Normal:			    A is firstvar:
	B_UNIFY_VAR <A>			B_UNIFY_FIRSTVAR <A>
	<head unify instructions>	<body unify instructions>
	B_UNIFY_EXIT			B_UNIFY_EXIT

We  need  B_UNIFY_FIRSTVAR  for   the   debugger    as   well   as   for
clearUninitialisedVarsFrame() in pl-gc.c. When in   debug mode we simply
create a frame for =/2 and call it. Note that the `slow unify' mode must
be consistently applied in B_UNIFY_VAR and B_UNIFY_EXIT, which is why we
copy the global value into a local variable.

TBD: B_UNIFY_CONST <var>, <const>
     B_UNIFY_VAR <var1>, <var2>

Note  that  the  B_UNIFY_FIRSTVAR  assumes  write   mode,  but  this  is
unimportant because the compiler generates write (B_*) instructions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_UNIFY_FIRSTVAR, VIF_BREAK, 1, (CA1_FVAR))
{ ARGP = varFrameP(FR, (int)*PC++);
  setVar(*ARGP);			/* needed for GC */
  goto unify_var_cont;
}


VMI(B_UNIFY_VAR, VIF_BREAK, 1, (CA1_VAR))
{ ARGP = varFrameP(FR, (int)*PC++);

unify_var_cont:
  if ( (slow_unify=LD->slow_unify) )
  { Word k = ARGP;

    ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(k);
    setVar(*ARGP);
    umode = uwrite;			/* must write for GC to work */
    NEXT_INSTRUCTION;
  }

  umode = uread;			/* needed? */
  NEXT_INSTRUCTION;
}


VMI(B_UNIFY_EXIT, 0, 0, ())
{ ARGP = argFrameP(lTop, 0);
  if ( slow_unify )
  { NFR = lTop;
    DEF = GD->procedures.equals2->definition;
    setNextFrameFlags(NFR, FR);
    goto normal_call;
  }

  CHECK_WAKEUP;				/* only for non-first-var */
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
	B_UNIFY_[FV][FV] VAR1 VAR2
Unify two variables.  F stands for a first-var; V for any other var
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_UNIFY_FF, VIF_BREAK, 2, (CA1_FVAR,CA1_FVAR))
{ Word v1 = varFrameP(FR, (int)*PC++);
  Word v2 = varFrameP(FR, (int)*PC++);

  if ( LD->slow_unify )
  { setVar(*v1);
    setVar(*v2);
    ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = linkVal(v2);
    goto debug_equals2;
  }

  setVar(*v1);
  *v2 = makeRefL(v1);

  NEXT_INSTRUCTION;
}


/* B_UNIFY_VF is the same as B_UNIFY_FV, but the arguments
 * are swapped by the compiler.  The distinction is needed
 * to allow the decompiler return the correct argument order.
 * Having swapped V1=V2 is hard to compensate for in the
 * GUI tracer.
 */

VMI(B_UNIFY_VF, VIF_BREAK, 2, (CA1_FVAR,CA1_VAR))
{ SEPERATE_VMI;
  VMI_GOTO(B_UNIFY_FV);
}


VMI(B_UNIFY_FV, VIF_BREAK, 2, (CA1_FVAR,CA1_VAR))
{ Word f = varFrameP(FR, (int)*PC++);
  Word v = varFrameP(FR, (int)*PC++);

  if ( LD->slow_unify )
  { setVar(*f);
    ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(f);
    *ARGP++ = linkVal(v);
    goto debug_equals2;
  }

  *f = linkVal(v);

  NEXT_INSTRUCTION;
}


VMI(B_UNIFY_VV, VIF_BREAK, 2, (CA1_VAR,CA1_VAR))
{ int rc;
  Word v1 = varFrameP(FR, (int)*PC++);
  Word v2 = varFrameP(FR, (int)*PC++);

  if ( LD->slow_unify )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = linkVal(v2);
  debug_equals2:
    NFR = lTop;
    DEF = GD->procedures.equals2->definition;
    setNextFrameFlags(NFR, FR);
    goto normal_call;
  }

  SAVE_REGISTERS(qid);
  rc = unify_ptrs(v1, v2, ALLOW_GC|ALLOW_SHIFT PASS_LD);
  LOAD_REGISTERS(qid);
  if ( rc )
  { CHECK_WAKEUP;
    NEXT_INSTRUCTION;
  }
  if ( exception_term )
    THROW_EXCEPTION;

  BODY_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_UNIFY_FC: Unify first variable with a constant.  Always succeeds, no
need for wakeup.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_UNIFY_FC, VIF_BREAK, 2, (CA1_FVAR, CA1_DATA))
{ Word v1 = varFrameP(FR, (int)*PC++);
  word c = (word)*PC++;

  if ( LD->slow_unify )
  { setVar(*v1);
    ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = c;
    goto debug_equals2;
  }

  *v1 = c;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_UNIFY_VC: Unify a variable (not first) with a constant in the body.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_UNIFY_VC, VIF_BREAK, 2, (CA1_VAR, CA1_DATA))
{ Word k = varFrameP(FR, (int)*PC++);
  word c = (word)*PC++;

  if ( LD->slow_unify )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(k);
    *ARGP++ = c;
    goto debug_equals2;
  }

  deRef(k);
  if ( *k == c )
    NEXT_INSTRUCTION;
  if ( canBind(*k) )
  { if ( !hasGlobalSpace(0) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(0, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }
      k = varFrameP(FR, (int)PC[-2]);
      deRef(k);
    }

    bindConst(k, c);
    CHECK_WAKEUP;
    NEXT_INSTRUCTION;
  }
  CLAUSE_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_EQ_VV: translation of	Var1 == Var2
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_EQ_VV, VIF_BREAK, 2, (CA1_VAR,CA1_VAR))
{ Word v1 = varFrameP(FR, (int)*PC++);
  Word v2 = varFrameP(FR, (int)*PC++);
  int rc;

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = linkVal(v2);
  debug_eq_vv:
    NFR = lTop;
    DEF = GD->procedures.strict_equal2->definition;
    setNextFrameFlags(NFR, FR);
    goto normal_call;
  }
#endif

  if ( (rc=compareStandard(v1, v2, TRUE PASS_LD)) == 0 )
    NEXT_INSTRUCTION;
  if ( rc == CMP_ERROR )
    THROW_EXCEPTION;

  FASTCOND_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_EQ_VC Var == constant
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_EQ_VC, VIF_BREAK, 2, (CA1_VAR,CA1_DATA))
{ Word v1 = varFrameP(FR, (int)*PC++);
  word c  = (word)*PC++;

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = c;
    goto debug_eq_vv;
  }
#endif

  deRef(v1);
  if ( *v1 == c )
    NEXT_INSTRUCTION;

  FASTCOND_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_NEQ_VV: translation of Var1 \== Var2
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_NEQ_VV, VIF_BREAK, 2, (CA1_VAR,CA1_VAR))
{ Word v1 = varFrameP(FR, (int)*PC++);
  Word v2 = varFrameP(FR, (int)*PC++);
  int rc;

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = linkVal(v2);
  debug_neq_vv:
    NFR = lTop;
    DEF = GD->procedures.not_strict_equal2->definition;
    setNextFrameFlags(NFR, FR);
    goto normal_call;
  }
#endif

  if ( (rc=compareStandard(v1, v2, TRUE PASS_LD)) == 0 )
    FASTCOND_FAILED;
  if ( rc == CMP_ERROR )
    THROW_EXCEPTION;

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_NEQ_VC Var == constant
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_NEQ_VC, VIF_BREAK, 2, (CA1_VAR,CA1_DATA))
{ Word v1 = varFrameP(FR, (int)*PC++);
  word c  = (word)*PC++;

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { ARGP = argFrameP(lTop, 0);
    *ARGP++ = linkVal(v1);
    *ARGP++ = c;
    goto debug_neq_vv;
  }
#endif

  deRef(v1);
  if ( *v1 != c )
    NEXT_INSTRUCTION;

  FASTCOND_FAILED;
}


#endif /*O_COMPILE_IS*/


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_ARGFIRSTVAR: A variable in the body nested  in a term, encountered for
the first time. We now know both   *ARGP and the variable are variables.
ARGP points to the argument of a term on the global stack. The reference
should therefore go from k to ARGP.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_ARGFIRSTVAR, 0, 1, (CA1_FVAR))
{ setVar(*ARGP);
  varFrame(FR, *PC++) = makeRefG(ARGP++);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_FIRSTVAR: A variable in the body, encountered   for the first time. We
now know both *ARGP and the variable  are variables. We set the variable
to be a variable (it is uninitialised   memory) and make a reference. No
trailing needed as we are writing in this and the next frame.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_FIRSTVAR, 0, 1, (CA1_FVAR))
{ Word k = varFrameP(FR, *PC++);

  setVar(*k);
  *ARGP++ = makeRefL(k);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_VOID: A singleton variable in  the  body.   Ensure  the  argument is a
variable.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_VOID, 0, 0, ())
{ setVar(*ARGP++);
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_FUNCTOR: A functor in the body. As we   don't  expect ARGP to point to
initialised memory while in body mode  we   just  allocate the term, but
don't initialise the arguments to variables. Allocation is done in place
to avoid a function call.

B_RFUNCTOR: right-argument recursive version of B_FUNCTOR
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_FUNCTOR, 0, 1, (CA1_FUNC))
{ pushArgumentStack(ARGP+1);
  VMI_GOTO(B_RFUNCTOR);
}


VMI(B_RFUNCTOR, 0, 1, (CA1_FUNC))
{ functor_t f = (functor_t) *PC++;
  size_t arity = arityFunctor(f);
  Word ap;

  if ( !hasGlobalSpace(1+arity) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(1+arity, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  *ARGP = consPtr(gTop, TAG_COMPOUND|STG_GLOBAL);
  ARGP = gTop;
  *ARGP++ = f;
  for(ap=ARGP; arity-->0;)		/* must clear if we want to do GC */
    setVar(*ap++);
  gTop = ap;

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
B_LIST: Same as B_FUNCTOR for ./2
B_RLIST: Right-argument recursive B_LIST
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_LIST, 0, 0, ())
{ pushArgumentStack(ARGP+1);
  VMI_GOTO(B_RLIST);
}


VMI(B_RLIST, 0, 0, ())
{ if ( !hasGlobalSpace(3) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = ensureGlobalSpace(3, ALLOW_GC);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  *ARGP = consPtr(gTop, TAG_COMPOUND|STG_GLOBAL);
  ARGP = gTop;
  *ARGP++ = FUNCTOR_dot2;
  setVar(ARGP[0]);
  setVar(ARGP[1]);
  gTop = ARGP+2;

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_POPF: Pop the saved argument pointer (see H_FUNCTOR and B_FUNCTOR).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_POP, 0, 0, ())
{ ARGP = *--aTop;
  NEXT_INSTRUCTION;
}


		 /*******************************
		 *	       ENTER		*
		 *******************************/


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_ENTER: Enter the body of the clause.   This instruction is left out if
the clause has no body. The basic task   of  this instruction is to move
ARGP from the argument part of this frame  into the argument part of the
child frame to be built. `BFR' (the last frame with alternatives) is set
to  this  frame  if  this  frame  has  alternatives,  otherwise  to  the
backtrackFrame of this frame.

If this frame has no alternatives it is possible to  put  the  backtrack
frame  immediately  on  the backtrack frame of this frame.  This however
makes debugging much more  difficult  as  the  system  will  do  a  deep
backtrack without showing the fail ports explicitely.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_ENTER, VIF_BREAK, 0, ())
{ ARGP = argFrameP(lTop, 0);

  if ( unlikely(LD->alerted) )
  {
#if O_DEBUGGER
    if ( debugstatus.debugging )
    { int action;

      SAVE_REGISTERS(qid);
      clearUninitialisedVarsFrame(FR, PC);
      action = tracePort(FR, BFR, UNIFY_PORT, PC PASS_LD);
      LOAD_REGISTERS(qid);

      switch( action )
      { case ACTION_RETRY:
	  goto retry;
	case ACTION_FAIL:
	  FRAME_FAILED;
	case ACTION_ABORT:
	  THROW_EXCEPTION;
      }
    }
#endif /*O_DEBUGGER*/

    CHECK_WAKEUP;
  }
  NEXT_INSTRUCTION;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CONTEXT is used by  non-meta  predicates   that  are  compiled  into a
different  module  using  <module>:<head>  :-    <body>.  The  I_CONTEXT
instruction immediately follows the I_ENTER. The argument is the module.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CONTEXT, 0, 1, (CA1_MODULE))
{ Module m = (Module)*PC++;

  setContextModule(FR, m);

  NEXT_INSTRUCTION;
}

		 /*******************************
		 *	       CALLING		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CALL forms the normal  code  generated   by  the  compiler for calling
predicates. The arguments are already written   in the frame starting at
`lTop'.

The task of I_CALL is to  save  necessary  information  in  the  current
frame,  fill  the next frame and initialise the machine registers.  Then
execution can continue at `next_instruction'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALL, VIF_BREAK, 1, (CA1_PROC))
{ Procedure proc = (Procedure) *PC++;

  NFR = lTop;
  setNextFrameFlags(NFR, FR);
  DEF = proc->definition;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This is the common part of the call variations.  By now the following is
true:

  - NFR			Points to new frame
  - arguments		filled
  - DEF			filled with predicate to call
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

normal_call:

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Initialise those slots of the frame that are common to Prolog predicates
and foreign ones.  There might be some possibilities for optimisation by
delaying these initialisations till they are really  needed  or  because
the information they are calculated from is destroyed.  This probably is
not worthwile.

Note: we are working above `lTop' here!!   We restore this as quickly as
possible to be able to call-back to Prolog.

(*) If we do not resolve here,  the handleSignals() may resolve the same
procedure and deallocate our temporary version if threading is not used.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  NFR->parent         = FR;
  setFramePredicate(NFR, DEF);		/* TBD */
  NFR->programPointer = PC;		/* save PC in child */
  NFR->clause         = NULL;		/* for save atom-gc */
  environment_frame = FR = NFR;		/* open the frame */

  if ( unlikely(addPointer(lTop, LOCAL_MARGIN) > (void*)lMax) )
  { int rc;

    lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
    SAVE_REGISTERS(qid);
    rc = growLocalSpace__LD(LOCAL_MARGIN, ALLOW_SHIFT PASS_LD);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { rc = raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

depart_continue:
retry_continue:
  setGenerationFrame(FR);
#ifdef O_PROFILE
  FR->prof_node = NULL;
#endif
  LD->statistics.inferences++;

#ifdef O_DEBUGLOCAL
{ Word ap = argFrameP(FR, DEF->functor->arity);
  int n;

  for(n=50; --n; )
    *ap++ = (word)(((char*)ATOM_nil) + 1);
}
#endif

  if ( unlikely(LD->alerted) )
  {					/* play safe */
    lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);

    if ( is_signalled(PASS_LD1) )
    { SAVE_REGISTERS(qid);
      DEF = getProcDefinedDefinition(DEF PASS_LD); /* see (*) above */
      LOAD_REGISTERS(qid);
      if ( FR->predicate != DEF )		/* auto imported/loaded */
      { setFramePredicate(FR, DEF);
	setGenerationFrame(FR);
      }
      SAVE_REGISTERS(qid);
      handleSignals(PASS_LD1);
      LOAD_REGISTERS(qid);
      if ( exception_term )
      { CL = NULL;

	enterDefinition(DEF);
					/* The catch is not yet installed, */
					/* so we ignore it */
	if ( FR->predicate == PROCEDURE_catch3->definition )
	  set(FR, FR_CATCHED);

	THROW_EXCEPTION;
      }
    }

#ifdef O_PROFILE
    if ( LD->profile.active )
      FR->prof_node = profCall(DEF PASS_LD);
#endif

#ifdef O_LIMIT_DEPTH
    { unsigned int depth = levelFrame(FR);

      if ( depth > depth_reached )
	depth_reached = depth;
      if ( depth > depth_limit )
      { DEBUG(2, Sdprintf("depth-limit\n"));

	if ( debugstatus.debugging )
	  newChoice(CHP_DEBUG, FR PASS_LD);
	FRAME_FAILED;
      }
    }
#endif

#ifdef O_INFERENCE_LIMIT
    if ( LD->statistics.inferences >= LD->inference_limit.limit )
    { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
      SAVE_REGISTERS(qid);
      raiseInferenceLimitException();
      LOAD_REGISTERS(qid);
      if ( exception_term )
	THROW_EXCEPTION;
    }
#endif

#if O_DEBUGGER
    if ( debugstatus.debugging )
    { int rc;

      lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
      SAVE_REGISTERS(qid);
      DEF = getProcDefinedDefinition(DEF PASS_LD);
      LOAD_REGISTERS(qid);
      if ( FR->predicate != DEF )		/* auto imported/loaded */
      { setFramePredicate(FR, DEF);
	setGenerationFrame(FR);
#ifdef O_PROFILE
        if ( FR->prof_node )
	  profSetHandle(FR->prof_node, DEF);
#endif
        goto retry_continue;
      }
      set(FR, FR_INBOX);

      SAVE_REGISTERS(qid);
      rc = tracePort(FR, BFR, CALL_PORT, NULL PASS_LD);
      LOAD_REGISTERS(qid);
      switch( rc )
      { case ACTION_FAIL:   FRAME_FAILED;
	case ACTION_IGNORE: VMI_GOTO(I_EXIT);
	case ACTION_ABORT:  THROW_EXCEPTION;
	case ACTION_RETRY:
	  if ( debugstatus.retryFrame )
	    goto retry;			/* otherwise retrying the call-port */
					/* is a no-op */
      }
    }
#endif /*O_DEBUGGER*/
  }

  PC = DEF->codes;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_DEPART: implies it is the last subclause   of  the clause. This is the
entry point for last call optimisation.

(*) Handling undefined predicates here is very tricky because we need to
destroy de clause pointer before   leaveDefinition() to get asynchronous
atom-gc ok, but this destroys  the  environment   for  normal  GC if the
undefined predicate trapping code starts a GC. Therefore, undefined code
runs normal I_CALL. This isn't too  bad,   as  it only affects the first
call.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_DEPART, VIF_BREAK, 1, (CA1_PROC))
{ if ( (void *)BFR <= (void *)FR && truePrologFlag(PLFLAG_LASTCALL) )
  { Procedure proc = (Procedure) *PC++;

    if ( !proc->definition->impl.any.defined &&	/* see (*) */
	 false(proc->definition, PROC_DEFINED) )
    { PC--;
      VMI_GOTO(I_CALL);
    }

    if ( true(FR, FR_WATCHED) )
    { LD->query->next_environment = lTop;
      lTop = (LocalFrame)ARGP;		/* just pushed arguments, so top */
      SAVE_REGISTERS(qid);
      frameFinished(FR, FINISH_EXIT PASS_LD);
      LOAD_REGISTERS(qid);
      lTop = LD->query->next_environment;
      LD->query->next_environment = NULL;
      if ( exception_term )
	THROW_EXCEPTION;
    }

    FR->clause = NULL;			/* for save atom-gc */
    leaveDefinition(DEF);
    DEF = proc->definition;
    if ( true(DEF, P_TRANSPARENT) )
    { FR->context = contextModule(FR);
      FR->level++;
      clear(FR, FR_CLEAR_NEXT);
      set(FR, FR_CONTEXT);
    } else
    { setNextFrameFlags(FR, FR);
    }
    if ( true(DEF, HIDE_CHILDS) )
      set(FR, FR_HIDE_CHILDS);

    setFramePredicate(FR, DEF);
    copyFrameArguments(lTop, FR, DEF->functor->arity PASS_LD);

    END_PROF();
    START_PROF(DEPART_CONTINUE, "DEPART_CONTINUE");
    goto depart_continue;
  }

  VMI_GOTO(I_CALL);
}


#ifdef O_CALL_AT_MODULE
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_DEPARTATM: procedure-module, context-module, procedure
See I_CALLATM for details.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
VMI(I_DEPARTATM, VIF_BREAK, 3, (CA1_MODULE, CA1_MODULE, CA1_PROC))
{ PC++;						/* Ignore :-qualifier */
  VMI_GOTO(I_DEPARTM);
}
#endif


VMI(I_DEPARTM, VIF_BREAK, 2, (CA1_MODULE, CA1_PROC))
{ if ( (void *)BFR > (void *)FR || !truePrologFlag(PLFLAG_LASTCALL) )
  { VMI_GOTO(I_CALLM);
  } else
  { Module m = (Module)*PC++;

    setContextModule(FR, m);
    VMI_GOTO(I_DEPART);
  }
}


		 /*******************************
		 *	       EXIT		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Leave the clause:

  - update reference of current clause
    If there are no alternatives left and BFR  <=  frame  we  will
    never  return  at  this clause and can decrease the reference count.
    If BFR > frame the backtrack frame is a child of  this  frame,
    so  this frame can become active again and we might need to continue
    this clause.

  - update BFR
    `BFR' will become the backtrack frame of other childs  of  the
    parent  frame  in which we are going to continue.  If this frame has
    alternatives and is newer than the old backFrame `BFR'  should
    become this frame.

    If there are no alternatives and  the  BFR  is  this  one  the
    BFR can become this frame's backtrackframe.

  - Update `lTop'.
    lTop can be set to this frame if there are no alternatives  in  this
    frame  and  BFR  is  older  than this frame (e.g. there are no
    frames with alternatives that are newer).

  - restore machine registers from parent frame
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_EXIT: End of clauses for normal Prolog clauses.

TBD: Insert a layer in between, so   this  never has to handle call-back
from C.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_EXIT, VIF_BREAK, 0, ())
{ LocalFrame leave;

  if ( unlikely(LD->alerted) )
  {
#if O_DEBUGGER
    if ( debugstatus.debugging )
    { int action;

      SAVE_REGISTERS(qid);
      action = tracePort(FR, BFR, EXIT_PORT, PC PASS_LD);
      LOAD_REGISTERS(qid);

      switch( action )
      { case ACTION_RETRY:
	  goto retry;
	case ACTION_FAIL:
	  discardChoicesAfter(FR, FINISH_CUT PASS_LD);
	  FRAME_FAILED;
	case ACTION_ABORT:
	  THROW_EXCEPTION;
      }

      if ( BFR && BFR->type == CHP_DEBUG && BFR->frame == FR )
	BFR = BFR->parent;
    }
#endif /*O_DEBUGGER*/
  }

  if ( (void *)BFR <= (void *)FR )	/* deterministic */
  { leave = true(FR, FR_WATCHED) ? FR : NULL;
    FR->clause = NULL;			/* leaveDefinition() destroys clause */
    leaveDefinition(DEF);		/* dynamic pred only */
    lTop = FR;
    DEBUG(3, Sdprintf("Deterministic exit of %s, lTop = #%ld\n",
		      predicateName(FR->predicate), loffset(lTop)));
  } else
  { leave = NULL;
    clear(FR, FR_INBOX);
  }

  PC = FR->programPointer;
  environment_frame = FR = FR->parent;
  DEF = FR->predicate;
  ARGP = argFrameP(lTop, 0);
  Profile(profResumeParent(FR->prof_node PASS_LD));
  if ( leave )
  { SAVE_REGISTERS(qid);
    frameFinished(leave, FINISH_EXIT PASS_LD);
    LOAD_REGISTERS(qid);
    if ( exception_term )
      THROW_EXCEPTION;
  }

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_EXITFACT: generated to close a fact. The   reason for not generating a
plain I_EXIT is first of all that the actual sequence should be I_ENTER,
I_EXIT,  and  just  optimising   to    I_EXIT   looses   the  unify-port
interception. Second, there should be some room for optimisation here.

The exit_checking_wakeup is referenced from I_FEXITNDET.   If there is a
wakeup and our current goal is  deterministic,   we  first pop it (i.e.,
some sort of last-call optimization).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_EXITFACT, 0, 0, ())
{ if ( unlikely(LD->alerted) )
  {
#if O_DEBUGGER
    if ( debugstatus.debugging )
    { int action;

      SAVE_REGISTERS(qid);
      action = tracePort(FR, BFR, UNIFY_PORT, PC PASS_LD);
      LOAD_REGISTERS(qid);

      switch( action )
      { case ACTION_RETRY:
	  goto retry;
	case ACTION_ABORT:
	  THROW_EXCEPTION;
      }
    }
#endif /*O_DEBUGGER*/
  exit_checking_wakeup:
#ifdef O_ATTVAR
    if ( LD->alerted & ALERT_WAKEUP )
    { LD->alerted &= ~ALERT_WAKEUP;

      if ( *valTermRef(LD->attvar.head) )
      { PC = SUPERVISOR(exit);
	goto wakeup;
      }
    }
#endif
  }

  VMI_GOTO(I_EXIT);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Created for the return of the toplevel query.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_EXITQUERY, 0, 0, ())
{ assert(!FR->parent);

  QF = QueryFromQid(qid);		/* may be shifted: recompute */
  QF->solutions++;

  assert(FR == &QF->top_frame);

  if ( BFR == &QF->choice )		/* No alternatives */
  { set(QF, PL_Q_DETERMINISTIC);
    lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
    FR->clause = NULL;

    if ( true(FR, FR_WATCHED) )
    { SAVE_REGISTERS(qid);
      frameFinished(FR, FINISH_EXIT PASS_LD);
      LOAD_REGISTERS(qid);
    }
  }

#ifdef O_PROFILE
  if ( LD->profile.active )
  { LocalFrame parent = parentFrame(FR);

    if ( parent )
      profResumeParent(parent->prof_node PASS_LD);
    else
      profResumeParent(NULL PASS_LD);
  }
#endif

  QF->foreign_frame = PL_open_foreign_frame();
  assert(LD->exception.throw_environment == &throw_env);
  LD->exception.throw_environment = throw_env.parent;

#define DET_EXIT (PL_Q_DETERMINISTIC|PL_Q_EXT_STATUS)
  return (QF->flags&DET_EXIT)==DET_EXIT ? PL_S_LAST : TRUE;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_YIELD: Yield control from this engine. This  VMI fetches the first and
second argument. The second must be an integer. PL_next_solution() exits
with code, providing Term through PL_yielded. Calling PL_next_solution()
again resumes the VM.

'$engine_yield'(Term, Code) :-
	'$yield'.

'$yield' translates to I_YIELD
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_YIELD, VIF_BREAK, 0, ())
{ Word p;

  QF = QueryFromQid(qid);
  if ( !(QF->flags&PL_Q_ALLOW_YIELD) )
  { PL_error(NULL, 0, "not an engine", ERR_PERMISSION_VMI, "I_YIELD");
    THROW_EXCEPTION;
  }
  if ( (void*)BFR < (void*)FR )
    lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
  ARGP = argFrameP(lTop, 0);
  SAVE_REGISTERS(qid);
  DEBUG(CHK_SECURE, checkStacks(NULL));

  QF->foreign_frame = PL_open_foreign_frame();
  QF->yield.term = PL_new_term_ref();
  *valTermRef(QF->yield.term) = linkVal(argFrameP(FR, 0));
  DEBUG(CHK_SECURE, checkStacks(NULL));

  assert(LD->exception.throw_environment == &throw_env);
  LD->exception.throw_environment = throw_env.parent;

  p = argFrameP(FR, 1);
  deRef(p);

  if ( isTaggedInt(*p) )
  { return valInt(*p);
  } else
  { PL_error(NULL, 0, NULL, ERR_TYPE,
	     ATOM_integer, pushWordAsTermRef(argFrameP(FR, 1)));
    popTermRef();
    THROW_EXCEPTION;
  }
}


		 /*******************************
		 *	      CONTROL		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CUT: !. Task is to detroy  all   choicepoints  newer  then the current
frame. If we are in  debug-mode  we   create  a  new  CHP_DEBUG frame to
provide proper debugger output.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CUT, VIF_BREAK, 0, ())
{
#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { int rc;
    Choice ch;
    mark m;

    SAVE_REGISTERS(qid);
    rc = tracePort(FR, BFR, CUT_CALL_PORT, PC PASS_LD);
    LOAD_REGISTERS(qid);
    switch( rc )
    { case ACTION_RETRY:
	goto retry;
      case ACTION_FAIL:
	FRAME_FAILED;
      case ACTION_ABORT:
	THROW_EXCEPTION;
    }

    if ( (ch = findStartChoice(FR, BFR)) )
    { m = ch->mark;
      SAVE_REGISTERS(qid);
      dbg_discardChoicesAfter(FR, FINISH_CUT PASS_LD);
      LOAD_REGISTERS(qid);
      lTop = (LocalFrame) argFrameP(FR, CL->value.clause->variables);
      ch = newChoice(CHP_DEBUG, FR PASS_LD);
      ch->mark = m;
    } else
    { dbg_discardChoicesAfter(FR, FINISH_CUT PASS_LD);
      lTop = (LocalFrame) argFrameP(FR, CL->value.clause->variables);
    }
    ARGP = argFrameP(lTop, 0);
    if ( exception_term )
      THROW_EXCEPTION;

    SAVE_REGISTERS(qid);
    rc = tracePort(FR, BFR, CUT_EXIT_PORT, PC PASS_LD);
    LOAD_REGISTERS(qid);
    switch( rc )
    { case ACTION_RETRY:
	goto retry;
      case ACTION_FAIL:
	FRAME_FAILED;
      case ACTION_ABORT:
	THROW_EXCEPTION;
    }
  } else
#endif
  { SAVE_REGISTERS(qid);
    discardChoicesAfter(FR, FINISH_CUT PASS_LD);
    LOAD_REGISTERS(qid);
    lTop = (LocalFrame) argFrameP(FR, CL->value.clause->variables);
    ARGP = argFrameP(lTop, 0);
    if ( exception_term )
      THROW_EXCEPTION;
  }

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_JMP skips the amount stated in the pointed argument. The PC++ could be
compiled out, but this is a bit more neath.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_JMP, 0, 1, (CA1_JUMP))
{ PC += *PC;
  PC++;

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_OR: Create choice-point in the clause.  Argument is the amount to skip
if the choice-point needs to be activated.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_OR, 0, 1, (CA1_JUMP))
{ size_t skip = *PC++;
  Choice ch;

  if ( addPointer(lTop, sizeof(struct choice)) > (void*)lMax )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = growLocalSpace__LD(sizeof(*ch), ALLOW_SHIFT PASS_LD);
    LOAD_REGISTERS(qid);
    if ( rc != TRUE )
    { raiseStackOverflow(rc);
      THROW_EXCEPTION;
    }
  }

  ch = newChoice(CHP_JUMP, FR PASS_LD);
  ch->value.PC = PC+skip;
  ARGP = argFrameP(lTop, 0);

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_IFTHEN saves the value of BFR (current   backtrack frame) into a local
frame slot reserved by the compiler. Note  that the variable to hold the
local-frame pointer is  *not*  reserved   in  clause->variables,  so the
garbage collector won't see it. We use  a term-reference because using a
relative address simplifies the stack-shifter.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_SOFTIFTHEN, 0, 1, (CA1_CHP))
{ SEPERATE_VMI;
  VMI_GOTO(C_IFTHEN);
}

VMI(C_IFTHEN, 0, 1, (CA1_CHP))
{ varFrame(FR, *PC++) = consTermRef(BFR);

  NEXT_INSTRUCTION;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_IFTHENELSE: contraction of C_IFTHEN and C_OR.  This contraction has been
made to help the decompiler distinguis between (a ; b) -> c and a -> b ;
c,  which  would  otherwise  only  be    possible  to  distinguis  using
look-ahead.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_NOT, 0, 2, (CA1_CHP,CA1_JUMP))
{ SEPERATE_VMI;
  VMI_GOTO(C_IFTHENELSE);
}


VMI(C_IFTHENELSE, 0, 2, (CA1_CHP,CA1_JUMP))
{ varFrame(FR, *PC++) = consTermRef(BFR); /* == C_IFTHEN */

  VMI_GOTO(C_OR);
}

VMI(C_FASTCOND, 0, 2, (CA1_CHP,CA1_JUMP))
{ size_t skip;

#ifdef O_DEBUGGER
  if ( unlikely(debugstatus.debugging) )
    VMI_GOTO(C_IFTHENELSE);
#endif

  varFrame(FR, *PC++) = consTermRef(BFR); /* == C_IFTHEN */
  skip = *PC++;
  LD->fast_condition = PC+skip;
  NEXT_INSTRUCTION;
}

VMI(C_FASTCUT, 0, 1, (CA1_CHP))
{
#ifdef O_DEBUGGER
  if ( unlikely(debugstatus.debugging) )
    VMI_GOTO(C_CUT);
#endif

  PC++;
  LD->fast_condition = NULL;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_VAR is generated by the compiler to ensure the  instantiation  pattern
of  the  variables  is  the  same after finishing both paths of the `or'
wired in the clause.  Its task is to make the n-th variable slot of  the
current frame to be a variable.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_VAR, 0, 1, (CA1_FVAR))
{ setVar(varFrame(FR, *PC++));

  NEXT_INSTRUCTION;
}


VMI(C_VAR_N, 0, 2, (CA1_FVAR,CA1_INTEGER))
{ Word vp = varFrameP(FR, *PC++);
  size_t count = *PC++;

  while(count--)
    setVar(*vp++);

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_CUT  destroys  all  backtrack  points    created  after  the  C_IFTHEN
instruction in this clause. It assumes the  value of BFR has been stored
in the nth-variable slot of the current local frame.

We can dereference all frames that are older that the old backtrackframe
and older than this frame.

All frames created since what becomes now the  backtrack  point  can  be
discarded.

C_LCUT  results  from  !'s  encountered  in    the   condition  part  of
if->then;else and \+ (which  is  (g->fail;true)).   It  should  cut  all
choices created since the mark, but not   the mark itself. The test-case
is  a  :-  \+  (b,  !,  fail),    which   should  succeed.  The  current
implementation  walks  twice  over  the    choice-points,  but  cuts  in
conditions should be rare (I hope :-).

C_LSCUT does the same for the condition   part  of soft-cut (*->). Here,
the choice argument is the new choice  created by the disjunction, so we
must cut its parent.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
BEGIN_SHAREDVARS
  Choice och;
  Choice ch;

VMI(C_LSCUT, 0, 1, (CA1_CHP))
{ word chref = varFrame(FR, *PC++);

  if ( (intptr_t)chref < 0 )
    chref = (word)-(intptr_t)chref;

  ch = (Choice)valTermRef(chref);
  och = ch->parent;
  goto c_lcut_cont;
}

VMI(C_LCUT, 0, 1, (CA1_CHP))
{ och = (Choice) valTermRef(varFrame(FR, *PC++));
c_lcut_cont:

  for(ch=BFR; ch; ch = ch->parent)
  { if ( ch->parent == och )
    { och = ch;
      goto c_cut;
    }
  }
  assert(BFR == och);			/* no choicepoint yet */
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CUTCHP cuts all  choice-points  after   the  specified  argument. This
instruction is generated for $cut(Var), used by prolog_cut_to(Choice).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CUTCHP, 0, 0, ())
{ Word a = argFrameP(FR, 0);

  deRef(a);
  if ( isInteger(*a) && storage(*a) == STG_INLINE )
  { intptr_t i = valInt(*a);
    och = ((Choice)((Word)lBase + i));

    if ( !existingChoice(och PASS_LD) )
    { PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_choice, consTermRef(a));
      THROW_EXCEPTION;
    }

    DEBUG(MSG_CUT, Sdprintf("prolog_cut_to/1 for %s on [%d] %s\n",
			    chp_chars(och),
			    levelFrame(FR), predicateName(FR->predicate)));

    goto c_cut;
  } else
  { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_choice, consTermRef(a));
    THROW_EXCEPTION;
  }
}


VMI(C_SCUT, 0, 0, ())
{ NEXT_INSTRUCTION;
}

VMI(C_LCUTIFTHEN, 0, 1, (CA1_CHP))
{ SEPERATE_VMI;
  VMI_GOTO(C_CUT);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This code deals with ->, *-> and prolog_cut_to/1 (I_CUTCHP)

(*) Normally, committing destroys frames created   after  a choice point
that is related to the running frame. In that case we can simply destroy
all frames that are  more  recent  that   the  choice  point.  With  the
ancestral however, it is possible that  we   must  keep  frames. We must
destroy all frames that are not  reachable   by  the continuation of the
current frame, nor one of the older choice points.

Using in_continuation() seems a bit slower, but the test is rather quick
and avoids some decisions as well. Timing   on a few syntatic cases show
no significant performance difference and even   a  small gain using the
implementation below.

TBD: Merge with dbgDiscardChoicesAfter()
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_CUT, 0, 1, (CA1_CHP))
{ och = (Choice) valTermRef(varFrame(FR, *PC));
  PC++;					/* cannot be in macro! */
c_cut:

  assert(BFR>=och);
  for(ch=BFR; ch > och; ch = ch->parent)
  { LocalFrame fr2;

    DEBUG(MSG_CUT, Sdprintf("Discarding choice %s for %s\n",
			    chp_chars(ch), predicateName(ch->frame->predicate)));

    for(fr2 = ch->frame;
	!in_continuation(fr2, FR, ch->parent);	/* See (*) */
	fr2 = fr2->parent)
    { DEBUG(MSG_CUT, Sdprintf("Discarding [%d] %s\n",
			      levelFrame(fr2), predicateName(fr2->predicate)));

      assert(fr2->clause || true(fr2->predicate, P_FOREIGN));

      if ( true(fr2, FR_WATCHED) )
      { char *lSave = (char*)lBase;

	BFR = ch;
	SAVE_REGISTERS(qid);
	frameFinished(fr2, FINISH_CUT PASS_LD);
	LOAD_REGISTERS(qid);
	if ( lSave != (char*)lBase )	/* shifted */
	{ intptr_t offset = (char*)lBase - lSave;

	  fr2 = addPointer(fr2, offset);
	  ch  = addPointer(ch,  offset);
	  assert(ch == BFR);
	  och = addPointer(och, offset);
	}
	if ( exception_term )
	  THROW_EXCEPTION;
      }

      discardFrame(fr2 PASS_LD);
      killFrame(fr2);				/* kill for markPredicates() */
    }

    if ( ch->parent == och )
      DiscardMark(ch->mark);
  }
  assert(och == ch);
  BFR = ch;

  if ( (void *)och > (void *)FR )
  { lTop = (LocalFrame)(och+1);
  } else
  { int nvar = (true(FR->predicate, P_FOREIGN)
			? (int)FR->predicate->functor->arity
			: FR->clause->value.clause->variables);
    lTop = (LocalFrame) argFrameP(FR, nvar);
  }

  ARGP = argFrameP(lTop, 0);

  DEBUG(MSG_CUT, Sdprintf(" --> BFR = #%ld, lTop = #%ld\n",
			  loffset(BFR), loffset(lTop)));
  NEXT_INSTRUCTION;
}
END_SHAREDVARS


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_SOFTIF: A *-> B ; C is translated to C_SOFIF <A> C_SOFTCUT <B> C_JMP
end <C>.

C_SOFTIF <choice-var> <skip> is  the  same   as  C_OR  <skip>, storing a
reference to the choice-point in <choice-var>

See pl-comp.c and C_SOFTCUT implementation for details.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
VMI(C_SOFTIF, 0, 2, (CA1_CHP,CA1_JUMP))
{ varFrame(FR, *PC++) = consTermRef(lTop);	/* see C_SOFTCUT */

  DEBUG(MSG_CUT, Sdprintf("Creating *-> choice at %p (%d)\n",
			  lTop, loffset(lTop)));
  VMI_GOTO(C_OR);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_SOFTCUT: Handle the commit-to of A *->   B;  C. We must invalidate the
choice point, but note that C_SOFTCUT is  executed multiple times if the
condition succeeds multiple times. Also, C_LSCUT   must find this choice
point to know how far to cut,  so   we  cannot  simply delete the choice
point. Instead, a positive term reference implies we did not yet execute
the soft cut. In this case we  delete   the  choice  and make the slot a
negative term reference to the parent.   A second execution of C_SOFTCUT
with a negative term reference is simply ignored.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_SOFTCUT, 0, 1, (CA1_CHP))
{ Word chref = varFrameP(FR, *PC++);

  if ( (intptr_t)*chref > 0 )
  { Choice ch = (Choice)valTermRef((term_t)*chref);
    Choice bfr = BFR;

    DEBUG(MSG_SOFTCUT,
	  Sdprintf("Killing choice %s from %s\n",
		   chp_chars(ch), print_addr(chref, NULL)));

    if ( bfr == ch )
    { BFR = bfr->parent;
      *chref = (word)-(intptr_t)consTermRef(BFR);
    } else
    { for(; bfr >= ch; bfr=bfr->parent)
      { if ( bfr->parent == ch )
	{ bfr->parent = ch->parent;
	  *chref = (word)-(intptr_t)consTermRef(ch->parent);
	  break;
	}
      }
    }
  } else
  { DEBUG(MSG_SOFTCUT,
	  Sdprintf("Already killed at %s\n", print_addr(chref, NULL)));
  }

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_END is a dummy instruction to help the decompiler to find the end of A
-> B. (Note that a :- (b ->  c),  d  ==   a  :-  (b  ->  c, d) as far as
semantics. They are different terms however.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_END, 0, 0, ())
{ NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C_FAIL is equivalent to fail/0. Used to implement \+/1.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(C_FAIL, 0, 0, ())
{ BODY_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_FAIL: Translation of fail/0. Same as C_FAIL, but we make a normal call
when in debug-mode, so we can trace the call.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_FAIL, VIF_BREAK, 0, ())
{
#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { NFR = lTop;
    setNextFrameFlags(NFR, FR);
    DEF = lookupDefinition(FUNCTOR_fail0, MODULE_system);

    goto normal_call;
  }
#endif
  BODY_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_TRUE: Translation of true/0.  See also I_FAIL.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_TRUE, VIF_BREAK, 0, ())
{
#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { NFR = lTop;
    setNextFrameFlags(NFR, FR);
    DEF = lookupDefinition(FUNCTOR_true0, MODULE_system);

    goto normal_call;
  }
#endif
  NEXT_INSTRUCTION;
}


BEGIN_SHAREDVARS
functor_t fpred;
Word p;
/** var(@Term)
*/

VMI(I_VAR, VIF_BREAK, 1, (CA1_VAR))
{ p = varFrameP(FR, (int)*PC++);

#ifdef O_DEBUGGER
  if ( unlikely(debugstatus.debugging) )
  { fpred = FUNCTOR_var1;
  debug_pred1:

    NFR = lTop;
    setNextFrameFlags(NFR, FR);
    DEF  = lookupDefinition(fpred, MODULE_system);
    ARGP = argFrameP(NFR, 0);
    *ARGP++ = linkVal(p);

    goto normal_call;
  }
#endif

  deRef(p);
  if ( canBind(*p) )
    NEXT_INSTRUCTION;
  FASTCOND_FAILED;
}


/** nonvar(@Term)
*/

VMI(I_NONVAR, VIF_BREAK, 1, (CA1_VAR))
{ p = varFrameP(FR, (int)*PC++);

#ifdef O_DEBUGGER
  if ( unlikely(debugstatus.debugging) )
  { fpred = FUNCTOR_nonvar1;
    goto debug_pred1;
  }
#endif

  deRef(p);
  if ( !canBind(*p) )
    NEXT_INSTRUCTION;
  FASTCOND_FAILED;
}

/** integer(@Term), atom(@Term), etc.
*/

#define isCallableLD(t) isCallable(t PASS_LD)

#ifdef O_DEBUGGER
#define TYPE_TEST(functor, test)           \
	p = varFrameP(FR, (int)*PC++);     \
	deRef(p);                          \
        if ( test(*p) )			   \
          NEXT_INSTRUCTION;                \
	FASTCOND_FAILED;
#else
#define TYPE_TEST(functor, test)		\
	p = varFrameP(FR, (int)*PC++);		\
	if ( unlikely(debugstatus.debugging) )	\
        { fpred = functor;			\
	  goto debug_pred1;			\
	}					\
	deRef(p);				\
        if ( test(*p) )				\
          NEXT_INSTRUCTION;			\
	FASTCOND_FAILED;
#endif

VMI(I_INTEGER, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_integer1, isInteger);
}

VMI(I_FLOAT, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_float1, isFloat);
}

VMI(I_NUMBER, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_number1, isNumber);
}

VMI(I_ATOMIC, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_atomic1, isAtomic);
}

VMI(I_ATOM, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_atom1, isTextAtom);
}

VMI(I_STRING, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_string1, isString);
}

VMI(I_COMPOUND, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_compound1, isTerm);
}

VMI(I_CALLABLE, VIF_BREAK, 1, (CA1_VAR))
{ TYPE_TEST(FUNCTOR_callable1, isCallableLD);
}

END_SHAREDVARS

		 /*******************************
		 *	    SUPERVISORS		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_VIRGIN: Fresh, unused predicate. Any new   predicate  is created using
this supervisor (see resetProcedure()). The task of this is to

	* Resolve the definition (i.e. auto-import or auto-load if
	not defined).
	* Check the indexing opportunities and install the proper
        supervisor (see pl-index.c).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_VIRGIN, 0, 0, ())
{ lTop = (LocalFrame)argFrameP(FR, FR->predicate->functor->arity);

  if ( !DEF->impl.any.defined && false(DEF, PROC_DEFINED) )
  { SAVE_REGISTERS(qid);
    DEF = getProcDefinedDefinition(DEF PASS_LD);
    LOAD_REGISTERS(qid);

    setFramePredicate(FR, DEF);
    setGenerationFrame(FR);
#ifdef O_PROFILE
    if ( FR->prof_node )
      profSetHandle(FR->prof_node, DEF);
#endif
    if ( DEF->impl.any.defined )
      goto retry_continue;
#ifdef O_PLMT
  } else if ( true(DEF, P_THREAD_LOCAL) )
  { DEF = getProcDefinition__LD(DEF PASS_LD);
    setFramePredicate(FR, DEF);
    setGenerationFrame(FR);
#endif
  }

  if ( createSupervisor(DEF) )
  { PC = DEF->codes;
    NEXT_INSTRUCTION;
  } else				/* TBD: temporary */
  { assert(0);
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_UNDEF: Undefined predicate. We could make   two  instructions, one for
trapping and one not, but the disadvantage of that is that switching the
unknown flag of the module has no   immediate consequences. Hence we use
one instruction and dynamic checking.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_UNDEF, 0, 0, ())
{ switch( getUnknownModule(DEF->module) )
  { case UNKNOWN_ERROR:
    { fid_t fid;
      Definition caller;

      if ( FR->parent )
	caller = FR->parent->predicate;
      else
	caller = NULL;

      lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
      newChoice(CHP_DEBUG, FR PASS_LD);

      SAVE_REGISTERS(qid);
      if ( (fid = PL_open_foreign_frame()) )
      { PL_error(NULL, 0, NULL, ERR_UNDEFINED_PROC, DEF, caller);
	PL_close_foreign_frame(fid);
      }
      LOAD_REGISTERS(qid);

      enterDefinition(DEF);		/* will be left in exception code */

      THROW_EXCEPTION;
    }
    case UNKNOWN_WARNING:
    { fid_t fid;

      lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
      SAVE_REGISTERS(qid);
      if ( (fid = PL_open_foreign_frame()) )
      { term_t pred;
	int rc;

	rc = ( (pred=PL_new_term_ref()) &&
	       unify_definition(MODULE_user, pred, DEF, 0, GP_NAMEARITY) &&
	       printMessage(ATOM_warning,
			    PL_FUNCTOR, FUNCTOR_error2,
			      PL_FUNCTOR, FUNCTOR_existence_error2,
			        PL_ATOM, ATOM_procedure,
			        PL_TERM, pred,
			      PL_VARIABLE) );
	(void)rc;			/* checking for exception term below */
	PL_close_foreign_frame(fid);
      }
      if ( exception_term )
	THROW_EXCEPTION;
      /*FALLTHROUGH*/
    }
    case UNKNOWN_FAIL:
    default:
      if ( debugstatus.debugging )
	newChoice(CHP_DEBUG, FR PASS_LD);
      FRAME_FAILED;
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Generic calling code.  This needs to be specialised.

Note that FR->clause is still NULL. We need to keep that while doing the
possible stack-expansion in ENSURE_LOCAL_SPACE(), which   is  why we use
the temporary variable `cl' for storing the clause.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_STATIC, 0, 0, ())
{ ClauseRef cl;
  struct clause_choice chp;

  ARGP = argFrameP(FR, 0);
  lTop = (LocalFrame)ARGP+DEF->functor->arity;

  DEBUG(9, Sdprintf("Searching clause ... "));

  if ( !(cl = firstClause(ARGP, FR, DEF, &chp PASS_LD)) )
  { DEBUG(9, Sdprintf("No clause matching index.\n"));
    if ( debugstatus.debugging )
      newChoice(CHP_DEBUG, FR PASS_LD);

    FRAME_FAILED;
  }
  DEBUG(9, Sdprintf("Clauses found.\n"));

  PC = cl->value.clause->codes;
  ENSURE_LOCAL_SPACE(LOCAL_MARGIN+cl->value.clause->variables*sizeof(word),
		     THROW_EXCEPTION);
  lTop = (LocalFrame)(ARGP + cl->value.clause->variables);
  CL = cl;

  if ( chp.cref )
  { Choice ch = newChoice(CHP_CLAUSE, FR PASS_LD);
    ch->value.clause = chp;
  } else if ( debugstatus.debugging )
    newChoice(CHP_DEBUG, FR PASS_LD);

  DEBUG(CHK_SECURE,
	{ int argc; int n;
	  argc = DEF->functor->arity;
	  for(n=0; n<argc; n++)
	    checkData(argFrameP(FR, n));
	});

  umode = uread;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_DYNAMIC: Dynamic predicate. Dynamic predicates   must  use the dynamic
indexing and need to lock the predicate. This VMI can also handle static
code.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_DYNAMIC, 0, 0, ())
{ enterDefinition(DEF);

  VMI_GOTO(S_STATIC);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_THREAD_LOCAL: Get thread-local definition
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_THREAD_LOCAL, 0, 0, ())
{ DEF = getProcDefinition__LD(DEF PASS_LD);
  setFramePredicate(FR, DEF);
  setGenerationFrame(FR);

  assert(DEF->codes);
  PC = DEF->codes;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_MULTIFILE: Multifile predicate.  These need to be aware of new
clauses that can be added at runtime.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_MULTIFILE, 0, 0, ())
{ VMI_GOTO(S_STATIC);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_TRUSTME: Trust this clause. Generated   for  single-clause supervisors
and for the last one of a disjunction.

TBD: get rid of clause-references
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_TRUSTME, 0, 1, (CA1_CLAUSEREF))
{ ClauseRef cref = (ClauseRef)*PC++;

  ARGP = argFrameP(FR, 0);
  TRUST_CLAUSE(cref);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_ALLCLAUSES: Simply try the clauses one-by-one. This works for all code
and is the ultimate fallback of the indexing code.  The supervisor code
is

	S_ALLCLAUSES
	S_NEXTCLAUSE
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

BEGIN_SHAREDVARS
ClauseRef cref;

VMI(S_ALLCLAUSES, 0, 0, ())		/* Uses CHP_JUMP */
{ cref = DEF->impl.clauses.first_clause;

next_clause:
  ARGP = argFrameP(FR, 0);
  for(; cref; cref = cref->next)
  { if ( visibleClauseCNT(cref->value.clause, generationFrame(FR)) )
    { TRY_CLAUSE(cref, cref->next, PC);
    }
  }

  FRAME_FAILED;
}


VMI(S_NEXTCLAUSE, 0, 0, ())
{ cref = CL->next;

  if ( debugstatus.debugging && !debugstatus.suspendTrace )
  { ARGP = argFrameP(FR, 0);
    lTop = (LocalFrame)ARGP + FR->predicate->functor->arity;

    for(; cref; cref = cref->next)
    { if ( visibleClauseCNT(cref->value.clause, generationFrame(FR)) )
      {	LocalFrame fr;
	CL = cref;

	if ( (fr = dbgRedoFrame(FR, CHP_CLAUSE PASS_LD)) )
	{ int action;

	  SAVE_REGISTERS(qid);
	  action = tracePort(fr, BFR, REDO_PORT, NULL PASS_LD);
	  LOAD_REGISTERS(qid);

	  switch( action )
	  { case ACTION_FAIL:
	      FRAME_FAILED;
	    case ACTION_IGNORE:
	      VMI_GOTO(I_EXIT);
	    case ACTION_RETRY:
	      goto retry_continue;
	    case ACTION_ABORT:
	      THROW_EXCEPTION;
	  }
	}

        break;
      }
    }
  }

  PC--;
  goto next_clause;
}
END_SHAREDVARS


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
S_LIST: Predicate consisting of two clauses, one of them using [] and
the other [_|_].
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_LIST, 0, 2, (CA1_CLAUSEREF, CA1_CLAUSEREF))
{ ClauseRef cref;
  Word k;

  ARGP = argFrameP(FR, 0);
  deRef2(ARGP, k);
  if ( isList(*k) )
    cref = (ClauseRef)PC[1];
  else if ( isNil(*k) )
    cref = (ClauseRef)PC[0];
  else if ( canBind(*k) )
  { PC = SUPERVISOR(staticp) + 1;
    VMI_GOTO(S_STATIC);
  } else
    FRAME_FAILED;

  PC += 2;

  TRUST_CLAUSE(cref);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Meta-predicate  argument  qualification.  S_MQUAL    qualifies  the  Nth
argument. S_LMQUAL does the same and resets   the  context module of the
frame to be definition module of   the  predicate, such that unqualified
calls refer again to  the  definition   module.  This  sequence  must be
processed as part of the supervisor,   notably before creating the first
choicepoint.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(S_MQUAL, 0, 1, (CA1_VAR))
{ int arg = (int)*PC++;
  int rc;

  SAVE_REGISTERS(qid);
  rc = m_qualify_argument(FR, arg PASS_LD);
  LOAD_REGISTERS(qid);
  if ( rc != TRUE )
  { if ( rc != FALSE )
      raiseStackOverflow(rc);
    THROW_EXCEPTION;
  }

  NEXT_INSTRUCTION;
}


VMI(S_LMQUAL, 0, 1, (CA1_VAR))
{ int arg = (int)*PC++;
  int rc;

  SAVE_REGISTERS(qid);
  rc = m_qualify_argument(FR, arg PASS_LD);
  LOAD_REGISTERS(qid);
  if ( rc != TRUE )
  { if ( rc != FALSE )
      raiseStackOverflow(rc);
    THROW_EXCEPTION;
  }
  setContextModule(FR, FR->predicate->module);

  NEXT_INSTRUCTION;
}


		 /*******************************
		 *	    ARITHMETIC		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Arithmic is compiled using a  stack  machine.    ARGP  is  used as stack
pointer and the arithmic stack is allocated   on top of the local stack,
starting at the argument field of the next slot of the stack (where ARGP
points to when processing the body anyway).

Arguments to functions are pushed on the stack  starting  at  the  left,
thus `add1(X, Y) :- Y is X + 1' translates to:

  I_ENTER	% enter body
  B_VAR1	% push Y via ARGP
  A_ENTER	% align the stack to prepare for writing doubles
  A_VAR0	% evaluate X and push numeric result
  A_INTEGER 1	% Push 1 as numeric value
  A_FUNC2 0	% Add top-two of the stack and push result
  A_IS		% unify Y with numeric result
  I_EXIT	% leave the clause

  a_func0:	% executes arithmic function without arguments, pushing
	        % its value on the stack
  a_func1:	% unary function. Changes the top of the stack.
  a_func2:	% binary function. Pops two values and pushes one.

Note that we do not call `ar_func0(*PC++, &ARGP)' as ARGP is a register
variable.  Also, for compilers that do register allocation it is unwise
to give the compiler a hint to put ARGP not into a register.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_ENTER: Prepare for arithmetic operations.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_ENTER, 0, 0, ())
{ AR_BEGIN();
  NEXT_INSTRUCTION;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_INTEGER: Push long integer following PC
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_INTEGER, 0, 1, (CA1_INTEGER))
{ Number n = allocArithStack(PASS_LD1);

  n->value.i = (intptr_t) *PC++;
  n->type    = V_INTEGER;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_INT64: Push int64_t following PC
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_INT64, 0, WORDS_PER_INT64, (CA1_INT64))
{ Number n = allocArithStack(PASS_LD1);
  Word p = &n->value.w[0];

  cpInt64Data(p, PC);
  n->type    = V_INTEGER;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_MPZ: Push mpz integer following PC
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_MPZ, 0, VM_DYNARGC, (CA1_MPZ))
{
#ifdef O_GMP
  Number n = allocArithStack(PASS_LD1);
  Word p = (Word)PC;
  size_t size;

  p++;				/* skip indirect header */
  n->type = V_MPZ;
  n->value.mpz->_mp_size  = (int)*p++;
  n->value.mpz->_mp_alloc = 0;	/* avoid de-allocating */
  size = sizeof(mp_limb_t) * abs(n->value.mpz->_mp_size);
  n->value.mpz->_mp_d = (void*)p;

  p += (size+sizeof(word)-1)/sizeof(word);
  PC = (Code)p;
#endif
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_DOUBLE: Push double following PC
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_DOUBLE, 0, WORDS_PER_DOUBLE, (CA1_FLOAT))
{ Number n = allocArithStack(PASS_LD1);
  Word p = &n->value.w[0];

  cpDoubleData(p, PC);
  n->type       = V_FLOAT;
  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_VAR: Push a variable.  This can be any term
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

BEGIN_SHAREDVARS
  int offset;

VMI(A_VAR, 0, 1, (CA1_VAR))
{ Number n;
  Word p, p2;

  offset = (int)*PC++;

a_var_n:
  p = varFrameP(FR, offset);
  deRef2(p, p2);

					/* speedup common case a bit */
  if ( tagex(*p2) == (TAG_INTEGER|STG_INLINE) )
  { n = allocArithStack(PASS_LD1);
    n->value.i = valInt(*p2);
    n->type = V_INTEGER;
    NEXT_INSTRUCTION;
    /*NOTREACHED*/
  }

  switch(tag(*p2))
  { case TAG_INTEGER:
      n = allocArithStack(PASS_LD1);
      get_integer(*p2, n);
      NEXT_INSTRUCTION;
    case TAG_FLOAT:
      n = allocArithStack(PASS_LD1);
      n->value.f = valFloat(*p2);
      n->type = V_FLOAT;
      NEXT_INSTRUCTION;
    default:
    { intptr_t lsafe = (char*)lTop - (char*)lBase;
      fid_t fid;
      number result;
      int rc;

      SAVE_REGISTERS(qid);
      lTop = (LocalFrame)argFrameP(lTop, 1); /* for is/2.  See below */
      if ( (fid = PL_open_foreign_frame()) )
      { rc = valueExpression(consTermRef(p), &result PASS_LD);
	PL_close_foreign_frame(fid);
      } else
      { rc = FALSE;
      }
      lTop = addPointer(lBase, lsafe);
      LOAD_REGISTERS(qid);

      if ( rc )
      { pushArithStack(&result PASS_LD);
	NEXT_INSTRUCTION;
      } else
      { resetArithStack(PASS_LD1);
	THROW_EXCEPTION;
      }
    }
  }
}

VMI(A_VAR0, 0, 0, ())
{ offset = VAROFFSET(0);
  goto a_var_n;
}

VMI(A_VAR1, 0, 0, ())
{ offset = VAROFFSET(1);
  goto a_var_n;
}

VMI(A_VAR2, 0, 0, ())
{ offset = VAROFFSET(2);
  goto a_var_n;
}
END_SHAREDVARS



/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_FUNC, function, #args
A_FUNC0, function
A_FUNC1, function
A_FUNC2, function

TBD: Keep knowledge on #argument in function!
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

BEGIN_SHAREDVARS
  int an;
  code fn;

VMI(A_FUNC0, 0, 1, (CA1_AFUNC))
{ an = 0;
  fn = *PC++;
  goto common_an;
}

VMI(A_FUNC1, 0, 1, (CA1_AFUNC))
{ an = 1;
  fn = *PC++;
  goto common_an;
}

VMI(A_FUNC2, 0, 1, (CA1_AFUNC))
{ an = 2;
  fn = *PC++;
  goto common_an;
}

VMI(A_FUNC, 0, 2, (CA1_AFUNC, CA1_INTEGER))
{ int rc;

  fn = *PC++;
  an = (int) *PC++;

common_an:
  SAVE_REGISTERS(qid);
  rc = ar_func_n((int)fn, an PASS_LD);
  LOAD_REGISTERS(qid);
  if ( !rc )
  { resetArithStack(PASS_LD1);
    THROW_EXCEPTION;
  }

  NEXT_INSTRUCTION;
}
END_SHAREDVARS


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_ADD: Shorthand for A_FUNC2 pl_ar_add()
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_ADD, 0, 0, ())
{ Number argv = argvArithStack(2 PASS_LD);
  int rc;
  number r;

  SAVE_REGISTERS(qid);
  rc = pl_ar_add(argv, argv+1, &r);
  LOAD_REGISTERS(qid);
  popArgvArithStack(2 PASS_LD);
  if ( rc )
  { pushArithStack(&r PASS_LD);
    NEXT_INSTRUCTION;
  }

  resetArithStack(PASS_LD1);
  THROW_EXCEPTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_MUL: Shorthand for A_FUNC2 ar_mul()
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_MUL, 0, 0, ())
{ Number argv = argvArithStack(2 PASS_LD);
  int rc;
  number r;

  SAVE_REGISTERS(qid);
  rc = ar_mul(argv, argv+1, &r);
  LOAD_REGISTERS(qid);
  popArgvArithStack(2 PASS_LD);
  if ( rc )
  { pushArithStack(&r PASS_LD);
    NEXT_INSTRUCTION;
  }

  resetArithStack(PASS_LD1);
  THROW_EXCEPTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_ADD_FC: Simple case A is B + <int>, where   A is a firstvar and B is a
normal variable. This case is very   common,  especially with relatively
small integers.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_ADD_FC, VIF_BREAK, 3, (CA1_FVAR, CA1_VAR, CA1_INTEGER))
{ Word rp  = varFrameP(FR, *PC++);	/* A = */
  Word np  = varFrameP(FR, *PC++);	/* B + */
  intptr_t add = (intptr_t)*PC++;	/* <int> */

  deRef(np);

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { Word expr;

    if ( !hasGlobalSpace(3) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(3, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }

      np = varFrameP(FR, PC[-2]);
      rp = varFrameP(FR, PC[-3]);
    }

    expr = gTop;
    gTop += 3;
    expr[0] = FUNCTOR_plus2;
    bArgVar(&expr[1], np PASS_LD);
    expr[2] = consInt(add);

    ARGP = argFrameP(lTop, 0);
    setVar(*rp);
    *ARGP++ = linkVal(rp);
    *ARGP++ = consPtr(expr, TAG_COMPOUND|STG_GLOBAL);
    NFR = lTop;
    DEF = GD->procedures.is2->definition;
    setNextFrameFlags(NFR, FR);
    goto normal_call;
  }
#endif

  if ( tagex(*np) == (TAG_INTEGER|STG_INLINE) )
  { intptr_t v = valInt(*np);
    int64_t r = v+add;			/* tagged ints never overflow */
    word w = consInt(r);

    if ( valInt(w) == r )
    { *rp = w;
    } else				/* but their sum might not fit */
    { int rc;

      SAVE_REGISTERS(qid);
      rc = put_int64(&w, r, ALLOW_GC|ALLOW_SHIFT PASS_LD);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
	THROW_EXCEPTION;
      *rp = w;
    }
    NEXT_INSTRUCTION;
  } else
  { number n;
    word w;
    fid_t fid;
    int rc;

    SAVE_REGISTERS(qid);
    if ( (fid = PL_open_foreign_frame()) )	/* Still needed? */
    { rc = valueExpression(pushWordAsTermRef(np), &n PASS_LD);
      popTermRef();
      if ( rc )
      { ensureWritableNumber(&n);
	if ( (rc=ar_add_ui(&n, add)) )
	{ if ( (rc=put_number(&w, &n, ALLOW_GC PASS_LD)) != TRUE )
	    rc = raiseStackOverflow(rc);
	}
	clearNumber(&n);
      }
      PL_close_foreign_frame(fid);
    } else
      rc = FALSE;
    LOAD_REGISTERS(qid);
    if ( !rc )
      THROW_EXCEPTION;

    rp = varFrameP(FR, PC[-3]);		/* may have shifted */
    *rp = w;

    NEXT_INSTRUCTION;
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Translation of the arithmic comparison predicates (<, >, =<,  >=,  =:=).
Both sides are pushed on the stack, so we just compare the two values on
the  top  of  this  stack  and  backtrack  if  they  do  not suffice the
condition.  Example translation: `a(Y) :- b(X), X > Y'

	I_ENTER
	B_FIRSTVAR 1	% Link X from B's frame to a new var in A's frame
	I_CALL b/1	% call b/1
	A_ENTER		% Enter arithmetic mode
	A_VAR 1		% Push X
	A_VAR 0		% Push Y
	A_GT		% compare
	EXIT
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

BEGIN_SHAREDVARS
  Number n1, n2;
  int cmp;
  int rc;

#define CMP_FAST(op) \
  n1 = argvArithStack(2 PASS_LD); \
  n2 = n1 + 1; \
  if ( n1->type == n2->type ) \
  { switch(n1->type) \
    { case V_INTEGER: \
        rc = n1->value.i op n2->value.i; \
	goto a_cmp_out; \
      case V_FLOAT: \
        rc = n1->value.f op n2->value.f; \
	goto a_cmp_out; \
      default: \
        ; \
    } \
  }


VMI(A_LT, VIF_BREAK, 0, ())		/* A < B */
{ CMP_FAST(<)
  cmp = LT;
acmp:
  rc = ar_compare(n1, n2, cmp);
a_cmp_out:
  popArgvArithStack(2 PASS_LD);
  AR_END();
  if ( rc )
    NEXT_INSTRUCTION;
  FASTCOND_FAILED;
}

VMI(A_LE, VIF_BREAK, 0, ())		/* A =< B */
{ CMP_FAST(<=);
  cmp = LE;
  goto acmp;
}

VMI(A_GT, VIF_BREAK, 0, ())		/* A > B */
{ CMP_FAST(>);
  cmp = GT;
  goto acmp;
}

VMI(A_GE, VIF_BREAK, 0, ())		/* A >= B */
{ CMP_FAST(>=);
  cmp = GE;
  goto acmp;
}

VMI(A_EQ, VIF_BREAK, 0, ())		/* A =:= B */
{ CMP_FAST(==);
  cmp = EQ;
  goto acmp;
}

VMI(A_NE, VIF_BREAK, 0, ())		/* A \=:= B */
{ CMP_FAST(!=);
  cmp = NE;
  goto acmp;
}
END_SHAREDVARS


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_IS: Translation of is/2. The stack has two pushed values: the variable
for the result (a word) and the number holding the result. For example:

   a(X) :- X is sin(3).

  I_ENTER
  B_VAR 0		push left argument of is/2
  A_INTEGER 3		push integer as number
  A_FUNC <sin>		run function on it
  A_IS			bind value
  I_EXIT
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_IS, VIF_BREAK, 0, ())		/* A is B */
{ Number n = argvArithStack(1 PASS_LD);
  Word k;

  ARGP = argFrameP(lTop, 0);	/* 1-st argument */
  deRef2(ARGP, k);

  if ( canBind(*k) )
  { word c;
    int rc;

    if ( n->type == V_INTEGER )		/* Speedup the 99% case a bit */
    { c = consInt(n->value.i);
      if ( valInt(c) == n->value.i &&
	   hasGlobalSpace(0) )
      { rc = TRUE;
	bindConst(k, c);
	goto a_is_ok;
      }
    }

#ifdef O_GMP
  can_bind:
#endif
    ARGP++;				/* new_args must become 1 in */
    SAVE_REGISTERS(qid);		/* get_vmi_state() */
    rc = put_number(&c, n, ALLOW_GC PASS_LD);
    LOAD_REGISTERS(qid);
    ARGP--;

    if ( rc == TRUE )
    { deRef2(ARGP, k);			/* may be shifted */
      if ( !isTerm(c) )
      { bindConst(k, c);
      } else
      { SAVE_REGISTERS(qid);
	rc = unify_ptrs(k, &c, ALLOW_GC|ALLOW_SHIFT PASS_LD);
	LOAD_REGISTERS(qid);
	if ( rc == FALSE )
	{ popArgvArithStack(1 PASS_LD);
	  AR_END();
	  if ( exception_term )
	    THROW_EXCEPTION;
	  BODY_FAILED;
	}
      }
    } else
    { raiseStackOverflow(rc);
      popArgvArithStack(1 PASS_LD);
      AR_END();
      THROW_EXCEPTION;
    }

  a_is_ok:
    popArgvArithStack(1 PASS_LD);
    AR_END();

    CHECK_WAKEUP;
    NEXT_INSTRUCTION;
  } else
  { int rc;

    if ( isInteger(*k) && intNumber(n) )
    { number left;

      get_integer(*k, &left);
      rc = (cmpNumbers(&left, n) == CMP_EQUAL);
      clearNumber(&left);
    } else if ( isFloat(*k) && floatNumber(n) )
    { rc = (valFloat(*k) == n->value.f);
#ifdef O_GMP
    } else if ( n->type == V_MPQ )
    { goto can_bind;
#endif
    } else
    { rc = FALSE;
    }

    popArgvArithStack(1 PASS_LD);
    AR_END();
    if ( rc )
      NEXT_INSTRUCTION;
  }

  BODY_FAILED;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
A_FIRSTVAR_IS: Deal with the very common case that the local variable is
a firstvar of the current frame. There   are numerous advantages to this
case: we know the left-side is a var, we  do not need to trail and we do
not need to check for attvar wakeup.

TBD: link with following B_VAR? How  frequent?   Likely  very: we are in
body mode and in many cases the result is used only once.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(A_FIRSTVAR_IS, VIF_BREAK, 1, (CA1_FVAR)) /* A is B */
{ Number n = argvArithStack(1 PASS_LD);
  word w;
  int rc;

  SAVE_REGISTERS(qid);
  if ( (rc = put_number(&w, n, ALLOW_GC PASS_LD)) != TRUE )
    rc = raiseStackOverflow(rc);
  LOAD_REGISTERS(qid);

  popArgvArithStack(1 PASS_LD);
  AR_END();

  if ( rc )
  { *varFrameP(FR, *PC++) = w;
    NEXT_INSTRUCTION;
  } else
    THROW_EXCEPTION;
}


		 /*******************************
		 *	     FOREIGN		*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
	I_FOPEN
	I_FCALLDET0-10 f/n
	I_FEXITDET
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

#ifdef O_PROF_PENTIUM
#define PROF_FOREIGN \
	{ END_PROF(); \
	  START_PROF(DEF->prof_index, DEF->prof_name); \
	}
#else
#define PROF_FOREIGN (void)0
#endif

BEGIN_SHAREDVARS
volatile word rc;			/* make gcc quiet on non-initialised */
volatile fid_t ffr_id;

VMI(I_FOPEN, 0, 0, ())
{ FliFrame ffr;

#ifdef O_DEBUGGER
  if ( debugstatus.debugging )
  { lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
    BFR = newChoice(CHP_DEBUG, FR PASS_LD);
    ffr = (FliFrame)lTop;
  } else
#endif
  { ffr = (FliFrame)argFrameP(FR, DEF->functor->arity);
  }

#if O_DEBUG
  if ( exception_term )
  { Sdprintf("Exception at entry of %s\n",  predicateName(DEF));
    PL_write_term(Serror, exception_term, 1200, PL_WRT_NEWLINE);
  }
#endif

  assert(DEF->functor->arity < 100);

  lTop = (LocalFrame)(ffr+1);
  ffr->size = 0;
  NoMark(ffr->mark);
  ffr->parent = fli_context;
  ffr->magic = FLI_MAGIC;
  fli_context = ffr;
  ffr_id = consTermRef(ffr);
  SAVE_REGISTERS(qid);

  NEXT_INSTRUCTION;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_FCALLDETVA:  Call  deterministic  foreign    function  using  P_VARARG
conventions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_FCALLDETVA, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  struct foreign_context context;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  context.context   = 0L;
  context.engine    = LD;
  context.control   = FRG_FIRST_CALL;
  context.predicate = DEF;

  PROF_FOREIGN;
  rc = (*f)(h0, DEF->functor->arity, &context);
  VMI_GOTO(I_FEXITDET);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_FCALLDET0 .. I_FCALLDET10: Call deterministic   foreign function using
a1, a2, ... calling conventions.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_FCALLDET0, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;

  PROF_FOREIGN;
  rc = (*f)();
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET1, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET2, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET3, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET4, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET5, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET6, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET7, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET8, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET9, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7, h0+8);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FCALLDET10, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7, h0+8, h0+9);
  VMI_GOTO(I_FEXITDET);
}


VMI(I_FEXITDET, 0, 0, ())
{ FliFrame ffr = (FliFrame)valTermRef(ffr_id);

  LOAD_REGISTERS(qid);
  PC += 3;
  DEBUG(CHK_SECURE, assert(PC[-1] == encode(I_FEXITDET)));
  fli_context = ffr->parent;

  switch(rc)
  { case TRUE:
      if ( exception_term )		/* false alarm */
	PL_clear_foreign_exception(FR);
      goto exit_checking_wakeup;
    case FALSE:
      if ( exception_term )
	THROW_EXCEPTION;
      FRAME_FAILED;
    default:
    { fid_t fid = PL_open_foreign_frame();
      term_t ex = PL_new_term_ref();

      PL_put_intptr(ex, rc);
      PL_error(NULL, 0, NULL, ERR_DOMAIN,
	       ATOM_foreign_return_value, ex);
      PL_close_foreign_frame(fid);
      THROW_EXCEPTION;
    }
  }
}
END_SHAREDVARS

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Non-deterministic foreign calls. This  is   compiled  into the following
supervisor code:

	I_FOPENNDET
	I_FCALLNDETVA func
	I_FEXITNDET
	I_FREDO

On determistic success or failure I_FEXITNDET ends the clause. Otherwise
it writes the context in CL  and   creates  a jump-choicepoint that will
take it to I_FREDO. I_FREDO updates the context structure and jumps back
to the I_FCALLNDETVA (PC -= 4);
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

BEGIN_SHAREDVARS
volatile intptr_t rc;				/* make compiler happy */
struct foreign_context context;
volatile fid_t ffr_id;

VMI(I_FOPENNDET, 0, 0, ())
{ Choice ch;
  FliFrame ffr;

  context.context   = 0L;
  context.engine    = LD;
  context.control   = FRG_FIRST_CALL;
  context.predicate = DEF;

foreign_redo:
  lTop = (LocalFrame)argFrameP(FR, DEF->functor->arity);
  ch = newChoice(CHP_JUMP, FR PASS_LD);
  ch->value.PC = PC+3;

  ffr = (FliFrame)(ch+1);
  lTop = (LocalFrame)(ffr+1);
  ffr->size = 0;
  NoMark(ffr->mark);
  ffr->parent = fli_context;
  ffr->magic = FLI_MAGIC;
  fli_context = ffr;
  ffr_id = consTermRef(ffr);
  SAVE_REGISTERS(qid);

  NEXT_INSTRUCTION;
}


VMI(I_FCALLNDETVA, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, DEF->functor->arity, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET0, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;

  PROF_FOREIGN;
  rc = (*f)(&context);
  VMI_GOTO(I_FEXITNDET);
}

VMI(I_FCALLNDET1, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET2, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  rc = (*f)(h0, h0+1, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET3, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET4, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET5, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET6, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET7, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET8, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET9, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7, h0+8, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FCALLNDET10, 0, 1, (CA1_FOREIGN))
{ Func f = (Func)*PC++;
  term_t h0 = argFrameP(FR, 0) - (Word)lBase;

  PROF_FOREIGN;
  rc = (*f)(h0, h0+1, h0+2, h0+3, h0+4, h0+5, h0+6, h0+7, h0+8, h0+9, &context);
  VMI_GOTO(I_FEXITNDET);
}


VMI(I_FEXITNDET, 0, 0, ())
{ FliFrame ffr = (FliFrame) valTermRef(ffr_id);

  LOAD_REGISTERS(qid);
  PC += 3;				/* saved at in I_FOPENNDET */
  fli_context = ffr->parent;

  switch(rc)
  { case TRUE:
      if ( exception_term )		/* false alarm */
	PL_clear_foreign_exception(FR);
      DEBUG(CHK_SECURE, assert(BFR->value.PC == PC));
#ifdef O_DEBUGGER
      if ( unlikely(debugstatus.debugging) )
	BFR->type = CHP_DEBUG;
      else
#endif
	BFR = BFR->parent;
      FR->clause = NULL;
      goto exit_checking_wakeup;
    case FALSE:
      if ( exception_term )
	THROW_EXCEPTION;
      DEBUG(CHK_SECURE, assert(BFR->value.PC == PC));
#ifdef O_DEBUGGER
      if ( unlikely(debugstatus.debugging) )
	BFR->type = CHP_DEBUG;
      else
#endif
	BFR = BFR->parent;
      FRAME_FAILED;
    default:
    { /* TBD: call debugger */
      if ( exception_term )		/* false alarm */
	PL_clear_foreign_exception(FR);

      if ( (rc & FRG_REDO_MASK) == REDO_INT )
      { rc = (word)(((intptr_t)rc)>>FRG_REDO_BITS);
      } else
      { rc &= ~FRG_REDO_MASK;
      }
      CL = (ClauseRef)rc;
      lTop = (LocalFrame)(BFR+1);
      goto exit_checking_wakeup;
    }
  }
}

VMI(I_FREDO, 0, 0, ())
{ if ( is_signalled(PASS_LD1) )
  { SAVE_REGISTERS(qid);
    handleSignals(PASS_LD1);
    LOAD_REGISTERS(qid);
    if ( exception_term )
      THROW_EXCEPTION;
  }

  context.context = (word)FR->clause;
  context.control = FRG_REDO;
  context.engine  = LD;
  PC -= 4;
  goto foreign_redo;
}

END_SHAREDVARS


		 /*******************************
		 *     EXCEPTIONS & CLEANUP	*
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CALLCLEANUP: Part of setup_call_catcher_cleanup(:Setup, :Goal,
?Catcher, :Cleanup). Simply set a flag on the frame and call the 1-st
argument. See also I_CATCH.

I_EXITCLEANUP  is  at  the  end  of   call_cleanup/3.  If  there  is  no
choice-point created this is the final exit. If this frame has no parent
(it is the entry of PL_next_solution()),

setup_call_catcher_cleanup(:Setup :Goal, -Reason, :Cleanup)
is tranalated into

  i_enter
  <setup>
  i_callcleanup
  i_exitcleanup
  i_exit

We set FR_WATCHED to get a cleanup call if the frame fails or is cutted.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALLCLEANUP, 0, 0, ())
{ if ( !mustBeCallable(consTermRef(argFrameP(FR, 3)) PASS_LD) )
    THROW_EXCEPTION;

  newChoice(CHP_CATCH, FR PASS_LD);
  set(FR, FR_CLEANUP);
				/* = B_VAR1 */
  *argFrameP(lTop, 0) = linkVal(argFrameP(FR, 1));

  VMI_GOTO(I_USERCALL0);
}


/* (*) Work around a bug in the LLVM.  Just calling a dummy function avoids
   a crash here!?  If we do not use GCC's threaded-code support it appears
   that the bug is gone too.  LLVM's support for this GCC extension is poor
   anyway: it runs, but is *much* slower than the switch.
*/

VMI(I_EXITCLEANUP, 0, 0, ())
{
#if defined(__llvm__) && defined(VMCODE_IS_ADDRESS) /* (*) */
  extern int llvm_dummy(void);
  llvm_dummy();
#endif

  while( BFR && BFR->type == CHP_DEBUG )
    BFR = BFR->parent;

  if ( BFR->frame == FR && BFR->type == CHP_CATCH )
  { DEBUG(3, Sdprintf(" --> BFR = #%ld\n", loffset(BFR->parent)));
    for(BFR = BFR->parent; BFR > (Choice)FR; BFR = BFR->parent)
    { if ( BFR->type == CHP_DEBUG )
	continue;
      if ( BFR->frame > FR )
	NEXT_INSTRUCTION;		/* choice from setup of setup_call_catcher_cleanup/4 */
    }

    SAVE_REGISTERS(qid);
    frameFinished(FR, FINISH_EXITCLEANUP PASS_LD);
    LOAD_REGISTERS(qid);
    if ( exception_term )
      THROW_EXCEPTION;
  }

  NEXT_INSTRUCTION;			/* goto i_exit? */
}


#if O_CATCHTHROW
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CATCH has to fake a choice-point to   make  it possible to undo before
starting the recover action. Otherwise it simply   has to call the first
argument.  Catch is defined as:

catch(Goal, Pattern, Recover) :-
  $catch.

which is translated to:
  I_ENTER
  I_CATCH
  I_EXITCATCH
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CATCH, 0, 0, ())
{ if ( BFR->frame == FR && BFR == (Choice)argFrameP(FR, 3) )
  { assert(BFR->type == CHP_DEBUG);
    BFR->type = CHP_CATCH;
  } else
    newChoice(CHP_CATCH, FR PASS_LD);

				  /* = B_VAR0 */
  *argFrameP(lTop, 0) = linkVal(argFrameP(FR, 0));
  VMI_GOTO(I_USERCALL0);
}


VMI(I_EXITCATCH, 0, 0, ())
{ if ( BFR->frame == FR && BFR == (Choice)argFrameP(FR, 3) )
  { assert(BFR->type == CHP_CATCH);
    BFR = BFR->parent;
    set(FR, FR_CATCHED);
  }

  VMI_GOTO(I_EXIT);
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
The B_THROW code is the implementation for   throw/1.  The call walks up
the stack, looking for a frame running catch/3 on which it can unify the
exception code. It then cuts all  choicepoints created since throw/3. If
throw/3 is not found, it sets  the   query  exception  field and returns
failure. Otherwise, it will simulate an I_USERCALL0 instruction: it sets
the FR and lTop as if it  was   running  the  throw/3 predicate. Then it
pushes the recovery goal from throw/3 and jumps to I_USERCALL0.

Note that exceptions are placed on the stack using PL_raise_exception(),
which uses duplicate_term() and  freezeGlobal()   to  make the exception
term immune for undo operations.

(*) If the exception is not caught, we  try to print it and enable trace
mode. However, we should be careful about   this  if the exception is an
out-of-stack exception because the trace runs in Prolog and is likely to
run fatally out of stack if we start the tracer immediately. That is the
role of trace_if_space(). As long as there is no space, the exception is
unwinded until there is space. Unfortunately,   this  means that some of
the context of the exception is lost. Note that  we need to run GC if we
ran out of global stack because  the   stack  is  frozen to preserve the
exception ball.

Overflow exceptions are supposed to be rare,   but  need to be processed
with care to avoid a fatal overflow   when  processing the exception and
its cleanup or debug actions.  We want two things:

  - Get, before doing any calls to Prolog, a sensible amount of free
    space.
  - GC and trim before resuming normal execution to free up and
    deallocate as much as possible space.

On each unwind action, we must  reset Stack->gced_size and increment the
inference count to make sure that the  time   we  run  out of memory the
system will actually consider GC. See considerGarbageCollect().
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(B_THROW, 0, 0, ())
{ term_t catchfr_ref;
  int start_tracer;
  Stack outofstack;
  int rewritten;

  PL_raise_exception(argFrameP(lTop, 0) - (Word)lBase);
  THROW_EXCEPTION;				/* sets origin */

b_throw:
  LD->fast_condition = NULL;		/* A_FUNC exceptions */
  rewritten = 0;
  QF  = QueryFromQid(qid);
  aTop = QF->aSave;
  assert(exception_term);
  outofstack = LD->outofstack;
  LD->outofstack = NULL;
  fid_t fid;

  if ( lTop < (LocalFrame)argFrameP(FR, FR->predicate->functor->arity) )
    lTop = (LocalFrame)argFrameP(FR, FR->predicate->functor->arity);

  DEBUG(CHK_SECURE, checkData(valTermRef(exception_term)));
  DEBUG(MSG_THROW,
	{ fid_t fid = PL_open_foreign_frame();
	  Sdprintf("[%d] Throwing (from line %d): ",
		   PL_thread_self(), throwed_from_line);
	  PL_write_term(Serror, exception_term, 1200, 0);
	  Sdprintf("\n");
	  PL_discard_foreign_frame(fid);
	});

  if ( has_emergency_space(&LD->stacks.local, sizeof(struct localFrame)) )
    fid = open_foreign_frame(PASS_LD1);
  else
    fid = 0;

again:
  SAVE_REGISTERS(qid);
  catchfr_ref = findCatcher(FR, LD->choicepoints, exception_term PASS_LD);
  LOAD_REGISTERS(qid);
  DEBUG(MSG_THROW,
	{ if ( catchfr_ref )
	  { LocalFrame fr = (LocalFrame)valTermRef(catchfr_ref);
	    Sdprintf("[%d]: found catcher at %ld\n",
		     PL_thread_self(), (long)levelFrame(fr));
	  } else
	  { Sdprintf("[%d]: not caught\n", PL_thread_self());
	  }
	});

  DEBUG(CHK_SECURE,
	{ SAVE_REGISTERS(qid);
	  checkData(valTermRef(exception_term));
	  checkStacks(NULL);
	  LOAD_REGISTERS(qid);
	});

  if ( debugstatus.suspendTrace == FALSE && !rewritten++ &&
       !uncachableException(exception_term PASS_LD) && /* e.g., $aborted */
       !resourceException(exception_term PASS_LD) )
  { int rc;

    SAVE_REGISTERS(qid);
    rc = exception_hook(qid, consTermRef(FR), catchfr_ref PASS_LD);
    LOAD_REGISTERS(qid);

    if ( rc && fid )
    { DEBUG(MSG_THROW,
	    Sdprintf("Exception was rewritten to: ");
	    PL_write_term(Serror, exception_term, 1200, 0);
	    Sdprintf(" (retrying)\n"));

      PL_rewind_foreign_frame(fid);
      clear((LocalFrame)valTermRef(catchfr_ref), FR_CATCHED);
      goto again;
    }
  }
  if ( fid )
    PL_close_foreign_frame(fid);

#if O_DEBUGGER
  start_tracer = FALSE;
  if ( !catchfr_ref &&
       !PL_same_term(exception_term, exception_printed) &&
       false(QueryFromQid(qid), PL_Q_CATCH_EXCEPTION) )
  { term_t rc;

    SAVE_REGISTERS(qid);
    rc = isCaughtInOuterQuery(qid, exception_term PASS_LD);
    DEBUG(MSG_THROW, Sdprintf("Caught in outer: %s\n", rc ? "YES" : "NO"));
    LOAD_REGISTERS(qid);

    if ( !rc )					/* uncaught exception */
    { SAVE_REGISTERS(qid);
      if ( PL_is_functor(exception_term, FUNCTOR_error2) &&
	   truePrologFlag(PLFLAG_DEBUG_ON_ERROR) )
      { debugmode(TRUE, NULL);
	if ( !trace_if_space() )		/* see (*) */
	{ start_tracer = TRUE;
	} else
	{ int rc;
	  trimStacks(FALSE PASS_LD);		/* restore spare stacks */
	  rc = printMessage(ATOM_error, PL_TERM, exception_term);
	  (void)rc;
	  PL_put_term(exception_printed, exception_term);
	}
      } else if ( classify_exception(exception_term) != EXCEPT_ABORT )
      { int rc = printMessage(ATOM_error,
			      PL_FUNCTOR_CHARS, "unhandled_exception", 1,
			        PL_TERM, exception_term);
	(void)rc;
	PL_put_term(exception_printed, exception_term);
      }
      LOAD_REGISTERS(qid);
    }
  }

  if ( debugstatus.debugging )
  { for( ;
	 FR && FR > (LocalFrame)valTermRef(catchfr_ref);
	 PC = FR->programPointer,
	 FR = FR->parent )
    { Choice ch = findStartChoice(FR, LD->choicepoints);
      void *l_top;

      environment_frame = FR;
      ARGP = argFrameP(FR, 0);		/* otherwise GC sees `new' arguments */
      LD->statistics.inferences++;	/* box exit, needed for GC */

      if ( ch )
      { int printed = PL_same_term(exception_printed, exception_term);
	term_t chref = consTermRef(ch);
	int rc;

	lTop = (LocalFrame)(BFR+1);
	DEBUG(CHK_SECURE,
	      { SAVE_REGISTERS(qid);
		checkStacks(NULL);
		LOAD_REGISTERS(qid);
	      });
	SAVE_REGISTERS(qid);
	dbg_discardChoicesAfter((LocalFrame)ch, FINISH_EXTERNAL_EXCEPT PASS_LD);
	LOAD_REGISTERS(qid);
	ch = (Choice)valTermRef(chref);
	Undo(ch->mark);
	DiscardMark(ch->mark);
	clearLocalVariablesFrame(FR);
	PL_put_term(LD->exception.pending, exception_term);
	if ( printed )
	  PL_put_term(exception_printed, exception_term);

	DEBUG(CHK_SECURE,
	      { SAVE_REGISTERS(qid);
	        checkStacks(NULL);
		LOAD_REGISTERS(qid);
		ch = (Choice)valTermRef(chref);
	      });

	SAVE_REGISTERS(qid);
	rc = tracePort(FR, ch, EXCEPTION_PORT, PC PASS_LD);
	LOAD_REGISTERS(qid);

	switch( rc )
	{ case ACTION_RETRY:
	    SAVE_REGISTERS(qid);
	    discardChoicesAfter(FR, FINISH_CUT PASS_LD);
	    resumeAfterException(TRUE, outofstack);
	    LOAD_REGISTERS(qid);
	    DEF = FR->predicate;
	    FR->clause = NULL;
	    goto retry_continue;
	  case ACTION_ABORT:
	    THROW_EXCEPTION;
	}

	setVar(*valTermRef(LD->exception.pending));
      }

					/* discard as much as we can from the local stack */
      l_top = argFrameP(FR, FR->predicate->functor->arity);
      FR->clause = NULL;		/* We do not care about the arguments */
      DEBUG(MSG_UNWIND_EXCEPTION,
	    Sdprintf("l_top above [%d] %s: %p\n",
		     (int)FR->level, predicateName(FR->predicate), l_top));
      if ( l_top < (void*)(BFR+1) )
      { DEBUG(MSG_UNWIND_EXCEPTION,
	      Sdprintf("Include choice points: %p -> %p\n", l_top, (void*)(BFR+1)));
        l_top = (void*)(BFR+1);
      }
      lTop = l_top;

      while(fli_context > (FliFrame)lTop)
        fli_context = fli_context->parent;

      DEBUG(CHK_SECURE,
	    { SAVE_REGISTERS(qid);
	      memset(lTop, 0xfb, lMax-lTop);
	      checkStacks(NULL);
	      LOAD_REGISTERS(qid)
	    });

      if ( true(FR, FR_WATCHED) )
      { SAVE_REGISTERS(qid);
	dbg_discardChoicesAfter(FR, FINISH_EXTERNAL_EXCEPT PASS_LD);
	LOAD_REGISTERS(qid);
	discardFrame(FR PASS_LD);
	SAVE_REGISTERS(qid);
	frameFinished(FR, FINISH_EXCEPT PASS_LD);
	LOAD_REGISTERS(qid);
      } else
      { SAVE_REGISTERS(qid);
	dbg_discardChoicesAfter(FR, FINISH_EXTERNAL_EXCEPT_UNDO PASS_LD);
	LOAD_REGISTERS(qid);
	discardFrame(FR PASS_LD);
      }

      if ( start_tracer )		/* See (*) */
      {	SAVE_REGISTERS(qid);
	exceptionUnwindGC();
	LOAD_REGISTERS(qid);

	DEBUG(MSG_STACK_OVERFLOW,
	      Sdprintf("Unwinding for exception. g+l+t used = %zd+%zd+%zd\n",
		       usedStack(global),
		       usedStack(local),
		       usedStack(trail)));

	if ( trace_if_space() )
	{ int rc;
	  start_tracer = FALSE;
	  SAVE_REGISTERS(qid);
	  LD->critical++;		/* do not handle signals */
	  trimStacks(FALSE PASS_LD);
	  rc = printMessage(ATOM_error, PL_TERM, exception_term);
	  (void)rc;
	  LD->critical--;
	  LOAD_REGISTERS(qid);
	}
      }
    }

    if ( start_tracer )
    { Sdprintf("Failed to print resource exception due to lack of space\n");
      SAVE_REGISTERS(qid);
      PL_write_term(Serror, exception_term, 1200, PL_WRT_QUOTED|PL_WRT_NEWLINE);
      LOAD_REGISTERS(qid);
    }
  } else
#endif /*O_DEBUGGER*/
  { DEBUG(3, Sdprintf("Unwinding for exception\n"));

    for( ;
	 FR && FR > (LocalFrame)valTermRef(catchfr_ref);
	 PC = FR->programPointer,
	 FR = FR->parent )
    { environment_frame = FR;
      ARGP = argFrameP(FR, 0);		/* otherwise GC sees `new' arguments */
      LD->statistics.inferences++;	/* box exit, needed for GC */

      SAVE_REGISTERS(qid);
      dbg_discardChoicesAfter(FR, FINISH_EXTERNAL_EXCEPT_UNDO PASS_LD);
      LOAD_REGISTERS(qid);

      lTop = (LocalFrame)argFrameP(FR, FR->predicate->functor->arity);
      discardFrame(FR PASS_LD);
      if ( true(FR, FR_WATCHED) )
      { SAVE_REGISTERS(qid);
	frameFinished(FR, FINISH_EXCEPT PASS_LD);
	LOAD_REGISTERS(qid);
      }
      DEBUG(CHK_SECURE, checkData(valTermRef(exception_term)));
    }
  }

					/* re-fetch (test cleanup(clean-5)) */
  DEBUG(CHK_SECURE, checkData(valTermRef(exception_term)));
  LD->statistics.inferences++;		/* box exit, needed for GC */


  if ( catchfr_ref )
  { word w;

    assert(FR == (LocalFrame)valTermRef(catchfr_ref));

    SAVE_REGISTERS(qid);
    dbg_discardChoicesAfter(FR, FINISH_EXTERNAL_EXCEPT_UNDO PASS_LD);
    LOAD_REGISTERS(qid);
    environment_frame = FR;
					/* re-unify */
    PL_unify(consTermRef(argFrameP(FR, 1)), exception_term);
    lTop = (LocalFrame) argFrameP(FR, 3); /* above the catch/3 */
    if ( (w=uncachableException(exception_term PASS_LD)) )
    { Word p = gTop;

      if ( !has_emergency_space(&LD->stacks.global, 3*sizeof(word)) )
	fatalError("Cannot wrap abort exception\n");

      argFrame(lTop, 0) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
      p[0] = FUNCTOR_drecover_and_rethrow2;
      p[1] = argFrame(FR, 2);
      p[2] = w;
      gTop = p+3;
    } else
    { argFrame(lTop, 0) = argFrame(FR, 2);  /* copy recover goal */
    }

    PC = findCatchExit();
    { word lSafe = consTermRef(lTop);
      lTop = (LocalFrame)argFrameP(lTop, 1);
      ARGP = (Word)lTop;
      SAVE_REGISTERS(qid);
      resumeAfterException(TRUE, outofstack);
      LOAD_REGISTERS(qid);
      lTop = (LocalFrame)valTermRef(lSafe);
    }

    VMI_GOTO(I_USERCALL0);
  } else
  { QF = QueryFromQid(qid);		/* may be shifted */
    set(QF, PL_Q_DETERMINISTIC);
    FR = environment_frame = &QF->top_frame;
    lTop = (LocalFrame)argFrameP(FR, FR->predicate->functor->arity);

    Undo(QF->choice.mark);
    DiscardMark(QF->choice.mark);
    QF->foreign_frame = PL_open_foreign_frame();
    QF->exception = PL_copy_term_ref(exception_term);

    SAVE_REGISTERS(qid);
    resumeAfterException(false(QF, PL_Q_PASS_EXCEPTION), outofstack);
    LOAD_REGISTERS(qid);
    if ( PL_pending(SIG_GC) )
    { SAVE_REGISTERS(qid);
      garbageCollect();
      LOAD_REGISTERS(qid);
    }
    QF = QueryFromQid(qid);		/* may be shifted: recompute */

    assert(LD->exception.throw_environment == &throw_env);
    LD->exception.throw_environment = throw_env.parent;

    DEBUG(MSG_THROW,
	  { Sdprintf("Leaving exception after callback: ");
	    PL_write_term(Serror, QF->exception, 1200, 0);
	    Sdprintf("\n");
	  });

    return (QF->flags & PL_Q_EXT_STATUS) ? PL_S_EXCEPTION : FALSE;
  }
}
#endif /*O_CATCHTHROW*/


		 /*******************************
		 *	    META-CALLING	*
		 *******************************/

BEGIN_SHAREDVARS
  Module module;
  functor_t functor;
  int arity;
  Word args;

#ifdef O_CALL_AT_MODULE
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CALLATM: procedure-module, context-module, procedure
The procedure-module is provided to support the decompiler.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALLATM, VIF_BREAK, 3, (CA1_MODULE, CA1_MODULE, CA1_PROC))
{ PC++;
  VMI_GOTO(I_CALLM);
}

VMI(I_DEPARTATMV, VIF_BREAK, 3, (CA1_MODULE, CA1_VAR, CA1_PROC))
{ if ( (void *)BFR > (void *)FR || !truePrologFlag(PLFLAG_LASTCALL) )
  { VMI_GOTO(I_CALLATMV);
  } else
  { Word ap;
    int iv;

    PC++;
    iv = (int)*PC++;

    ap = varFrameP(FR, iv);
    deRef(ap);
    if ( isTextAtom(*ap) )
    { Module m = lookupModule(*ap);

      setContextModule(FR, m);
      VMI_GOTO(I_DEPART);
    } else
    { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_module,
	       pushWordAsTermRef(ap));
      popTermRef();
      THROW_EXCEPTION;
    }
  }
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This instruction deals with  @(Callable,  Module),   where  Module  is a
variable. The module argument can be NULL.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALLATMV, VIF_BREAK, 3, (CA1_MODULE, CA1_VAR, CA1_PROC))
{ Word ap;
  int iv;
  Procedure proc;

  PC++;
  iv = (int)*PC++;
  proc = (Procedure)*PC++;

  ap = varFrameP(FR, iv);
  deRef(ap);
  if ( isTextAtom(*ap) )
  { module = lookupModule(*ap);
    DEF = proc->definition;
    NFR = lTop;

    goto mcall_cont;
  } else
  { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_module,
	     pushWordAsTermRef(ap));
    popTermRef();
    THROW_EXCEPTION;
  }
}

#endif

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_CALLM deals with qualified calls. The unfortunate  task is to sort out
the context module for calling a transparent  procedure. This job is the
same as the end of I_USERCALL
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALLM, VIF_BREAK, 2, (CA1_MODULE, CA1_PROC))
{ module = (Module)*PC++;
  DEF    = ((Procedure)*PC++)->definition;
  NFR = lTop;

  goto mcall_cont;
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_USERCALL0 is generated by the compiler if a variable is encountered as
a subclause. Note that the compount   statement  opened here is encloses
also I_CALL. This allows us to use   local register variables, but still
jump to the `normal_call' label to do the common part of all these three
virtual machine instructions.

I_USERCALL0 has the task of  analysing  the   goal:  it  should fill the
->procedure slot of the new frame and  save the current program counter.
It also is responsible of filling the   argument part of the environment
frame with the arguments of the term.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_USERCALL0, VIF_BREAK, 0, ())
{ word goal;
  Word a;

  module = NULL;
  NFR = lTop;
  a = argFrameP(NFR, 0);		/* get the goal */
  if ( !(a = stripModule(a, &module, 0 PASS_LD)) )
    THROW_EXCEPTION;

  DEBUG(MSG_CALL,
	{ term_t g = pushWordAsTermRef(a);
	  LocalFrame ot = lTop;
	  lTop += 100;
	  pl_writeln(g);
	  popTermRef();
	  lTop = ot;
	});
  DEBUG(CHK_SECURE, checkStacks(NULL));

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Determine the functor definition associated with the goal as well as the
arity and a pointer to the argument vector of the goal.

If the goal is not a  simple  goal,   the  body  is  compiled to `local'
clause. The compilation mode is presented to compileClause() by the NULL
`head'. This compilation-mode  constructs  a   stack-frame  whose  first
argument is the  goal-term,  followed   by  large  structures (compound,
string) from the arguments, followed  by   the  normal  local variables,
followed by the VM codes and, the   clause structure and finally a dummy
list for the clause-chain  (ClauseRef)  used   for  the  frames ->clause
field.

The clause data is discarded automatically  if the frame is invalidated.
Note that compilation does not give contained   atoms a reference as the
atom is referenced by the goal-term anyway.

Creating a `local clause'  is  needed   for  control  structures and for
meta-calling call/N for N >  8  as   there  are  no real predicates that
provide a backup. In  the  case  we   are  under  reset/3,  we can never
generate a local clause while  passing  call(<call/N>)   for  N  >  8 to
'$meta_call'/1 however leads to an infinite loop. For now we generate an
undefined predicate for call/N.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

  goal = *a;
  if ( isCallableAtom(goal) )
  { functor = lookupFunctorDef(goal, 0);
    arity   = 0;
    args    = NULL;
  } else if ( isTerm(goal) )
  { FunctorDef fd;

    functor = functorTerm(goal);
    if ( functor == FUNCTOR_colon2 )
      goto call_type_error;

    fd = valueFunctor(functor);
    if ( !isCallableAtom(fd->name) )
      goto call_type_error;
    if ( false(fd, CONTROL_F) &&
	 !(fd->name == ATOM_call && fd->arity > 8) )
    { args    = argTermP(goal, 0);
      arity   = (int)fd->arity;
    } else if ( true(FR, FR_INRESET) )
    { if ( false(fd, CONTROL_F) && !(fd->name == ATOM_call) )
      { /* arity > 8 will raise existence error */
	args  = argTermP(goal, 0);
	arity = (int)fd->arity;
      } else
      { DEF = GD->procedures.dmeta_call1->definition;
	goto mcall_cont;
      }
    } else
    { Clause cl;
      int rc;

      if ( fd->functor == FUNCTOR_xpceref2 &&
	   !checkCallAtContextInstantiation(a PASS_LD) )
	THROW_EXCEPTION;

      lTop = NFR;
      setNextFrameFlags(NFR, FR);
      rc = compileClause(&cl, NULL, a, PROCEDURE_dcall1, module, 0 PASS_LD);
      if ( rc == FALSE )
	THROW_EXCEPTION;
      if ( rc == LOCAL_OVERFLOW )
      { size_t room = roomStack(local);
	term_t lTopH = consTermRef(lTop);

	lTop = (LocalFrame)argFrameP(NFR, 1);
	SAVE_REGISTERS(qid);
	rc = growLocalSpace__LD(room*2, ALLOW_SHIFT PASS_LD);
	LOAD_REGISTERS(qid);
	lTop = (LocalFrame)valTermRef(lTopH);
	if ( rc != TRUE )
	{ raiseStackOverflow(rc);
	  THROW_EXCEPTION;
	}
	VMI_GOTO(I_USERCALL0);
      }

      DEF		  = NFR->predicate;
      DEBUG(CHK_SECURE, assert(DEF == PROCEDURE_dcall1->definition));
      NFR->parent	  = FR;
      NFR->programPointer = PC;
#ifdef O_PROFILE
      NFR->prof_node      = FR->prof_node;
#endif
#ifdef O_LOGICAL_UPDATE
      cl->generation.erased = ~(gen_t)0;
      cl->generation.created = global_generation();
      setGenerationFrame(NFR);
#endif
      PC = cl->codes;

      enterDefinition(DEF);
      environment_frame = FR = NFR;
      ARGP = argFrameP(lTop, 0);

      NEXT_INSTRUCTION;
    }
  } else
  {
  call_type_error:
    DEBUG(CHK_SECURE, checkStacks(NULL));
    PL_error(NULL, 0, NULL, ERR_TYPE,
	     ATOM_callable, pushWordAsTermRef(argFrameP(NFR, 0)));
    popTermRef();
    THROW_EXCEPTION;
  }
  goto i_usercall_common;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I_USERCALLN: translation of call(Goal, Arg1, ...)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_USERCALLN, VIF_BREAK, 1, (CA1_INTEGER))
{ Word a;
  int callargs = (int)*PC++;
  word goal;

  NFR = lTop;
  a = argFrameP(NFR, 0);		/* get the (now) instantiated */
  deRef(a);			/* variable */

  module = NULL;
  if ( !(a = stripModule(a, &module, 0 PASS_LD)) )
    THROW_EXCEPTION;

  if ( isTextAtom(goal = *a) )
  { arity   = 0;
    functor = lookupFunctorDef(goal, callargs);
    args    = NULL;
  } else if ( isTerm(goal) )
  { FunctorDef fdef = valueFunctor(functorTerm(goal));

    if ( !isCallableAtom(fdef->name) )
      goto call_type_error;
    arity   = (int)fdef->arity;
    functor = lookupFunctorDef(fdef->name, arity + callargs);
    args    = argTermP(goal, 0);
  } else
  { goto call_type_error;
  }

  if ( arity != 1 )
  { int i, shift = arity - 1;

    a = argFrameP(NFR, 1);	/* pointer to 1-st arg */

    if ( shift > 0 )
    { for(i=callargs-1; i>=0; i--)
      { if ( isRef(a[i]) )
	{ Word a1 = unRef(a[i]);

	  if ( a1 >= a && a1 < a+arity )
	    a[i+shift] = makeRef(a1+shift);
	  else
	    a[i+shift] = a[i];
	} else
	  a[i+shift] = a[i];
      }
    } else
    { for(i=0; i < callargs; i++)
      { if ( isRef(a[i]) )
	{ Word a1 = unRef(a[i]);

	  if ( a1 >= a && a1 < a+arity )
	    a[i+shift] = makeRef(a1+shift);
	  else
	    a[i+shift] = a[i];
	} else
	  a[i+shift] = a[i];
      }
    }
  }

i_usercall_common:
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Now scan the argument vector of the goal and fill the arguments  of  the
frame.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  if ( arity > 0 )
  { if ( arity > MAXARITY )
    { fid_t fid;

      lTop = (LocalFrame)argFrameP(NFR, 1);
      fid = PL_open_foreign_frame();
      PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_max_arity);
      PL_close_foreign_frame(fid);
      THROW_EXCEPTION;
    }

    ARGP = argFrameP(NFR, 0);

    for(; arity-- > 0; ARGP++, args++)
      *ARGP = linkVal(args);
  }

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Find  the  associated  procedure  and  its  definition.  The  latter  is
unfortunate, but we need to know the transparent status of the predicate
to be called to get the context module   right. We must build a complete
environment before we can call trapUndefined() to make shift/GC happy.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

  DEF = resolveProcedure(functor, module)->definition;

mcall_cont:
  setNextFrameFlags(NFR, FR);
  if ( !DEF->impl.any.defined && false(DEF, PROC_DEFINED) )
  { term_t nref = consTermRef(NFR);
    NFR->parent         = FR;
    setFramePredicate(NFR, DEF);	/* TBD */
    setGenerationFrame(NFR);
    NFR->programPointer = PC;		/* save PC in child */
    NFR->clause         = NULL;
#ifdef O_PROFILE
    NFR->prof_node      = NULL;
#endif
    setNextFrameFlags(NFR, FR);
    environment_frame = FR = NFR;
    lTop = (LocalFrame)argFrameP(NFR, DEF->functor->arity);

    SAVE_REGISTERS(qid);
    DEF = trapUndefined(DEF PASS_LD);
    LOAD_REGISTERS(qid);
    NFR = (LocalFrame)valTermRef(nref);

    FR = FR->parent;
#ifdef O_PLMT
  } else if ( true(DEF, P_THREAD_LOCAL) )
  { DEF = getProcDefinition__LD(DEF PASS_LD);
#endif
  }

  if ( true(DEF, P_TRANSPARENT) )
    setContextModule(NFR, module);

  goto normal_call;
}


/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
reset(:Goal, ?Ball, -Continuation) :-
    '$reset'.

Where '$reset' maps to

    I_RESET
    I_EXITRESET

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_RESET, 0, 0, ())
{ set(FR, FR_INRESET);
			  /* = B_VAR0 */
  *argFrameP(lTop, 0) = linkVal(argFrameP(FR, 0));
  VMI_GOTO(I_USERCALL0);
}


VMI(I_EXITRESET, 0, 0, ())
{ Word p = argFrameP(FR, 2);

  deRef(p);
  if ( canBind(*p) )
  { if ( !hasGlobalSpace(0) )
    { int rc;

      SAVE_REGISTERS(qid);
      rc = ensureGlobalSpace(0, ALLOW_GC);
      LOAD_REGISTERS(qid);
      if ( rc != TRUE )
      { raiseStackOverflow(rc);
	THROW_EXCEPTION;
      }

      p = argFrameP(FR, 2);
      deRef(p);
    }
    bindConst(p, consInt(0));
    NEXT_INSTRUCTION;
  } else
  { PL_uninstantiation_error(pushWordAsTermRef(p));
    popTermRef();
    THROW_EXCEPTION;
  }
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
$call_continuation(Cont)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_CALLCONT, 0, 1, (CA1_VAR))
{ Word cp = varFrameP(FR, (int)*PC++);

  deRef(cp);
  if ( hasFunctor(*cp, FUNCTOR_call1) )
  { *ARGP++ = linkVal(argTermP(*cp, 0));
    VMI_GOTO(I_USERCALL0);
  } else
  { term_t cont = pushWordAsTermRef(cp);
    Code pc;

    SAVE_REGISTERS(qid);
    pc = push_continuation(cont, FR, PC PASS_LD);
    LOAD_REGISTERS(qid);
    popTermRef();

    if ( pc )
    { PC = pc;
      FR = environment_frame;
      DEF = FR->predicate;
      ARGP = argFrameP(lTop, 0);
      NEXT_INSTRUCTION;
    } else
    { THROW_EXCEPTION;
    }
  }
}

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
shift(Ball) :-
    '$shift'(Ball).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

VMI(I_SHIFT, 0, 1, (CA1_VAR))
{ Word ballp  = varFrameP(FR, (int)*PC++);
  term_t ball = pushWordAsTermRef(ballp);
  Code pc;
  fid_t fid;

  SAVE_REGISTERS(qid);
  fid = PL_open_foreign_frame();
  pc = shift(ball PASS_LD);
  PL_close_foreign_frame(fid);
  LOAD_REGISTERS(qid);

  popTermRef();

  if ( pc )
  { PC = pc;
    FR = environment_frame;
    DEF = FR->predicate;
    ARGP = argFrameP(lTop, 0);
    NEXT_INSTRUCTION;
  } else
  { THROW_EXCEPTION;
  }
}

END_SHAREDVARS
