yap-6.3/C/computils.c

/*************************************************************************
*									 *
*	 YAP Prolog 							 *
*									 *
*	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
*									 *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
*									 *
**************************************************************************
*									 *
* File:		computils.c						 *
* comments:	some useful routines for YAP's compiler			 *
*									 *
* Last rev:     $Date: 2007-11-26 23:43:08 $							 *
* $Log: not supported by cvs2svn $
* Revision 1.31  2007/11/06 17:02:12  vsc
* compile ground terms away.
*
* Revision 1.30  2006/09/20 20:03:51  vsc
* improve indexing on floats
* fix sending large lists to DB
*
* Revision 1.29  2005/12/05 17:16:10  vsc
* write_depth/3
* overflow handlings and garbage collection
* Several ipdates to CLPBN
* dif/2 could be broken in the presence of attributed variables.
*
* Revision 1.28  2005/09/08 22:06:44  rslopes
* BEAM for YAP update...
*
* Revision 1.27  2005/07/06 15:10:04  vsc
* improvements to compiler: merged instructions and fixes for ->
*
* Revision 1.26  2005/01/04 02:50:21  vsc
* - allow MegaClauses with blobs
* - change Diffs to be thread specific
* - include Christian's updates
*
* Revision 1.25  2004/11/19 17:14:13  vsc
* a few fixes for 64 bit compiling.
*
* Revision 1.24  2004/04/16 19:27:31  vsc
* more bug fixes
*
* Revision 1.23  2004/03/10 14:59:55  vsc
* optimise -> for type tests
*									 *
*									 *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif

/*
 * This file includes a set of utilities, useful to the several compilation
 * modules 
 */

#include "Yap.h"
#include "Yatom.h"
#include "YapHeap.h"
#include "compile.h"
#include "yapio.h"
#if HAVE_STRING_H
#include <string.h>
#endif

#ifdef DEBUG
static void ShowOp(const char *, struct PSEUDO *);
#endif /* DEBUG */

/*
 * The compiler creates an instruction chain which will be assembled after
 * afterwards 
 */



typedef struct mem_blk {
  union {
    struct mem_blk *next;
    double fill;
  } ublock;
  char contents[1];
} MemBlk;

#define CMEM_BLK_SIZE (4*4096)
#define FIRST_CMEM_BLK_SIZE (16*4096)

static char *
AllocCMem (UInt size, struct intermediates *cip)
{
#if SIZEOF_INT_P==8
  size = (size + 7) & ((UInt)-8);
#else
  size = (size + 3) & ((UInt)0xfffffffc);
#endif
#if USE_SYSTEM_MALLOC
  if (!cip->blks || cip->blk_cur+size > cip->blk_top) {
    UInt blksz;
    struct mem_blk *p;

    if (size > CMEM_BLK_SIZE)
      blksz = size+sizeof(struct mem_blk);
    else
      blksz = CMEM_BLK_SIZE;
    if (!cip->blks) {
      CACHE_REGS
      if (LOCAL_CMemFirstBlock) {
	p = LOCAL_CMemFirstBlock;
	blksz = LOCAL_CMemFirstBlockSz;
	p->ublock.next = NULL;
      } else {
	if (blksz < FIRST_CMEM_BLK_SIZE)
	  blksz = FIRST_CMEM_BLK_SIZE;
	p = (struct mem_blk *)Yap_AllocCodeSpace(blksz);
	if (!p) {
	  LOCAL_Error_Size = size;
	  save_machine_regs();
	  siglongjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH);
	}
	LOCAL_CMemFirstBlock = p;
	LOCAL_CMemFirstBlockSz = blksz;
      }
    } else {
      p = (struct mem_blk *)Yap_AllocCodeSpace(blksz);
      if (!p) {
	CACHE_REGS
	LOCAL_Error_Size = size;
	save_machine_regs();
	siglongjmp(cip->CompilerBotch, OUT_OF_HEAP_BOTCH);
      }
    }
    p->ublock.next = cip->blks;
    cip->blks = p;
    cip->blk_cur = p->contents;
    cip->blk_top = (char *)p+blksz;
  }
  {
    char *out = cip->blk_cur;
    cip->blk_cur += size;
    return out;
  }
#else
  char *p;
  if (ASP <= CellPtr (cip->freep) + 256) {
    CACHE_REGS
    LOCAL_Error_Size = 256+((char *)cip->freep - (char *)HR);
    save_machine_regs();
    siglongjmp(cip->CompilerBotch, OUT_OF_STACK_BOTCH);
  } 
  p = cip->freep;
  cip->freep += size;
  return p;
#endif
}

void
Yap_ReleaseCMem (struct intermediates *cip)
{
#if USE_SYSTEM_MALLOC
  CACHE_REGS
  struct mem_blk *p = cip->blks;
  while (p) {
    struct mem_blk *nextp = p->ublock.next;
    if (p != LOCAL_CMemFirstBlock)
      Yap_FreeCodeSpace((ADDR)p);
    p = nextp;
  }
  cip->blks = NULL;
  if (cip->label_offset &&
      cip->label_offset != LOCAL_LabelFirstArray) {
    Yap_FreeCodeSpace((ADDR)cip->label_offset);
  }
#endif
  cip->label_offset = NULL;
}

char *
Yap_AllocCMem (UInt size, struct intermediates *cip)
{
  return AllocCMem(size, cip);
}

static int
is_a_test(Term arg, Term mod)
{
  if (IsVarTerm (arg)) {
    return FALSE;
  }
  if (IsVarTerm (arg) || !IsAtomTerm(mod)) {
    return FALSE;
  }
  if (IsAtomTerm (arg)) {
      Atom At = AtomOfTerm (arg);
      PredEntry *pe = RepPredProp(PredPropByAtom(At, mod));
      if (EndOfPAEntr(pe))
	return FALSE;
      return pe->PredFlags & TestPredFlag;
  }
  if (IsApplTerm (arg)) {
    Functor f = FunctorOfTerm (arg);

    if (f == FunctorModule) {
      return is_a_test(ArgOfTerm(2,arg), ArgOfTerm(1,arg));
    } else if (f == FunctorComma) {
      return
	is_a_test(ArgOfTerm(1,arg), mod) &&
	is_a_test(ArgOfTerm(2,arg), mod);
    } else {
      PredEntry *pe = RepPredProp(PredPropByFunc(f, mod));

      if (EndOfPAEntr(pe))
	return FALSE;
      if (pe->PredFlags & AsmPredFlag) {
	int op = pe->PredFlags & 0x7f;
	if (op >= _atom && op <= _eq) {
	  return TRUE;
	}
	return FALSE;
      }      
      return pe->PredFlags & (TestPredFlag|BinaryPredFlag);
    }
  }
  return FALSE;
}

int
Yap_is_a_test_pred (Term arg, Term mod)
{
  return is_a_test(arg, mod);
}

void
Yap_emit (compiler_vm_op o, Int r1, CELL r2, struct intermediates *cip)
{
  PInstr *p;
  p = (PInstr *) AllocCMem (sizeof (*p), cip);
  p->op = o;
  p->rnd1 = r1;
  p->rnd2 = r2;
  p->nextInst = NULL;
  if (cip->cpc == NIL) {
    cip->cpc = cip->CodeStart = p;
  } else {
    cip->cpc->nextInst = p;
    cip->cpc = p;
  }
}

void
Yap_emit_3ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, struct intermediates *cip)
{
  PInstr *p;
  p = (PInstr *) AllocCMem (sizeof (*p)+sizeof(CELL), cip);
  p->op = o;
  p->rnd1 = r1;
  p->rnd2 = r2;
  p->rnd3 = r3;
  p->nextInst = NIL;
  if (cip->cpc == NIL)
    cip->cpc = cip->CodeStart = p;
  else
    {
      cip->cpc->nextInst = p;
      cip->cpc = p;
    }
}

void
Yap_emit_4ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3, CELL r4, struct intermediates *cip)
{
  PInstr *p;
  p = (PInstr *) AllocCMem (sizeof (*p)+2*sizeof(CELL), cip);
  p->op = o;
  p->rnd1 = r1;
  p->rnd2 = r2;
  p->rnd3 = r3;
  p->rnd4 = r4;
  p->nextInst = NIL;
  if (cip->cpc == NIL)
    cip->cpc = cip->CodeStart = p;
  else
    {
      cip->cpc->nextInst = p;
      cip->cpc = p;
    }
}

CELL *
Yap_emit_extra_size (compiler_vm_op o, CELL r1, int size, struct intermediates *cip)
{
  PInstr *p;
  p = (PInstr *) AllocCMem (sizeof (*p) + size - CellSize, cip);
  p->op = o;
  p->rnd1 = r1;
  p->nextInst = NIL;
  if (cip->cpc == NIL)
    cip->cpc = cip->CodeStart = p;
  else
    {
      cip->cpc->nextInst = p;
      cip->cpc = p;
    }
  return p->arnds;
}

static void
bip_name(Int op, char *s)
{
  switch (op) {
  case _atom:
    strcpy(s,"atom");
    break;
  case _atomic:
    strcpy(s,"atomic");
    break;
  case _integer:
    strcpy(s,"integer");
    break;
  case _nonvar:
    strcpy(s,"nonvar");
    break;
  case _number:
    strcpy(s,"number");
    break;
  case _var:
    strcpy(s,"var");
    break;
  case _cut_by:
    strcpy(s,"cut_by");
    break;
  case _save_by:
    strcpy(s,"save_by");
    break;
  case _db_ref:
    strcpy(s,"db_ref");
    break;
  case _compound:
    strcpy(s,"compound");
    break;
  case _float:
    strcpy(s,"float");
    break;
  case _primitive:
    strcpy(s,"primitive");
    break;
  case _equal:
    strcpy(s,"equal");
    break;
  case _dif:
    strcpy(s,"dif");
    break;
  case _eq:
    strcpy(s,"eq");
    break;
  case _functor:
    strcpy(s,"functor");
    break;
  case _plus:
    strcpy(s,"plus");
    break;
  case _minus:
    strcpy(s,"minus");
    break;
  case _times:
    strcpy(s,"times");
    break;
  case _div:
    strcpy(s,"div");
    break;
  case _and:
    strcpy(s,"and");
    break;
  case _or:
    strcpy(s,"or");
    break;
  case _sll:
    strcpy(s,"sll");
    break;
  case _slr:
    strcpy(s,"slr");
    break;
  case _arg:
    strcpy(s,"arg");
    break;
  default:
    strcpy(s,"");
    break;
  }
}

void
Yap_bip_name(Int op, char *s) {
  bip_name(op,s);
}

#ifdef DEBUG

static void
write_address(CELL address)
{
  if (address < (CELL)AtomBase) {
    Yap_DebugErrorPutc('L');
    Yap_DebugPlWrite(MkIntTerm (address));
  } else if (address == (CELL) FAILCODE) {
    Yap_DebugPlWrite (MkAtomTerm (AtomFail));
  } else {
    char buf[32], *p = buf;

#if HAVE_SNPRINTF
    snprintf(buf,32,"%p",(void *)address);
#else
    sprintf(buf,"%p",(void *)address);
#endif
    p[31] = '\0'; /* so that I don't have to worry */
    Yap_DebugErrorPutc('0');
    Yap_DebugErrorPutc('x');
    while (*p != '\0') {
      Yap_DebugErrorPutc(*p++);
    }
  }
}

static void
write_functor(Functor f)
{
  if (IsExtensionFunctor(f)) {
    if (f == FunctorDBRef) {
      Yap_DebugPlWrite(MkAtomTerm(AtomDBREF));
    } else if (f == FunctorLongInt) {
      Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
    } else if (f == FunctorBigInt) {
      Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
    } else if (f == FunctorDouble) {
      Yap_DebugPlWrite(MkAtomTerm(AtomDOUBLE));
    } else if (f == FunctorString) {
      Yap_DebugPlWrite(MkAtomTerm(AtomSTRING));
    }
  } else {
    Yap_DebugPlWrite(MkAtomTerm(NameOfFunctor (f)));
    Yap_DebugErrorPutc ('/');
    Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor (f)));
  }
}

static void
ShowOp (const char *f, struct PSEUDO *cpc)
{
  char ch;
  Int arg = cpc->rnd1;
  Int rn = cpc->rnd2;
  CELL *cptr = cpc->arnds;

  while ((ch = *f++) != 0)
    {
      if (ch == '%')
	switch (ch = *f++)
	  {
#ifdef BEAM
	case '1':
		Yap_DebugPlWrite(MkIntTerm(rn));
		break;
	case '4':
		Yap_DebugPlWrite(MkIntTerm(arg));
		break;
#endif
	  case 'a':
	  case 'n':
	  case 'S':
	    Yap_DebugPlWrite ((Term) arg);
	    break;
	  case 'b':
	    /* write a variable bitmap for a call */
	    {
	      CACHE_REGS
	      int max = arg/(8*sizeof(CELL)), i;
	      CELL *ptr = cptr;
	      for (i = 0; i <= max; i++) {
		Yap_DebugPlWrite(MkIntegerTerm((Int)(*ptr++)));
	      }
	    }
	    break;		
	  case 'l':
	    write_address (arg);
	    break;
	  case 'B':
	    {
	      char s[32];

	      bip_name(rn,s);
	      Yap_DebugPlWrite (MkAtomTerm(Yap_LookupAtom(s)));
	    }
	    break;
	  case 'd':
	    {
	      CACHE_REGS
	      Yap_DebugPlWrite (MkIntegerTerm (arg));
	    }
	    break;
	  case 'z':
	    Yap_DebugPlWrite (MkIntTerm (cpc->rnd3));
	    break;
	  case 'v':
	    {
	      Ventry *v = (Ventry *) arg;
	      Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
	      Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
	    }
	    break;	
	  case 'N':
	    {
	      Ventry *v;

	      cpc = cpc->nextInst;
	      arg = cpc->rnd1;
	      v = (Ventry *) arg;
	      Yap_DebugErrorPutc (v->KindOfVE == PermVar ? 'Y' : 'X');
	      Yap_DebugPlWrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs));
	    }
	    break;
	  case 'm':
	    Yap_DebugPlWrite (MkAtomTerm ((Atom) arg));
	    Yap_DebugErrorPutc ('/');
	    Yap_DebugPlWrite (MkIntTerm (rn));
	    break;
	  case 'p':
	    {
	      PredEntry *p = RepPredProp ((Prop) arg);
	      Functor f = p->FunctorOfPred;
	      UInt arity = p->ArityOfPE;
	      Term mod;

	      if (p->ModuleOfPred)
		mod = p->ModuleOfPred;
	      else
		mod = TermProlog;
	      Yap_DebugPlWrite (mod);
	      Yap_DebugErrorPutc (':');
	      if (arity == 0)
		Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
	      else
		Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
	      Yap_DebugErrorPutc ('/');
	      Yap_DebugPlWrite (MkIntTerm (arity));
	    }
	    break;
	  case 'P':
	    {
	      PredEntry *p = RepPredProp((Prop) rn);
	      Functor f = p->FunctorOfPred;
	      UInt arity = p->ArityOfPE;
	      Term mod = TermProlog;

	      if (p->ModuleOfPred) mod = p->ModuleOfPred;
	      Yap_DebugPlWrite (mod);
	      Yap_DebugErrorPutc (':');
	      if (arity == 0)
		Yap_DebugPlWrite (MkAtomTerm ((Atom)f));
	      else
		Yap_DebugPlWrite (MkAtomTerm (NameOfFunctor (f)));
	      Yap_DebugErrorPutc ('/');
	      Yap_DebugPlWrite (MkIntTerm (arity));
	    }
	    break;
	  case 'f':
	    write_functor((Functor)arg);
	    break;
	  case 'r':
	    Yap_DebugErrorPutc ('A');
	    Yap_DebugPlWrite (MkIntTerm (rn));
	    break;
	  case 'h':
	    {
	      CELL my_arg = *cptr++;
	      write_address(my_arg);
	    }
	    break;
	  case 'g':
	    write_address(arg);
	    break;
	  case 'i':
	    write_address (arg);
	    break;
	  case 'j':
	    {
	      Functor fun = (Functor)*cptr++;
	      if (IsExtensionFunctor(fun)) {
		if (fun == FunctorDBRef) {
		  Yap_DebugPlWrite(MkAtomTerm(AtomDBREF));
		} else if (fun == FunctorLongInt) {
		  Yap_DebugPlWrite(MkAtomTerm(AtomLONGINT));
		} else if (fun == FunctorDouble) {
		  Yap_DebugPlWrite(MkAtomTerm(AtomDOUBLE));
		} else if (fun == FunctorString) {
		  Yap_DebugPlWrite(MkAtomTerm(AtomSTRING));
		}
	      } else {
		Yap_DebugPlWrite (MkAtomTerm(NameOfFunctor(fun)));
		Yap_DebugErrorPutc ('/');
		Yap_DebugPlWrite (MkIntTerm(ArityOfFunctor(fun)));
	      }
	    }
	    break;
	  case 'O':
	    Yap_DebugPlWrite(AbsAppl(cptr));
	    break;
	  case 'x':
	    Yap_DebugPlWrite (MkIntTerm (rn >> 1));
	    Yap_DebugErrorPutc ('\t');
	    Yap_DebugPlWrite (MkIntTerm (rn & 1));
	    break;
	  case 'w':
	    Yap_DebugPlWrite (arg);
	    break;
	  case 'o':
	    Yap_DebugPlWrite ((Term) * cptr++);
	  case 'c':
	    {
	      int i;
	      CELL *ptr = (CELL *)cptr[0];
	      for (i = 0; i < arg; ++i) {
		CELL my_arg;
		Yap_DebugErrorPutc('\t');
		if (*ptr) {
		  Yap_DebugPlWrite ((Term) *ptr++);
		} else {
		  Yap_DebugPlWrite (MkIntTerm (0));
		  ptr++;
		}
		Yap_DebugErrorPutc ('\t');
		my_arg = *ptr++;
		write_address (my_arg);
		if (i+1 < arg)
		  Yap_DebugErrorPutc ('\n');
	      }
	    }
	    break;
	  case 'e':
	    {
	      int i;
	      CELL *ptr = (CELL *)cptr[0];
	      for (i = 0; i < arg; ++i)	{
		CELL my_arg = ptr[0], lbl = ptr[1];
		Yap_DebugErrorPutc('\t');
		if (my_arg) {
		  write_functor((Functor)my_arg);
		} else {
		  Yap_DebugPlWrite(MkIntTerm (0));
		}
		Yap_DebugErrorPutc('\t');
		write_address(lbl);
		ptr += 2;
		if (i+1 < arg)
		  Yap_DebugErrorPutc('\n');
	      }
	    }
	    break;
	  default:
	    Yap_DebugErrorPutc ('%');
	    Yap_DebugErrorPutc (ch);
	  }
      else
	Yap_DebugErrorPutc (ch);
    }
  Yap_DebugErrorPutc ('\n');
}

static const char *
getFormat(compiler_vm_op ic) {
  switch( ic ) {
  case nop_op:
    return "nop";
  case get_var_op:
    return "get_var\t\t%v,%r";
  case put_var_op:
    return  "put_var\t\t%v,%r";
  case get_val_op:
    return "get_val\t\t%v,%r";
  case put_val_op:
    return "put_val\t\t%v,%r";
  case get_atom_op:
    return "get_atom\t%a,%r";
  case put_atom_op:
    return "put_atom\t%a,%r";
  case get_num_op:
    return "get_num\t\t%n,%r";
  case put_num_op:
    return "put_num\t\t%n,%r";
  case get_float_op:
    return "get_float\t\t%w,%r";
  case put_float_op:
    return "put_float\t\t%w,%r";
  case get_string_op:
    return "get_string\t\t%w,%S";
  case put_string_op:
    return "put_string\t\t%w,%S";
  case get_dbterm_op:
    return "get_dbterm\t%w,%r";
  case put_dbterm_op:
    return "put_dbterm\t%w,%r";
  case get_longint_op:
    return "get_longint\t\t%w,%r";
  case put_longint_op:
    return "put_longint\t\t%w,%r";
  case get_bigint_op:
    return "get_bigint\t\t%l,%r";
  case put_bigint_op:
    return "put_bigint\t\t%l,%r";
  case get_list_op:
    return "get_list\t%r";
  case put_list_op:
    return "put_list\t%r";
  case get_struct_op:
    return "get_struct\t%f,%r";
  case put_struct_op:
    return "put_struct\t%f,%r";
  case put_unsafe_op:
    return "put_unsafe\t%v,%r";
  case unify_var_op:
    return "unify_var\t%v";
  case write_var_op:
    return "write_var\t%v";
  case unify_val_op:
    return "unify_val\t%v";
  case write_val_op:
    return "write_val\t%v";
  case unify_atom_op:
    return "unify_atom\t%a";
  case write_atom_op:
    return "write_atom\t%a";
  case unify_num_op:
    return "unify_num\t%n";
  case write_num_op:
    return "write_num\t%n";
  case unify_float_op:
    return "unify_float\t%w";
  case write_float_op:
    return "write_float\t%w";
  case unify_string_op:
    return "unify_string\t%S";
  case write_string_op:
    return "write_string\t%S";
  case unify_dbterm_op:
    return "unify_dbterm\t%w";
  case write_dbterm_op:
    return "write_dbterm\t%w";
  case unify_longint_op:
    return "unify_longint\t%w";
  case write_longint_op:
    return "write_longint\t%w";
  case unify_bigint_op:
    return "unify_bigint\t%l";
  case write_bigint_op:
    return "write_bigint\t%l";
  case unify_list_op:
    return "unify_list";
  case write_list_op:
    return "write_list";
  case unify_struct_op:
    return "unify_struct\t%f";
  case write_struct_op:
    return "write_struct\t%f";
  case write_unsafe_op:
    return "write_unsafe\t%v";
  case unify_local_op:
    return "unify_local\t%v";
  case write_local_op:
    return "write local\t%v";
  case unify_last_list_op:
    return "unify_last_list";
  case write_last_list_op:
    return "write_last_list";
  case unify_last_struct_op:
    return "unify_last_struct\t%f";
  case write_last_struct_op:
    return "write_last_struct\t%f";
  case unify_last_var_op:
    return "unify_last_var\t%v";
  case unify_last_val_op:
    return "unify_last_val\t%v";
  case unify_last_local_op:
    return "unify_last_local\t%v";
  case unify_last_atom_op:
    return "unify_last_atom\t%a";
  case unify_last_num_op:
    return "unify_last_num\t%n";
  case unify_last_float_op:
     return "unify_last_float\t%w";
  case unify_last_string_op:
     return "unify_last_string\t%S";
  case unify_last_dbterm_op:
    return "unify_last_dbterm\t%w";
  case unify_last_longint_op:
    return "unify_last_longint\t%w";
  case unify_last_bigint_op:
    return "unify_last_bigint\t%l";
  case ensure_space_op:
    return "ensure_space";
  case native_op:
    return "native_code";
  case f_var_op:
    return "function_to_var\t%v,%B";
  case f_val_op:
    return "function_to_val\t%v,%B";
  case f_0_op:
    return "function_to_0\t%B";
  case align_float_op:
    return "align_float";
  case fail_op:
    return "fail";
  case cut_op:
    return "cut";
  case cutexit_op:
    return "cutexit";
  case allocate_op:
    return "allocate";
  case deallocate_op:
    return "deallocate";
  case tryme_op:
    return "try_me_else\t\t%l\t%x";
  case jump_op:
    return "jump\t\t%l";
  case jumpi_op:
    return "jump_in_indexing\t\t%i";
  case procceed_op:
    return "proceed";
  case call_op:
    return "call\t\t%p,%d,%z";
  case execute_op:
    return "execute\t\t%p";
  case safe_call_op:
    return "sys\t\t%p";
  case label_op:
    return "%l:";
  case name_op:
    return "name\t\t%m,%d";
  case pop_op:
    return "pop\t\t%l";
  case retryme_op:
    return "retry_me_else\t\t%l\t%x";
  case trustme_op:
    return "trust_me_else_fail\t%x";
  case either_op:
    return "either_me\t\t%l,%d,%z";
  case orelse_op:
    return "or_else\t\t%l,%z";
  case orlast_op:
    return "or_last";
  case push_or_op:
    return "push_or";
  case pop_or_op:
    return "pop_or";
  case pushpop_or_op:
    return "pushpop_or";
  case save_b_op:
    return "save_by\t\t%v";
  case commit_b_op:
    return "commit_by\t\t%v";
  case patch_b_op:
    return "patch_by\t\t%v";
  case try_op:
    return "try\t\t%g\t%x";
  case retry_op:
    return "retry\t\t%g\t%x";
  case trust_op:
    return "trust\t\t%g\t%x";
  case try_in_op:
    return "try_in\t\t%g\t%x";
  case jump_v_op:
    return "jump_if_var\t\t%g";
  case jump_nv_op:
    return "jump_if_nonvar\t\t%g";
  case cache_arg_op:
    return "cache_arg\t%r";
  case cache_sub_arg_op:
    return "cache_sub_arg\t%d";
  case user_switch_op:
    return "user_switch";
  case switch_on_type_op:
    return "switch_on_type\t%h\t%h\t%h\t%h";
  case switch_c_op:
    return "switch_on_constant\t%i\n%c";
  case if_c_op:
    return "if_constant\t%i\n%c";
  case switch_f_op:
    return "switch_on_functor\t%i\n%e";
  case if_f_op:
    return "if_functor\t%i\n%e";
  case if_not_op:
    return "if_not_then\t%i\t%h\t%h\t%h";
  case index_dbref_op:
    return "index_on_dbref";
  case index_blob_op:
    return "index_on_blob";
  case index_long_op:
    return "index_on_blob";
  case index_string_op:
    return "index_on_string";
  case 	if_nonvar_op:
    return "check_var\t %r";
  case save_pair_op:
    return "save_pair\t%v";
  case save_appl_op:
    return "save_appl\t%v";
  case mark_initialised_pvars_op:
    return "pvar_bitmap\t%l,%b";
  case mark_live_regs_op:
    return "pvar_live_regs\t%l,%b";
  case fetch_args_vv_op:
    return "fetch_reg1_reg2\t%N,%N";
  case fetch_args_cv_op:
    return "fetch_constant_reg\t%l,%N";
  case fetch_args_vc_op:
    return "fetch_reg_constant\t%l,%N";
  case fetch_args_iv_op:
    return "fetch_integer_reg\t%d,%N";
  case fetch_args_vi_op:
    return "fetch_reg_integer\t%d,%N";
  case enter_profiling_op:
    return "enter_profiling\t\t%g";
  case retry_profiled_op:
    return "retry_profiled\t\t%g";
  case count_call_op:
    return "count_call_op\t\t%g";
  case count_retry_op:
    return "count_retry_op\t\t%g";
  case restore_tmps_op:
    return "restore_temps\t\t%l";
  case restore_tmps_and_skip_op:
    return "restore_temps_and_skip\t\t%l";
  case enter_lu_op:
    return "enter_lu";
  case empty_call_op:
    return "empty_call\t\t%l,%d";
#ifdef YAPOR
  case sync_op:
    return "sync";
#endif /* YAPOR */
#ifdef TABLING
  case table_new_answer_op:
    return "table_new_answer";
  case table_try_single_op:
    return "table_try_single\t%g\t%x";
#endif /* TABLING */
#ifdef TABLING_INNER_CUTS
  case "clause_with_cut":
    return clause_with_cut_op;
#endif /* TABLING_INNER_CUTS */
#ifdef BEAM
  "run_op %1,%4",
  "body_op %1",
  "endgoal_op",
  "try_me_op %1,%4",
  "retry_me_op %1,%4",
  "trust_me_op %1,%4",
  "only_1_clause_op %1,%4",
  "create_first_box_op %1,%4",
  "create_box_op %1,%4",
  "create_last_box_op %1,%4",
  "remove_box_op %1,%4",
  "remove_last_box_op %1,%4",
  "prepare_tries",
  "std_base_op %1,%4",
  "direct_safe_call",
  "skip_while_var_op",
  "wait_while_var_op",
  "force_wait_op",
  "write_op",
  "is_op",
  "equal_op",
  "exit",
#endif
  case fetch_args_for_bccall_op:
    return "fetch_args_for_bccall\t%v";
  case bccall_op:
    return "binary_cfunc\t\t%v,%P";
  case blob_op:
    return "blob\t%O";
  case string_op:
    return "string\t%O";
  case label_ctl_op:
    return "label_control\t";
#ifdef SFUNC
  ,
  "get_s_f_op\t%f,%r",
  "put_s_f_op\t%f,%r",
  "unify_s_f_op\t%f",
  "write_s_f_op\t%f",
  "unify_s_var\t%v,%r",
  "write_s_var\t%v,%r",
  "unify_s_val\t%v,%r",
  "write_s_val\t%v,%r",
  "unify_s_a\t%a,%r",
  "write_s_a\t%a,%r",
  "get_s_end",
  "put_s_end",
  "unify_s_end",
  "write_s_end"
#endif
    }
  return NULL;
}

void
Yap_ShowCode (struct intermediates *cint)
{
  CACHE_REGS
  struct PSEUDO *cpc;

  cpc = cint->CodeStart;
  /* MkIntTerm and friends may build terms in the global stack */
  HR = (CELL *)cint->freep;
  while (cpc) {
    compiler_vm_op ic = cpc->op;
    if (ic != nop_op) {
      }
    ShowOp (getFormat(ic), cpc);
    cpc = cpc->nextInst;
  }
  Yap_DebugErrorPutc ('\n');
}

#endif /* DEBUG */