1027 lines
23 KiB
C
1027 lines
23 KiB
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 */
|
|
|